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) ...@@ -21,7 +21,7 @@ newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
dependencyList :: FilePath -> FilePath -> Action [FilePath] dependencyList :: FilePath -> FilePath -> Action [FilePath]
dependencyList depFile objFile = do dependencyList depFile objFile = do
res <- askOracle $ DependencyListKey (depFile, objFile) res <- askOracle $ DependencyListKey (depFile, objFile)
return $ fromMaybe [] res return . fromMaybe [] $ res
-- Oracle for 'path/dist/*.deps' files -- Oracle for 'path/dist/*.deps' files
dependencyListOracle :: Rules () dependencyListOracle :: Rules ()
...@@ -30,11 +30,11 @@ dependencyListOracle = do ...@@ -30,11 +30,11 @@ dependencyListOracle = do
need [file] need [file]
putOracle $ "Reading " ++ file ++ "..." putOracle $ "Reading " ++ file ++ "..."
contents <- parseMakefile <$> (liftIO $ readFile file) contents <- parseMakefile <$> (liftIO $ readFile file)
return $ Map.fromList return . Map.fromList
$ map (bimap unifyPath (map unifyPath)) . map (bimap unifyPath (map unifyPath))
$ map (bimap head concat . unzip) . map (bimap head concat . unzip)
$ groupBy ((==) `on` fst) . groupBy ((==) `on` fst)
$ sortBy (compare `on` fst) contents . sortBy (compare `on` fst) $ contents
addOracle $ \(DependencyListKey (file, obj)) -> addOracle $ \(DependencyListKey (file, obj)) ->
Map.lookup (unifyPath obj) <$> deps (unifyPath file) Map.lookup (unifyPath obj) <$> deps (unifyPath file)
return () return ()
...@@ -84,7 +84,7 @@ getHsSources = do ...@@ -84,7 +84,7 @@ getHsSources = do
(foundSources, missingSources) <- findModuleFiles dirs "*hs" (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 let generatedSources = map (\f -> buildPath -/- f <.> "hs") missingSources
return $ foundSources ++ generatedSources return $ foundSources ++ generatedSources
...@@ -103,18 +103,21 @@ decodeModule = splitFileName . replaceEq '.' '/' ...@@ -103,18 +103,21 @@ decodeModule = splitFileName . replaceEq '.' '/'
-- * a list of module files that have not been found, with paths being relative -- * 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. -- to the module directory, e.g. "CodeGen/Platform", and with no extension.
findModuleFiles :: [FilePath] -> FilePattern -> Expr ([FilePath], [FilePath]) findModuleFiles :: [FilePath] -> FilePattern -> Expr ([FilePath], [FilePath])
findModuleFiles dirs ext = do findModuleFiles dirs extension = do
modules <- getPkgDataList Modules modules <- getPkgDataList Modules
let decodedMods = sort . map decodeModule $ modules let decodedMods = sort . map decodeModule $ modules
modDirFiles = map (bimap head sort . unzip) modDirFiles = map (bimap head sort . unzip)
. groupBy ((==) `on` fst) $ decodedMods . groupBy ((==) `on` fst) $ decodedMods
matchExtension = (?==) ("*" <.> extension)
result <- lift . fmap concat . forM dirs $ \dir -> do result <- lift . fmap concat . forM dirs $ \dir -> do
todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
forM todo $ \(mDir, mFiles) -> do forM todo $ \(mDir, mFiles) -> do
let files = [ dir -/- mDir -/- mFile <.> ext | mFile <- mFiles ] let fullDir = dir -/- mDir
found <- fmap (map unifyPath) $ getDirectoryFiles "" files files <- fmap (filter matchExtension) $ getDirectoryContents fullDir
return (found, (mDir, map takeBaseName found)) 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 let foundFiles = concatMap fst result
foundMods = [ (d, f) | (d, fs) <- map snd result, f <- fs ] foundMods = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
......
...@@ -6,7 +6,7 @@ module Util ( ...@@ -6,7 +6,7 @@ module Util (
unifyPath, (-/-), unifyPath, (-/-),
chunksOfSize, chunksOfSize,
putColoured, redError, redError_, putColoured, redError, redError_,
bimap, minusOrd bimap, minusOrd, intersectOrd
) where ) where
import Data.Char import Data.Char
...@@ -71,7 +71,7 @@ redError_ = void . redError ...@@ -71,7 +71,7 @@ redError_ = void . redError
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f g (x, y) = (f x, g y) 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 :: Ord a => [a] -> [a] -> [a]
minusOrd [] _ = [] minusOrd [] _ = []
minusOrd xs [] = xs minusOrd xs [] = xs
...@@ -79,3 +79,13 @@ minusOrd (x:xs) (y:ys) = case compare x y of ...@@ -79,3 +79,13 @@ minusOrd (x:xs) (y:ys) = case compare x y of
LT -> x : minusOrd xs (y:ys) LT -> x : minusOrd xs (y:ys)
EQ -> minusOrd xs ys EQ -> minusOrd xs ys
GT -> minusOrd (x: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