Clean up and optimise performance.

src/Oracles/DependencyList.hs

@@ -21,7 +21,7 @@ newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
 dependencyList :: FilePath -> FilePath -> Action [FilePath]
 dependencyList depFile objFile = do
     res <- askOracle $ DependencyListKey (depFile, objFile)
-    return $ fromMaybe [] res
+    return . fromMaybe [] $ res
 
 -- Oracle for 'path/dist/*.deps' files
 dependencyListOracle :: Rules ()
@@ -30,11 +30,11 @@ dependencyListOracle = do
         need [file]
         putOracle $ "Reading " ++ file ++ "..."
         contents <- parseMakefile <$> (liftIO $ readFile file)
-        return $ Map.fromList
-               $ map (bimap unifyPath (map unifyPath))
-               $ map (bimap head concat . unzip)
-               $ groupBy ((==) `on` fst)
-               $ sortBy (compare `on` fst) contents
+        return . Map.fromList
+               . map (bimap unifyPath (map unifyPath))
+               . map (bimap head concat . unzip)
+               . groupBy ((==) `on` fst)
+               . sortBy (compare `on` fst) $ contents
     addOracle $ \(DependencyListKey (file, obj)) ->
         Map.lookup (unifyPath obj) <$> deps (unifyPath file)
     return ()

src/Settings/Util.hs

@@ -84,7 +84,7 @@ getHsSources = do
 
     (foundSources, missingSources) <- findModuleFiles dirs "*hs"
 
-    -- Generated source files will live in buildPath and have extension "hs"
+    -- Generated source files live in buildPath and have extension "hs"
     let generatedSources = map (\f -> buildPath -/- f <.> "hs") missingSources
 
     return $ foundSources ++ generatedSources
@@ -103,18 +103,21 @@ decodeModule = splitFileName . replaceEq '.' '/'
 -- * 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
+findModuleFiles dirs extension = do
     modules <- getPkgDataList Modules
-    let decodedMods = sort . map decodeModule $ modules
-        modDirFiles = map (bimap head sort . unzip)
-                    . groupBy ((==) `on` fst) $ decodedMods
+    let decodedMods    = sort . map decodeModule $ modules
+        modDirFiles    = map (bimap head sort . unzip)
+                       . groupBy ((==) `on` fst) $ decodedMods
+        matchExtension = (?==) ("*" <.> extension)
 
     result <- lift . fmap concat . forM dirs $ \dir -> do
         todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
         forM todo $ \(mDir, mFiles) -> do
-            let files = [ dir -/- mDir -/- mFile <.> ext | mFile <- mFiles ]
-            found <- fmap (map unifyPath) $ getDirectoryFiles "" files
-            return (found, (mDir, map takeBaseName found))
+            let fullDir = dir -/- mDir
+            files <- fmap (filter matchExtension) $ getDirectoryContents fullDir
+            let cmp fe f = compare (dropExtension fe) f
+                found    = intersectOrd cmp files mFiles
+            return (map (fullDir -/-) found, (mDir, map dropExtension found))
 
     let foundFiles   = concatMap fst result
         foundMods    = [ (d, f) | (d, fs) <- map snd result, f <- fs ]

src/Util.hs

@@ -6,7 +6,7 @@ module Util (
     unifyPath, (-/-),
     chunksOfSize,
     putColoured, redError, redError_,
-    bimap, minusOrd
+    bimap, minusOrd, intersectOrd
     ) where
 
 import Data.Char
@@ -71,7 +71,7 @@ redError_ = void . redError
 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
+-- Depending on Data.List.Ordered only for these two functions seems an overkill
 minusOrd :: Ord a => [a] -> [a] -> [a]
 minusOrd [] _  = []
 minusOrd xs [] = xs
@@ -79,3 +79,13 @@ 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
+
+intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
+intersectOrd cmp = loop
+  where
+    loop [] _ = []
+    loop _ [] = []
+    loop (x:xs) (y:ys) = case cmp x y of
+         LT ->     loop xs (y:ys)
+         EQ -> x : loop xs ys
+         GT ->     loop (x:xs) ys