Clean up.

src/Expression.hs

@@ -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
 

src/Package/Base.hs

@@ -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"

src/Settings/GccM.hs

@@ -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 ]

src/Settings/GhcCabal.hs

@@ -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

src/Settings/GhcM.hs

@@ -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

src/Settings/GhcPkg.hs

@@ -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" ]

src/Settings/Util.hs

@@ -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