Refactoring for consistent interface (getters) for expressions.

src/Expression.hs

@@ -9,6 +9,7 @@ module Expression (
     apply, append, appendM, remove,
     appendSub, appendSubD, filterSub, removeSub,
     interpret, interpretExpr,
+    getStage, getPackage, getBuilder, getFiles, getWay,
     stage, package, builder, file, way
     ) where
 
@@ -16,7 +17,9 @@ import Way
 import Stage
 import Builder
 import Package
-import Target
+import Target (Target)
+import Target hiding (Target(..))
+import qualified Target
 import Oracles.Base
 import Data.List
 import Data.Monoid
@@ -148,18 +151,34 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
 interpret :: Monoid a => Target -> DiffExpr a -> Action a
 interpret target = interpretExpr target . fromDiffExpr
 
+-- Convenient getters for target parameters
+getStage :: Expr Stage
+getStage = asks Target.stage
+
+getPackage :: Expr Package
+getPackage = asks Target.package
+
+getBuilder :: Expr Builder
+getBuilder = asks Target.builder
+
+getFiles :: Expr [FilePath]
+getFiles = asks Target.files
+
+getWay :: Expr Way
+getWay = asks Target.way
+
 -- Basic predicates (see Switches.hs for derived predicates)
 stage :: Stage -> Predicate
-stage s = liftM (s ==) (asks getStage)
+stage s = liftM (s ==) getStage
 
 package :: Package -> Predicate
-package p = liftM (p ==) (asks getPackage)
+package p = liftM (p ==) getPackage
 
 builder :: Builder -> Predicate
-builder b = liftM (b ==) (asks getBuilder)
+builder b = liftM (b ==) getBuilder
 
 file :: FilePattern -> Predicate
-file f = liftM (any (f ?==)) (asks getFiles)
+file f = liftM (any (f ?==)) getFiles
 
 way :: Way -> Predicate
-way w = liftM (w ==) (asks getWay)
+way w = liftM (w ==) getWay

src/Rules/Actions.hs

