Commit a1819f6a authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor rules, clean up code.

parent a93823be
......@@ -35,12 +35,12 @@ configOracle = do
++ (defaultConfig <.> "in")
++ "' is missing; unwilling to proceed."
need [defaultConfig]
putOracle $ "Parsing " ++ unifyPath defaultConfig ++ "..."
putOracle $ "Reading " ++ unifyPath defaultConfig ++ "..."
cfgDefault <- liftIO $ readConfigFile defaultConfig
existsUser <- doesFileExist userConfig
cfgUser <- if existsUser
then do
putOracle $ "Parsing "
putOracle $ "Reading "
++ unifyPath userConfig ++ "..."
liftIO $ readConfigFile userConfig
else do
......@@ -59,7 +59,7 @@ packageDataOracle :: Rules ()
packageDataOracle = do
pkgData <- newCache $ \file -> do
need [file]
putOracle $ "Parsing " ++ file ++ "..."
putOracle $ "Reading " ++ file ++ "..."
liftIO $ readConfigFile file
addOracle $ \(PackageDataKey (file, key)) ->
M.lookup key <$> pkgData (unifyPath file)
......@@ -70,7 +70,7 @@ dependencyOracle :: Rules ()
dependencyOracle = do
deps <- newCache $ \file -> do
need [file]
putOracle $ "Parsing " ++ file ++ "..."
putOracle $ "Reading " ++ file ++ "..."
contents <- parseMakefile <$> (liftIO $ readFile file)
return $ M.fromList
$ map (bimap unifyPath (map unifyPath))
......
......@@ -19,6 +19,7 @@ import Base
import Ways
import Util
import Oracles
import qualified System.Directory as S
data Settings = Settings
{
......@@ -137,19 +138,23 @@ pkgLibHsObjects path dist stage way = do
split <- splitObjects stage
if split
then do
let suffixes = ["_" ++ osuf way ++ "_split//*"]
findModuleFiles pathDist [buildDir] suffixes
let suffix = "_" ++ osuf way ++ "_split/*." ++ osuf way
findModuleFiles pathDist [buildDir] [suffix]
else pkgDepHsObjects path dist way
findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
findModuleFiles pathDist directories suffixes = do
modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
fileList <- forM directories $ \dir ->
forM modPaths $ \modPath ->
forM suffixes $ \suffix -> do
let file = dir </> modPath ++ suffix
when (doesDirectoryExist $ dropFileName file) $ return file
files <- getDirectoryFiles "" $ concat $ concat fileList
fileList <- forM [ dir </> modPath ++ suffix
| dir <- directories
, modPath <- modPaths
, suffix <- suffixes
] $ \file -> do
let dir = takeDirectory file
dirExists <- liftIO $ S.doesDirectoryExist dir
when dirExists $ return file
files <- getDirectoryFiles "" fileList
return $ map unifyPath files
-- The argument list has a limited size on Windows. Since Windows 7 the limit
......
......@@ -38,42 +38,41 @@ gccArgs (Package _ path _) (_, dist, _) srcs result =
, args ("-c":srcs)
, args ["-o", result] ]
compileC :: Package -> TodoItem -> [FilePath] -> FilePath -> Action ()
compileC pkg todo @ (stage, _, _) deps obj = do
need deps
let srcs = filter ("//*.c" ?==) deps
run (Gcc stage) $ gccArgs pkg todo srcs obj
compileHaskell :: Package -> TodoItem -> FilePath -> Way -> Action ()
compileHaskell pkg @ (Package _ path _) todo @ (stage, dist, _) obj way = do
let buildDir = unifyPath $ path </> dist </> "build"
-- TODO: keep only vanilla dependencies in 'haskell.deps'
deps <- args $ DependencyList (buildDir </> "haskell.deps") obj
need deps
let srcs = filter ("//*hs" ?==) deps
run (Ghc stage) $ ghcArgs pkg todo way srcs obj
buildRule :: Package -> TodoItem -> Rules ()
buildRule pkg @ (Package name path _) todo @ (stage, dist, _) =
let buildDir = unifyPath $ path </> dist </> "build"
hDepFile = buildDir </> "haskell.deps"
cDepFile = buildDir </> "c.deps"
in
forM_ allWays $ \way -> do -- TODO: optimise (too many ways in allWays)
let oPattern = "*." ++ osuf way
let hiPattern = "*." ++ hisuf way
(buildDir <//> hiPattern) %> \out -> do
let obj = out -<.> osuf way
(buildDir <//> hiPattern) %> \hi -> do
let obj = hi -<.> osuf way
need [obj]
(buildDir <//> oPattern) %> \obj -> do
need [argListPath argListDir pkg stage]
let vanillaObj = obj -<.> "o"
-- TODO: keep only vanilla dependencies in hDepFile
hDeps <- args $ DependencyList hDepFile obj
cDeps <- args $ DependencyList cDepFile $ takeFileName vanillaObj
let hSrcs = filter ("//*hs" ?==) hDeps
cSrcs = filter ("//*.c" ?==) cDeps
-- Report impossible cases
when (null $ hSrcs ++ cSrcs)
$ redError_ $ "No source files found for "
++ unifyPath obj ++ "."
when (not (null hSrcs) && not (null cSrcs))
$ redError_ $ "Both c and Haskell sources found for "
++ unifyPath obj ++ "."
-- Build using appropriate compiler
need $ hDeps ++ cDeps
when (not $ null hSrcs)
$ run (Ghc stage) $ ghcArgs pkg todo way hSrcs obj
when (not $ null cSrcs)
$ run (Gcc stage) $ gccArgs pkg todo cSrcs obj
let vanillaObjName = takeFileName obj -<.> "o"
cDeps <- args $ DependencyList cDepFile vanillaObjName
if null cDeps
then compileHaskell pkg todo obj way
else compileC pkg todo cDeps obj
argListRule :: Package -> TodoItem -> Rules ()
argListRule pkg todo @ (stage, _, settings) =
......
......@@ -11,32 +11,28 @@ arArgs objs result = args [ arg "q"
, arg result
, args objs ]
ldArgs :: Stage -> [FilePath] -> FilePath -> Args
ldArgs stage objs result = args [ args $ ConfLdLinkerArgs stage
, arg "-r"
, arg "-o"
, arg result
, args objs ]
arRule :: Package -> TodoItem -> Rules ()
arRule pkg @ (Package _ path _) todo @ (stage, dist, _) =
let buildDir = path </> dist </> "build"
in
(buildDir <//> "*a") %> \out -> do
let way = detectWay $ tail $ takeExtension out
depHsObjs <- pkgDepHsObjects path dist way
cObjs <- pkgCObjects path dist way
need $ [argListPath argListDir pkg stage] ++ depHsObjs ++ cObjs
hsObjs <- pkgDepHsObjects path dist way
need $ [argListPath argListDir pkg stage] ++ cObjs ++ hsObjs
libHsObjs <- pkgLibHsObjects path dist stage way
liftIO $ removeFiles "." [out]
-- Splitting argument list into chunks as otherwise Ar chokes up
maxChunk <- argSizeLimit
forM_ (chunksOfSize maxChunk $ libHsObjs ++ cObjs) $ \os -> do
run Ar $ arArgs os $ unifyPath out
ldArgs :: Package -> TodoItem -> FilePath -> Args
ldArgs (Package _ path _) (stage, dist, _) result = do
hObjs <- pkgDepHsObjects path dist vanilla
cObjs <- pkgCObjects path dist vanilla
need $ hObjs ++ cObjs
args [ args $ ConfLdLinkerArgs stage
, arg "-r"
, arg "-o"
, arg result
, args $ hObjs ++ cObjs ]
forM_ (chunksOfSize maxChunk $ cObjs ++ libHsObjs) $ \objs -> do
run Ar $ arArgs objs $ unifyPath out
ldRule :: Package -> TodoItem -> Rules ()
ldRule pkg @ (Package name path _) todo @ (stage, dist, _) =
......@@ -44,11 +40,13 @@ ldRule pkg @ (Package name path _) todo @ (stage, dist, _) =
buildDir = pathDist </> "build"
in
priority 2 $ (buildDir </> "*.o") %> \out -> do
need [argListPath argListDir pkg stage]
run Ld $ ldArgs pkg todo $ unifyPath out
cObjs <- pkgCObjects path dist vanilla
hObjs <- pkgDepHsObjects path dist vanilla
need $ [argListPath argListDir pkg stage] ++ cObjs ++ hObjs
run Ld $ ldArgs stage (cObjs ++ hObjs) $ unifyPath out
synopsis <- dropWhileEnd isPunctuation <$> showArg (Synopsis pathDist)
putColoured Green $ "/--------\n| Successfully built package "
++ name ++ " (stage " ++ show stage ++ ")."
putColoured Green $ "/--------\n| Successfully built package '"
++ name ++ "' (stage " ++ show stage ++ ")."
putColoured Green $ "| Package synopsis: " ++ synopsis ++ "."
++ "\n\\--------"
......@@ -56,16 +54,18 @@ argListRule :: Package -> TodoItem -> Rules ()
argListRule pkg @ (Package _ path _) todo @ (stage, dist, settings) =
(argListPath argListDir pkg stage) %> \out -> do
need $ ["shake/src/Package/Library.hs"] ++ sourceDependecies
ways' <- ways settings
ldList <- argList Ld (ldArgs pkg todo "output.o")
arList <- forM ways' $ \way -> do
cObjs <- pkgCObjects path dist way
hObjs <- pkgLibHsObjects path dist stage way
ext <- libsuf way
cObjsV <- pkgCObjects path dist vanilla
hsObjsV <- pkgDepHsObjects path dist vanilla
ldList <- argList Ld $ ldArgs stage (cObjsV ++ hsObjsV) "output.o"
ways' <- ways settings
arList <- forM ways' $ \way -> do
cObjs <- pkgCObjects path dist way
hsObjs <- pkgLibHsObjects path dist stage way
suffix <- libsuf way
argListWithComment
("way '" ++ tag way ++ "'")
Ar
(arArgs (hObjs ++ cObjs) $ "output" <.> ext)
(arArgs (cObjs ++ hsObjs) $ "output" <.> suffix)
writeFileChanged out $ unlines $ [ldList] ++ arList
buildPackageLibrary :: Package -> TodoItem -> Rules ()
......
......@@ -9,6 +9,7 @@ libraryPackagesInStage :: Stage -> [String]
libraryPackagesInStage Stage0 =
[ "bin-package-db"
, "binary"
, "Cabal/Cabal"
, "hoopl"
, "hpc"
, "transformers" ]
......@@ -16,7 +17,6 @@ libraryPackagesInStage Stage1 =
libraryPackagesInStage Stage0 ++
[ "array"
, "bytestring"
, "Cabal/Cabal"
, "containers"
, "deepseq"
, "directory"
......
......@@ -130,7 +130,6 @@ dropDynamic way
-- Detect way from a given extension. Fail if the result is not unique.
-- TODO: This may be slow -- optimise if overhead is significant.
-- TODO: No longer needed -- remove?
detectWay :: FilePath -> Way
detectWay extension =
let prefix = reverse $ dropWhile (/= '_') $ reverse extension
......
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