Commit 7a936b63 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Clean up and optimise performance.

parent 0be1b62e
......@@ -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 ()
......@@ -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
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 ]
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment