Commit 28a80787 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Clean up.

parent 4bd88123
......@@ -9,8 +9,8 @@ module Expression (
apply, append, appendM, remove,
appendSub, appendSubD, filterSub, removeSub,
interpret, interpretExpr,
getStage, getPackage, getBuilder, getFiles, getWay,
stage, package, builder, file, way
getStage, getPackage, getBuilder, getFiles, getFile, getWay,
stage, package, builder, stagedBuilder, file, way
) where
import Way
......@@ -164,6 +164,15 @@ getBuilder = asks Target.builder
getFiles :: Expr [FilePath]
getFiles = asks Target.files
-- Run getFiles and check that it contains a single file only
getFile :: Expr FilePath
getFile = do
target <- ask
files <- getFiles
case files of
[file] -> return file
_ -> error $ "Exactly one file expected in target " ++ show target
getWay :: Expr Way
getWay = asks Target.way
......@@ -174,9 +183,17 @@ stage s = liftM (s ==) getStage
package :: Package -> Predicate
package p = liftM (p ==) getPackage
-- For unstaged builders, e.g. GhcCabal
builder :: Builder -> Predicate
builder b = liftM (b ==) getBuilder
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = do
stage <- getStage
builder <- getBuilder
return $ builder == sb stage
file :: FilePattern -> Predicate
file f = liftM (any (f ?==)) getFiles
......
......@@ -26,8 +26,8 @@ import qualified System.Directory as S
--pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
--pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
prefixedPath :: String -> [Settings] -> Settings
prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
-- prefixedPath :: String -> [Settings] -> Settings
-- prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
--includeGccArgs :: FilePath -> FilePath -> Args
--includeGccArgs path dist =
......@@ -38,34 +38,34 @@ prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
-- , pathArgs "-I" path $ DepIncludeDirs pathDist ]
includeGccSettings :: Settings
includeGccSettings = mconcat
[ prefixedPath "-I" [argBuildPath, argBuildDir, arg "build", arg "autogen"]
, argPrefix "-I" $ argPaths ...
, prefixedPath "-I" [argBuildPath, argIncludeDirs ] -- wrong
, prefixedPath "-I" [argBuildPath, argDepIncludeDirs ]]
includeGhcSettings :: Settings
includeGhcSettings =
let buildDir = argBuildPath `fence` argSrcDirs
in arg "-i" `fence`
mconcat
[ argPathList "-i" [argBuildPath, argSrcDirs]
, argPath "-i" buildDir
, argPath "-I" buildDir
, argPathList "-i" [buildDir, arg "autogen"]
, argPathList "-I" [buildDir, arg "autogen"]
, argPathList "-I" [argBuildPath, argIncludeDirs]
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, argPathList "-optP" [buildDir, arg "autogen/cabal_macros.h"] ]
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
pkgHsSources path dist = do
let pathDist = path </> dist
autogen = pathDist </> "build/autogen"
dirs <- map (path </>) <$> args (SrcDirs pathDist)
findModuleFiles pathDist (autogen:dirs) [".hs", ".lhs"]
-- includeGccSettings :: Settings
-- includeGccSettings = mconcat
-- [ prefixedPath "-I" [argBuildPath, argBuildDir, arg "build", arg "autogen"]
-- , argPrefix "-I" $ argPaths ...
-- , prefixedPath "-I" [argBuildPath, argIncludeDirs ] -- wrong
-- , prefixedPath "-I" [argBuildPath, argDepIncludeDirs ]]
-- includeGhcSettings :: Settings
-- includeGhcSettings =
-- let buildDir = argBuildPath `fence` argSrcDirs
-- in arg "-i" `fence`
-- mconcat
-- [ argPathList "-i" [argBuildPath, argSrcDirs]
-- , argPath "-i" buildDir
-- , argPath "-I" buildDir
-- , argPathList "-i" [buildDir, arg "autogen"]
-- , argPathList "-I" [buildDir, arg "autogen"]
-- , argPathList "-I" [argBuildPath, argIncludeDirs]
-- , arg "-optP-include" -- TODO: Shall we also add -cpp?
-- , argPathList "-optP" [buildDir, arg "autogen/cabal_macros.h"] ]
-- pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
-- pkgHsSources path dist = do
-- let pathDist = path </> dist
-- autogen = pathDist </> "build/autogen"
-- dirs <- map (path </>) <$> args (SrcDirs pathDist)
-- findModuleFiles pathDist (autogen:dirs) [".hs", ".lhs"]
-- TODO: look for non-{hs,c} objects too
......@@ -101,19 +101,19 @@ pkgLibHsObjects path dist stage way = do
findModuleFiles pathDist [buildDir] [suffix]
else do return depObjs
findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
findModuleFiles pathDist directories suffixes = do
modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
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 $ unifyPath file
files <- getDirectoryFiles "" fileList
return $ map unifyPath files
-- findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
-- findModuleFiles pathDist directories suffixes = do
-- modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
-- 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 $ unifyPath file
-- files <- getDirectoryFiles "" fileList
-- return $ map unifyPath files
-- The argument list has a limited size on Windows. Since Windows 7 the limit
-- is 32768 (theoretically). In practice we use 31000 to leave some breathing
......@@ -128,29 +128,29 @@ argSizeLimit = do
-- List of source files, which need to be tracked by the build system
-- to make sure the argument lists have not changed.
sourceDependecies :: [FilePath]
sourceDependecies = [ "shake/src/Package/Base.hs"
, "shake/src/Oracles/Base.hs"
, "shake/src/Oracles/Flag.hs"
, "shake/src/Oracles/Option.hs"
, "shake/src/Oracles/Builder.hs"
, "shake/src/Oracles/PackageData.hs"
, "shake/src/Ways.hs"
, "shake/src/Util.hs"
, "shake/src/Oracles.hs" ]
-- Convert Builder's argument list to a printable String
argListWithComment :: String -> Builder -> Args -> Action String
argListWithComment comment builder args = do
args' <- args
return $ show builder ++ " arguments"
++ (if null comment then "" else " (" ++ comment ++ ")")
++ ":\n" ++ concatMap (\s -> " " ++ s ++ "\n") args'
argList :: Builder -> Args -> Action String
argList = argListWithComment ""
-- Path to argument list for a given Package/Stage combination
argListPath :: FilePath -> Package -> Stage -> FilePath
argListPath dir (Package name _ _ _) stage =
dir </> takeBaseName name ++ " (stage " ++ show stage ++ ")" <.> "txt"
-- sourceDependecies :: [FilePath]
-- sourceDependecies = [ "shake/src/Package/Base.hs"
-- , "shake/src/Oracles/Base.hs"
-- , "shake/src/Oracles/Flag.hs"
-- , "shake/src/Oracles/Option.hs"
-- , "shake/src/Oracles/Builder.hs"
-- , "shake/src/Oracles/PackageData.hs"
-- , "shake/src/Ways.hs"
-- , "shake/src/Util.hs"
-- , "shake/src/Oracles.hs" ]
-- -- Convert Builder's argument list to a printable String
-- argListWithComment :: String -> Builder -> Args -> Action String
-- argListWithComment comment builder args = do
-- args' <- args
-- return $ show builder ++ " arguments"
-- ++ (if null comment then "" else " (" ++ comment ++ ")")
-- ++ ":\n" ++ concatMap (\s -> " " ++ s ++ "\n") args'
-- argList :: Builder -> Args -> Action String
-- argList = argListWithComment ""
-- -- Path to argument list for a given Package/Stage combination
-- argListPath :: FilePath -> Package -> Stage -> FilePath
-- argListPath dir (Package name _ _ _) stage =
-- dir </> takeBaseName name ++ " (stage " ++ show stage ++ ")" <.> "txt"
......@@ -2,40 +2,34 @@ module Settings.GccM (gccMArgs) where
import Util
import Builder
import Package
import Expression
import Oracles.PackageData
import Settings.Util
import Settings.TargetDirectory
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
gccMArgs :: Args
gccMArgs = do
stage <- getStage
builder (GccM stage) ? do
pkg <- getPackage
files <- getFiles
ccArgs <- getPkgDataList CcArgs
let file = head files
path = targetPath stage pkg -/- "build"
mconcat
[ arg "-E"
, arg "-MM"
, append ccArgs -- TODO: remove? any other flags?
, includeGccArgs
, arg "-MF"
, arg $ path -/- takeFileName file <.> "deps"
, arg "-x"
, arg "c"
, arg file ]
gccMArgs = stagedBuilder GccM ? do
path <- getTargetPath
file <- getFile
ccArgs <- getPkgDataList CcArgs
mconcat
[ arg "-E"
, arg "-MM"
, append ccArgs -- TODO: remove? any other flags?
, includeGccArgs
, arg "-MF"
, arg $ path -/- "build" -/- takeFileName file <.> "deps"
, arg "-x"
, arg "c"
, arg file ]
includeGccArgs :: Args
includeGccArgs = do
stage <- getStage
pkg <- getPackage
incDirs <- getPkgDataList IncludeDirs
depIncDirs <- getPkgDataList DepIncludeDirs
let path = pkgPath pkg
path <- getTargetPath
pkgPath <- getPackagePath
pkg <- getPackage
iDirs <- getPkgDataList IncludeDirs
dDirs <- getPkgDataList DepIncludeDirs
mconcat
[ arg $ "-I" ++ targetPath stage pkg -/- "build/autogen"
, append . map (\dir -> "-I" ++ path -/- dir) $ incDirs ++ depIncDirs ]
[ arg $ "-I" ++ path -/- "build/autogen"
, append . map (\dir -> "-I" ++ pkgPath -/- dir) $ iDirs ++ dDirs ]
......@@ -3,9 +3,10 @@ module Settings.GhcCabal (
) where
import Way
import Util
import Stage
import Builder
import Package
import Util
import Switches
import Expression
import Oracles.Base
......@@ -15,26 +16,25 @@ import Settings.User
import Settings.Ways
import Settings.Util
import Settings.Packages
import Settings.TargetDirectory
import Data.List
import Control.Applicative
cabalArgs :: Args
cabalArgs = builder GhcCabal ? do
stage <- getStage
pkg <- getPackage
path <- getPackagePath
dir <- getTargetDirectory
mconcat [ arg "configure"
, arg $ pkgPath pkg
, arg $ targetDirectory stage pkg
, arg path
, arg dir
, dllArgs
, with $ Ghc stage
, with $ GhcPkg stage
, withStaged Ghc
, withStaged GhcPkg
, stage0 ? bootPackageDbArgs
, libraryArgs
, with HsColour
, configureArgs
, stage0 ? packageConstraints
, with $ Gcc stage
, withStaged Gcc
, notStage0 ? with Ld
, with Ar
, with Alex
......@@ -43,12 +43,12 @@ cabalArgs = builder GhcCabal ? do
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs :: Args
libraryArgs = do
ways <- getWays
ghcInterpreter <- lift $ ghcWithInterpreter
ways <- getWays
ghcInt <- lift $ ghcWithInterpreter
append [ if vanilla `elem` ways
then "--enable-library-vanilla"
else "--disable-library-vanilla"
, if vanilla `elem` ways && ghcInterpreter && not dynamicGhcPrograms
, if vanilla `elem` ways && ghcInt && not dynamicGhcPrograms
then "--enable-library-for-ghci"
else "--disable-library-for-ghci"
, if profiling `elem` ways
......@@ -82,8 +82,8 @@ configureArgs = do
bootPackageDbArgs :: Args
bootPackageDbArgs = do
sourcePath <- getSetting GhcSourcePath
arg $ "--package-db=" ++ sourcePath -/- "libraries/bootstrapping.conf"
path <- getSetting GhcSourcePath
arg $ "--package-db=" ++ path -/- "libraries/bootstrapping.conf"
-- This is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument;
......@@ -110,7 +110,7 @@ packageConstraints = do
-- TODO: put all validating options together in one file
ccArgs :: Args
ccArgs = validating ? do
let gccGe46 = liftM not gccLt46
let gccGe46 = notP gccLt46
mconcat [ arg "-Werror"
, arg "-Wall"
, gccIsClang ??
......@@ -155,3 +155,8 @@ with builder = specified builder ? do
path <- lift $ builderPath builder
lift $ needBuilder builder
append [withBuilderKey builder ++ path]
withStaged :: (Stage -> Builder) -> Args
withStaged sb = do
stage <- getStage
with $ sb stage
......@@ -4,38 +4,34 @@ import Way
import Util
import Stage
import Builder
import Package
import Switches
import Expression
import Oracles.Flag
import Oracles.PackageData
import Settings.Util
import Settings.Ways
import Settings.TargetDirectory
import Development.Shake
ghcMArgs :: Args
ghcMArgs = do
stage <- getStage
builder (GhcM stage) ? do
pkg <- getPackage
cppArgs <- getPkgDataList CppArgs
hsArgs <- getPkgDataList HsArgs
hsSrcs <- getHsSources
ways <- getWays
let buildPath = targetPath stage pkg -/- "build"
mconcat
[ arg "-M"
, packageGhcArgs
, includeGhcArgs
, append . map ("-optP" ++) $ cppArgs
, arg "-odir" , arg buildPath
, arg "-stubdir" , arg buildPath
, arg "-hidir" , arg buildPath
, arg "-dep-makefile", arg $ buildPath -/- "haskell.deps"
, append . concatMap (\way -> ["-dep-suffix", wayPrefix way]) $ ways
, append hsArgs
, append hsSrcs ]
ghcMArgs = stagedBuilder GhcM ? do
ways <- getWays
hsSrcs <- getHsSources
hsArgs <- getPkgDataList HsArgs
cppArgs <- getPkgDataList CppArgs
path <- getTargetPath
let buildPath = path -/- "build"
mconcat
[ arg "-M"
, packageGhcArgs
, includeGhcArgs
, append . map ("-optP" ++) $ cppArgs
, arg "-odir" , arg buildPath
, arg "-stubdir" , arg buildPath
, arg "-hidir" , arg buildPath
, arg "-dep-makefile", arg $ buildPath -/- "haskell.deps"
, append . concatMap (\way -> ["-dep-suffix", wayPrefix way]) $ ways
, append hsArgs
, append hsSrcs ]
packageGhcArgs :: Args
packageGhcArgs = do
......@@ -57,30 +53,29 @@ packageGhcArgs = do
includeGhcArgs :: Args
includeGhcArgs = do
stage <- getStage
pkg <- getPackage
path <- getTargetPath
pkgPath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
incDirs <- getPkgDataList IncludeDirs
let buildPath = targetPath stage pkg -/- "build"
let buildPath = path -/- "build"
autogenPath = buildPath -/- "autogen"
mconcat
[ arg "-i"
, append . map (\dir -> "-i" ++ pkgPath pkg -/- dir) $ srcDirs
, append . map (\dir -> "-i" ++ pkgPath -/- dir) $ srcDirs
, arg $ "-i" ++ buildPath
, arg $ "-i" ++ autogenPath
, arg $ "-I" ++ buildPath
, arg $ "-I" ++ autogenPath
, append . map (\dir -> "-I" ++ pkgPath pkg -/- dir) $ incDirs
, append . map (\dir -> "-I" ++ pkgPath -/- dir) $ incDirs
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, arg $ "-optP" ++ autogenPath -/- "cabal_macros.h" ]
getHsSources :: Expr [FilePath]
getHsSources = do
stage <- getStage
pkg <- getPackage
path <- getTargetPath
pkgPath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
let autogen = targetPath stage pkg -/- "build/autogen"
paths = autogen : map (pkgPath pkg -/-) srcDirs
let paths = (path -/- "build/autogen") : map (pkgPath -/-) srcDirs
getSourceFiles paths [".hs", ".lhs"]
-- Find all source files in specified paths and with given extensions
......
......@@ -6,14 +6,11 @@ import Switches
import Expression
import Settings.Util
import Settings.GhcCabal
import Settings.TargetDirectory
ghcPkgArgs :: Args
ghcPkgArgs = do
stage <- getStage
pkg <- getPackage
builder (GhcPkg stage) ? mconcat
[ arg "update"
, arg "--force"
, stage0 ? bootPackageDbArgs
, arg $ targetPath stage pkg -/- "inplace-pkg-config" ]
ghcPkgArgs = stagedBuilder GhcPkg ? do
path <- getTargetPath
mconcat [ arg "update"
, arg "--force"
, stage0 ? bootPackageDbArgs
, arg $ path -/- "inplace-pkg-config" ]
......@@ -4,6 +4,7 @@ module Settings.Util (
argSetting, argSettingList,
getFlag, getSetting, getSettingList,
getPkgData, getPkgDataList,
getPackagePath, getTargetPath, getTargetDirectory,
appendCcArgs,
needBuilder
-- argBuilderPath, argStagedBuilderPath,
......@@ -15,6 +16,7 @@ module Settings.Util (
) where
import Builder
import Package
import Expression
import Oracles.Base
import Oracles.Flag
......@@ -57,6 +59,15 @@ getPkgDataList key = do
pkg <- getPackage
lift . pkgDataList . key $ targetPath stage pkg
getPackagePath :: Expr FilePath
getPackagePath = liftM pkgPath getPackage
getTargetPath :: Expr FilePath
getTargetPath = liftM2 targetPath getStage getPackage
getTargetDirectory :: Expr FilePath
getTargetDirectory = liftM2 targetDirectory getStage getPackage
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
......
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