@@ -5,6 +5,7 @@ module Rules.Actions (
 import Util
 import Builder
 import Expression
+import qualified Target
 import Settings.Args
 import Settings.Util
 import Oracles.ArgsHash
@@ -18,7 +19,7 @@ build target = do
     argList <- interpret target args
     -- The line below forces the rule to be rerun if the args hash has changed
     argsHash <- askArgsHash target
-    run (getBuilder target) argList
+    run (Target.builder target) argList
 
 buildWhen :: Predicate -> FullTarget -> Action ()
 buildWhen predicate target = do

src/Rules/Data.hs

@@ -9,6 +9,7 @@ import Package
 import Builder
 import Switches
 import Expression
+import qualified Target
 import Settings.GhcPkg
 import Settings.GhcCabal
 import Settings.TargetDirectory
@@ -20,8 +21,8 @@ import Development.Shake
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
 buildPackageData :: StagePackageTarget -> Rules ()
 buildPackageData target =
-    let stage = getStage target
-        pkg   = getPackage target
+    let stage = Target.stage target
+        pkg   = Target.package target
         path  = targetPath stage pkg
     in
     (path -/-) <$>

src/Settings/GhcCabal.hs

@@ -21,8 +21,8 @@ import Control.Applicative
 
 cabalArgs :: Args
 cabalArgs = builder GhcCabal ? do
-    stage <- asks getStage
-    pkg   <- asks getPackage
+    stage <- getStage
+    pkg   <- getPackage
     mconcat [ arg "configure"
             , arg $ pkgPath pkg
             , arg $ targetDirectory stage pkg
@@ -43,7 +43,7 @@ cabalArgs = builder GhcCabal ? do
 -- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
 libraryArgs :: Args
 libraryArgs = do
-    ways           <- fromDiffExpr Settings.Ways.ways
+    ways           <- getWays
     ghcInterpreter <- lift $ ghcWithInterpreter
     append [ if vanilla `elem` ways
              then  "--enable-library-vanilla"
@@ -60,7 +60,7 @@ libraryArgs = do
 
 configureArgs :: Args
 configureArgs = do
-    stage <- asks getStage
+    stage <- getStage
     let conf key = appendSubD $ "--configure-option=" ++ key
         cFlags   = mconcat [ ccArgs
                            , remove ["-Werror"]
@@ -82,7 +82,7 @@ configureArgs = do
 
 bootPackageDbArgs :: Args
 bootPackageDbArgs = do
-    sourcePath <- lift . setting $ GhcSourcePath
+    sourcePath <- getSetting GhcSourcePath
     arg $ "--package-db=" ++ sourcePath -/- "libraries/bootstrapping.conf"
 
 -- This is a positional argument, hence:
@@ -93,7 +93,7 @@ dllArgs = arg ""
 
 packageConstraints :: Args
 packageConstraints = do
-    pkgs <- fromDiffExpr packages
+    pkgs <- getPackages
     constraints <- lift $ forM pkgs $ \pkg -> do
         let cabal  = pkgPath pkg -/- pkgCabal pkg
             prefix = dropExtension (pkgCabal pkg) ++ " == "

src/Settings/GhcM.hs

@@ -16,13 +16,13 @@ import Development.Shake
 
 ghcMArgs :: Args
 ghcMArgs = do
-    stage <- asks getStage
+    stage <- getStage
     builder (GhcM stage) ? do
-        pkg     <- asks getPackage
+        pkg     <- getPackage
         cppArgs <- getPkgDataList CppArgs
         hsArgs  <- getPkgDataList HsArgs
         hsSrcs  <- getHsSources
-        ways    <- fromDiffExpr Settings.Ways.ways
+        ways    <- getWays
         let buildPath = targetPath stage pkg -/- "build"
         mconcat
             [ arg "-M"
@@ -39,9 +39,9 @@ ghcMArgs = do
 
 packageGhcArgs :: Args
 packageGhcArgs = do
-    stage              <- asks getStage
-    supportsPackageKey <- lift . flag $ SupportsPackageKey
-    pkgKey             <- getPkgData     PackageKey
+    stage              <- getStage
+    supportsPackageKey <- getFlag SupportsPackageKey
+    pkgKey             <- getPkgData PackageKey
     pkgDepKeys         <- getPkgDataList DepKeys
     pkgDeps            <- getPkgDataList Deps
     mconcat
@@ -57,8 +57,8 @@ packageGhcArgs = do
 
 includeGhcArgs :: Args
 includeGhcArgs = do
-    stage       <- asks getStage
-    pkg         <- asks getPackage
+    stage       <- getStage
+    pkg         <- getPackage
     srcDirs     <- getPkgDataList SrcDirs
     includeDirs <- getPkgDataList IncludeDirs
     let buildPath   = targetPath stage pkg -/- "build"
@@ -76,8 +76,8 @@ includeGhcArgs = do
 
 getHsSources :: Expr [FilePath]
 getHsSources = do
-    stage   <- asks getStage
-    pkg     <- asks getPackage
+    stage   <- getStage
+    pkg     <- getPackage
     srcDirs <- getPkgDataList SrcDirs
     let autogenPath = targetPath stage pkg -/- "build/autogen"
         dirs        = autogenPath : map (pkgPath pkg -/-) srcDirs

src/Settings/GhcPkg.hs

@@ -12,8 +12,8 @@ import Settings.TargetDirectory
 
 ghcPkgArgs :: Args
 ghcPkgArgs = do
-    stage <- asks getStage
-    pkg   <- asks getPackage
+    stage <- getStage
+    pkg   <- getPackage
     builder (GhcPkg stage) ? mconcat
         [ arg "update"
         , arg "--force"

src/Settings/Packages.hs

 module Settings.Packages (
     module Settings.Default,
-    packages, knownPackages
+    packages, getPackages, knownPackages
     ) where
 
 import Package
@@ -14,6 +14,9 @@ import Settings.Default
 packages :: Packages
 packages = defaultPackages <> userPackages
 
+getPackages :: Expr [Package]
+getPackages = fromDiffExpr packages
+
 -- These are the packages we build by default
 defaultPackages :: Packages
 defaultPackages = mconcat

src/Settings/Util.hs

@@ -2,6 +2,7 @@ module Settings.Util (
     -- Primitive settings elements
     arg, argM,
     argSetting, argSettingList,
+    getFlag, getSetting, getSettingList,
     getPkgData, getPkgDataList,
     appendCcArgs,
     needBuilder
@@ -16,6 +17,7 @@ module Settings.Util (
 import Builder
 import Expression
 import Oracles.Base
+import Oracles.Flag
 import Oracles.Setting
 import Oracles.PackageData
 import Settings.User
@@ -34,24 +36,31 @@ argSetting = argM . setting
 argSettingList :: SettingList -> Args
 argSettingList = appendM . settingList
 
+getFlag :: Flag -> Expr Bool
+getFlag = lift . flag
+
+getSetting :: Setting -> Expr String
+getSetting = lift . setting
+
+getSettingList :: SettingList -> Expr [String]
+getSettingList = lift . settingList
+
 getPkgData :: (FilePath -> PackageData) -> Expr String
 getPkgData key = do
-    stage <- asks getStage
-    pkg   <- asks getPackage
-    let path = targetPath stage pkg
-    lift . pkgData . key $ path
+    stage <- getStage
+    pkg   <- getPackage
+    lift . pkgData . key $ targetPath stage pkg
 
 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
 getPkgDataList key = do
-    stage <- asks getStage
-    pkg   <- asks getPackage
-    let path = targetPath stage pkg
-    lift . pkgDataList . key $ path
+    stage <- getStage
+    pkg   <- getPackage
+    lift . pkgDataList . key $ targetPath stage pkg
 
 -- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
 appendCcArgs :: [String] -> Args
 appendCcArgs xs = do
-    stage <- asks getStage
+    stage <- getStage
     mconcat [ builder (Gcc stage) ? append xs
             , builder GhcCabal    ? appendSub "--configure-option=CFLAGS" xs
             , builder GhcCabal    ? appendSub "--gcc-options" xs ]

src/Settings/Ways.hs

 module Settings.Ways (
-    ways
+    ways, getWays
     ) where
 
 import Way
@@ -13,6 +13,9 @@ import Settings.User
 ways :: Ways
 ways = defaultWays <> userWays
 
+getWays :: Expr [Way]
+getWays = fromDiffExpr ways
+
 -- These are default ways
 defaultWays :: Ways
 defaultWays = mconcat

src/Switches.hs

@@ -4,9 +4,10 @@ module Switches (
     ) where
 
 import Stage
+import Expression
+import Settings.Util
 import Oracles.Flag
 import Oracles.Setting
-import Expression
 
 -- Derived predicates
 stage0 :: Predicate
@@ -30,11 +31,11 @@ registerPackage = return True
 
 splitObjects :: Predicate
 splitObjects = do
-    stage       <- asks getStage
-    notBroken   <- notP . flag $ SplitObjectsBroken
-    notGhcUnreg <- notP . flag $ GhcUnregisterised
-    goodArch    <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
-    goodOs      <- lift $ targetOss   [ "mingw32", "cygwin32", "linux"
-                                      , "darwin", "solaris2", "freebsd"
-                                      , "dragonfly", "netbsd", "openbsd"]
-    return $ notBroken && notGhcUnreg && stage == Stage1 && goodArch && goodOs
+    stage    <- getStage -- We don't split bootstrap (stage 0) packages
+    broken   <- getFlag SplitObjectsBroken
+    ghcUnreg <- getFlag GhcUnregisterised
+    goodArch <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
+    goodOs   <- lift $ targetOss   [ "mingw32", "cygwin32", "linux"
+                                   , "darwin", "solaris2", "freebsd"
+                                   , "dragonfly", "netbsd", "openbsd"]
+    return $ not broken && not ghcUnreg && stage == Stage1 && goodArch && goodOs

src/Target.hs

 {-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
 module Target (
     Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
-    stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
+    stageTarget, stagePackageTarget, fullTarget, fullTarwithWay
     ) where
 
 import Way
@@ -16,39 +16,40 @@ import Development.Shake.Classes
 -- be built and the Way they are to be built.
 data Target = Target
      {
-        getStage   :: Stage,
-        getPackage :: Package,
-        getFiles   :: [FilePath],
-        getBuilder :: Builder,
-        getWay     :: Way
+        stage   :: Stage,
+        package :: Package,
+        files   :: [FilePath],
+        builder :: Builder,
+        way     :: Way
      }
      deriving (Eq, Generic)
 
--- StageTarget is a Target whose field getStage is already assigned
+-- StageTarget is a partially constructed Target. Only stage is guaranteed to
+-- be assigned.
 type StageTarget = Target
 
 stageTarget :: Stage -> StageTarget
-stageTarget stage = Target
+stageTarget s = Target
     {
-        getStage   = stage,
-        getPackage = error "stageTarget: Package not set",
-        getFiles   = error "stageTarget: Files not set",
-        getBuilder = error "stageTarget: Builder not set",
-        getWay     = vanilla -- most targets are built only one way (vanilla)
+        stage   = s,
+        package = error "stageTarget: Package not set",
+        files   = error "stageTarget: Files not set",
+        builder = error "stageTarget: Builder not set",
+        way     = vanilla
     }
 
--- StagePackageTarget is a Target whose fields getStage and getPackage are
--- already assigned
+-- StagePackageTarget is a partially constructed Target. Only stage and package
+-- are guaranteed to be assigned.
 type StagePackageTarget = Target
 
 stagePackageTarget :: Stage -> Package -> StagePackageTarget
-stagePackageTarget stage package = Target
+stagePackageTarget s p = Target
     {
-        getStage   = stage,
-        getPackage = package,
-        getFiles   = error "stagePackageTarget: Files not set",
-        getBuilder = error "stagePackageTarget: Builder not set",
-        getWay     = vanilla
+        stage   = s,
+        package = p,
+        files   = error "stagePackageTarget: Files not set",
+        builder = error "stagePackageTarget: Builder not set",
+        way     = vanilla
     }
 
 -- FullTarget is a Target whose fields are all assigned
@@ -56,29 +57,29 @@ type FullTarget = Target
 
 -- Most targets are built only one way, vanilla, hence we set it by default.
 fullTarget :: StagePackageTarget -> [FilePath] -> Builder -> FullTarget
-fullTarget target files builder = target
+fullTarget target fs b = target
     {
-        getFiles   = files,
-        getBuilder = builder,
-        getWay     = vanilla
+        files   = fs,
+        builder = b,
+        way     = vanilla
     }
 
--- Use this function to be explicit about build the way.
-fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget
-fullTargetWithWay target files builder way = target
+-- Use this function to be explicit about the build way.
+fullTarwithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget
+fullTarwithWay target fs b w = target
     {
-        getFiles   = files,
-        getBuilder = builder,
-        getWay     = way
+        files   = fs,
+        builder = b,
+        way     = w
     }
 
 -- Shows a (full) target as "package:file@stage (builder, way)"
 instance Show FullTarget where
-    show target = show (getPackage target)
-                  ++ ":" ++ show (getFiles target)
-                  ++ "@" ++ show (getStage target)
-                  ++ " (" ++ show (getBuilder target)
-                  ++ ", " ++ show (getWay target) ++ ")"
+    show target = show (package target)
+                  ++ ":" ++ show (files target)
+                  ++ "@" ++ show (stage target)
+                  ++ " (" ++ show (builder target)
+                  ++ ", " ++ show (way target) ++ ")"
 
 -- Instances for storing in the Shake database
 instance Binary FullTarget