Minor revision

src/Expression.hs

@@ -7,7 +7,7 @@ module Expression (
 
     -- ** Predicates
     (?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
-    input, inputs, output, outputs, way, libraryPackage,
+    libraryPackage, way, input, inputs, output, outputs,
 
     -- ** Evaluation
     interpret, interpretInContext,
@@ -17,7 +17,7 @@ module Expression (
 
     -- * Convenient accessors
     getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
-    getInput, getOutput, getSetting, getSettingList, getStagedSettingList, getFlag,
+    getInput, getOutput, getSetting, getSettingList, getStagedSettingList,
 
     -- * Re-exports
     module Data.Semigroup,
@@ -40,7 +40,6 @@ import Stage
 import Target hiding (builder, inputs, outputs)
 import Way
 
-import Oracles.Config.Flag
 import Oracles.Config.Setting
 
 -- | @Expr a@ is a computation that produces a value of type @Action a@ and can
@@ -55,20 +54,18 @@ type Args      = H.Args      Context Builder
 type Packages  = Expr [Package]
 type Ways      = Expr [Way]
 
--- Basic operations on expressions:
-
+-- | Get a configuration setting.
 getSetting :: Setting -> Expr String
 getSetting = expr . setting
 
-getSettingList :: SettingList -> Expr [String]
+-- | Get a list of configuration settings.
+getSettingList :: SettingList -> Args
 getSettingList = expr . settingList
 
-getStagedSettingList :: (Stage -> SettingList) -> Expr [String]
+-- | Get a list of configuration settings for the current stage.
+getStagedSettingList :: (Stage -> SettingList) -> Args
 getStagedSettingList f = getSettingList . f =<< getStage
 
-getFlag :: Flag -> Predicate
-getFlag = expr . flag
-
 -- | Is the build currently in the provided stage?
 stage :: Stage -> Predicate
 stage s = (s ==) <$> getStage

src/Rules/Generate.hs

@@ -211,7 +211,7 @@ generateGhcPlatformH = do
     targetArch     <- getSetting TargetArch
     targetOs       <- getSetting TargetOs
     targetVendor   <- getSetting TargetVendor
-    ghcUnreg       <- getFlag GhcUnregisterised
+    ghcUnreg       <- expr $ flag GhcUnregisterised
     return . unlines $
         [ "#ifndef __GHCPLATFORM_H__"
         , "#define __GHCPLATFORM_H__"
@@ -275,7 +275,7 @@ generateConfigHs = do
     cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
     cLibFFI                    <- expr useLibFFIForAdjustors
     rtsWays                    <- getRtsWays
-    cGhcRtsWithLibdw           <- getFlag WithLibdw
+    cGhcRtsWithLibdw           <- expr $ flag WithLibdw
     let cGhcRTSWays = unwords $ map show rtsWays
     return $ unlines
         [ "{-# LANGUAGE CPP #-}"
@@ -349,7 +349,7 @@ generateGhcAutoconfH = do
     trackGenerateHs
     configHContents  <- expr $ map undefinePackage <$> readFileLines configH
     tablesNextToCode <- expr ghcEnableTablesNextToCode
-    ghcUnreg         <- getFlag GhcUnregisterised
+    ghcUnreg         <- expr $ flag GhcUnregisterised
     ccLlvmBackend    <- getSetting CcLlvmBackend
     ccClangBackend   <- getSetting CcClangBackend
     return . unlines $

src/Settings.hs

 module Settings (
     getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
-    findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
-    getContextDirectory, getBuildPath, stagePackages, builderPath,
+    findKnownPackage, getPkgData, getPkgDataList, isLibrary,
+    getBuildPath, stagePackages, builderPath,
     getBuilderPath, isSpecified, latestBuildStage, programPath, programContext,
     integerLibraryName, destDir, pkgConfInstallPath, stage1Only
     ) where
@@ -25,27 +25,21 @@ import Settings.Flavours.Quickest
 import Settings.Path
 import UserSettings
 
-getArgs :: Expr [String]
+getArgs :: Args
 getArgs = args flavour
 
-getLibraryWays :: Expr [Way]
+getLibraryWays :: Ways
 getLibraryWays = libraryWays flavour
 
-getRtsWays :: Expr [Way]
+getRtsWays :: Ways
 getRtsWays = rtsWays flavour
 
-getPackages :: Expr [Package]
+getPackages :: Packages
 getPackages = packages flavour
 
 stagePackages :: Stage -> Action [Package]
 stagePackages stage = interpretInContext (stageContext stage) getPackages
 
-getPackagePath :: Expr FilePath
-getPackagePath = pkgPath <$> getPackage
-
-getContextDirectory :: Expr FilePath
-getContextDirectory = stageDirectory <$> getStage
-
 getBuildPath :: Expr FilePath
 getBuildPath = buildPath <$> getContext
 
@@ -80,7 +74,7 @@ programContext stage pkg
 knownPackages :: [Package]
 knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
 
--- TODO: Speed up?
+-- TODO: Speed up? Switch to Set?
 -- Note: this is slow but we keep it simple as there are just ~50 packages
 findKnownPackage :: PackageName -> Maybe Package
 findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
@@ -156,12 +150,12 @@ programPath context@Context {..} = do
 pkgConfInstallPath :: FilePath
 pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) -/- "package.conf.install"
 
--- | Stage1Only flag
--- TODO: Set this by cmdline flags
+-- TODO: Set this from command line
+-- | Stage1Only flag.
 stage1Only :: Bool
 stage1Only = defaultStage1Only
 
--- | Install's DESTDIR flag
--- TODO: Set this by cmdline flags
+-- TODO: Set this from command line
+-- | Install's DESTDIR setting.
 destDir :: FilePath
 destDir = defaultDestDir

src/Settings/Builders/Ghc.hs

 module Settings.Builders.Ghc (
-  ghcBuilderArgs, ghcMBuilderArgs, haddockGhcArgs,
-  ghcCbuilderArgs
-) where
+    ghcBuilderArgs, ghcMBuilderArgs, haddockGhcArgs, ghcCbuilderArgs
+    ) where
 
 import Flavour
-import GHC
 import Settings.Builders.Common
 
 ghcBuilderArgs :: Args
@@ -18,6 +16,11 @@ ghcBuilderArgs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
             , getInputs
             , arg "-o", arg =<< getOutput ]
 
+needTouchy :: Expr ()
+needTouchy = notStage0 ? do
+    maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
+    expr . whenJust maybePath $ \path -> need [path]
+
 ghcCbuilderArgs :: Args
 ghcCbuilderArgs =
   builder (Ghc CompileCWithGhc) ? do
@@ -58,11 +61,6 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             , pure [ "-optl-l" ++           lib | lib <- libs ++ gmpLibs ]
             , pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
 
-needTouchy :: Expr ()
-needTouchy = notStage0 ? do
-    maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
-    expr . whenJust maybePath $ \path -> need [path]
-
 splitObjectsArgs :: Args
 splitObjectsArgs = splitObjects flavour ? do
     expr $ need [ghcSplitPath]
@@ -116,10 +114,10 @@ wayGhcArgs = do
 -- FIXME: Get rid of to-be-deprecated -this-package-key.
 packageGhcArgs :: Args
 packageGhcArgs = do
-    compId    <- getPkgData ComponentId
+    compId  <- getPkgData ComponentId
     thisArg <- do
         not0 <- notStage0
-        unit <- getFlag SupportsThisUnitId
+        unit <- expr $ flag SupportsThisUnitId
         return $ if not0 || unit then "-this-unit-id " else "-this-package-key "
     mconcat [ arg "-hide-all-packages"
             , arg "-no-user-package-db"

src/Settings/Builders/GhcCabal.hs

@@ -14,7 +14,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
     context   <- getContext
     when (package context /= deriveConstants) $ expr (need inplaceLibCopyTargets)
     mconcat [ arg "configure"
-            , arg =<< getPackagePath
+            , arg =<< pkgPath <$> getPackage
             , arg $ top -/- buildPath context
             , dll0Args
             , withStaged $ Ghc CompileHs
@@ -34,7 +34,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
 
 ghcCabalHsColourBuilderArgs :: Args
 ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
-    path    <- getPackagePath
+    path    <- pkgPath <$> getPackage
     top     <- expr topDirectory
     context <- getContext
     pure [ "hscolour", path, top -/- buildPath context ]