[commit: ghc] wip/nfs-locking: Refactor findModuleFiles and add comments. (0be1b62)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/0be1b62e3ca05ce9e4c3da40e972aab9e42f991f/ghc

>---------------------------------------------------------------

commit 0be1b62e3ca05ce9e4c3da40e972aab9e42f991f
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sat Aug 1 00:19:04 2015 +0100

    Refactor findModuleFiles and add comments.


>---------------------------------------------------------------

0be1b62e3ca05ce9e4c3da40e972aab9e42f991f
 src/Settings/Util.hs | 62 ++++++++++++++++++++++++++++------------------------
 src/Util.hs          | 11 +++++++++-
 2 files changed, 44 insertions(+), 29 deletions(-)

diff --git a/src/Settings/Util.hs b/src/Settings/Util.hs
index 1901a8c..3ea13e3 100644
--- a/src/Settings/Util.hs
+++ b/src/Settings/Util.hs
@@ -5,7 +5,7 @@ module Settings.Util (
     getFlag, getSetting, getSettingList,
     getPkgData, getPkgDataList,
     getPackagePath, getTargetPath, getTargetDirectory,
-    getHsSources, getSourceFiles,
+    getHsSources,
     appendCcArgs,
     needBuilder
     -- argBuilderPath, argStagedBuilderPath,
@@ -78,44 +78,50 @@ getHsSources = do
     path    <- getTargetPath
     pkgPath <- getPackagePath
     srcDirs <- getPkgDataList SrcDirs
+
+    let buildPath = path -/- "build"
+        dirs      = (buildPath -/- "autogen") : map (pkgPath -/-) srcDirs
+
+    (foundSources, missingSources) <- findModuleFiles dirs "*hs"
+
+    -- Generated source files will live in buildPath and have extension "hs"
+    let generatedSources = map (\f -> buildPath -/- f <.> "hs") missingSources
+
+    return $ foundSources ++ generatedSources
+
+-- Given a module name extract the directory and file names, e.g.:
+-- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
+decodeModule :: String -> (FilePath, String)
+decodeModule = splitFileName . replaceEq '.' '/'
+
+-- findModuleFiles scans a list of given directories and finds files matching a
+-- given extension pattern (e.g., "*hs") that correspond to modules of the
+-- currently built package. Missing module files are returned in a separate
+-- list. The returned pair contains the following:
+-- * a list of found module files, with paths being relative to one of given
+--   directories, e.g. "codeGen/CodeGen/Platform.hs" for the compiler package.
+-- * a list of module files that have not been found, with paths being relative
+--   to the module directory, e.g. "CodeGen/Platform", and with no extension.
+findModuleFiles :: [FilePath] -> FilePattern -> Expr ([FilePath], [FilePath])
+findModuleFiles dirs ext = do
     modules <- getPkgDataList Modules
-    let buildPath   = path -/- "build"
-        autogenPath = buildPath -/- "autogen"
-        dirs        = autogenPath : map (pkgPath -/-) srcDirs
-        decodedMods = sort $ map decodeModule modules
+    let decodedMods = sort . map decodeModule $ modules
         modDirFiles = map (bimap head sort . unzip)
-                    $ groupBy ((==) `on` fst) decodedMods
+                    . groupBy ((==) `on` fst) $ decodedMods
 
     result <- lift . fmap concat . forM dirs $ \dir -> do
         todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
         forM todo $ \(mDir, mFiles) -> do
-            let files = [ dir -/- mDir -/- mFile <.> "*hs" | mFile <- mFiles ]
+            let files = [ dir -/- mDir -/- mFile <.> ext | mFile <- mFiles ]
             found <- fmap (map unifyPath) $ getDirectoryFiles "" files
             return (found, (mDir, map takeBaseName found))
 
-    let foundSources = concatMap fst result
+    let foundFiles   = concatMap fst result
         foundMods    = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
-        leftMods     = decodedMods \\ sort foundMods
-        genSources   = map (\(d, f) -> buildPath -/- d -/- f <.> "hs") leftMods
-
-    return $ foundSources ++ genSources
-
--- Given a module name extract the directory and file names, e.g.:
--- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
-decodeModule :: String -> (FilePath, FilePath)
-decodeModule = splitFileName . replaceEq '.' '/'
+        missingMods  = decodedMods `minusOrd` sort foundMods
+        missingFiles = map (uncurry (-/-)) missingMods
 
-    -- getSourceFiles paths [".hs", ".lhs"]
-
--- Find all source files in specified paths and with given extensions
-getSourceFiles :: [FilePath] -> [String] -> Expr [FilePath]
-getSourceFiles paths exts = do
-    modules <- getPkgDataList Modules
-    let modPaths   = map (replaceEq '.' '/') modules
-        candidates = [ p -/- m ++ e | p <- paths, m <- modPaths, e <- exts ]
-    files <- lift $ filterM (doesDirectoryExist . takeDirectory) candidates
-    result <- lift $ getDirectoryFiles "" files
-    return $ map unifyPath result
+    return (foundFiles, missingFiles)
 
 -- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
 appendCcArgs :: [String] -> Args
diff --git a/src/Util.hs b/src/Util.hs
index fd33e73..31c0e6a 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -6,7 +6,7 @@ module Util (
     unifyPath, (-/-),
     chunksOfSize,
     putColoured, redError, redError_,
-    bimap
+    bimap, minusOrd
     ) where
 
 import Data.Char
@@ -70,3 +70,12 @@ redError_ = void . redError
 -- Depending on Data.Bifunctor only for this function seems an overkill
 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
 bimap f g (x, y) = (f x, g y)
+
+-- Depending on Data.List.Ordered only for this function seems an overkill
+minusOrd :: Ord a => [a] -> [a] -> [a]
+minusOrd [] _  = []
+minusOrd xs [] = xs
+minusOrd (x:xs) (y:ys) = case compare x y of
+    LT -> x : minusOrd xs (y:ys)
+    EQ ->     minusOrd xs ys
+    GT ->     minusOrd (x:xs) ys