Part 1 of the Great Refactoring of the Expression
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 27 Jul 2017 01:58:55 +0000 (02:58 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 27 Jul 2017 01:58:55 +0000 (02:58 +0100)
See #347

27 files changed:
hadrian.cabal
src/Base.hs
src/Expression.hs
src/Oracles/Config/Flag.hs
src/Oracles/Config/Setting.hs
src/Oracles/Path.hs
src/Rules/Generators/Common.hs
src/Rules/Generators/ConfigHs.hs
src/Rules/Generators/GhcAutoconfH.hs
src/Rules/Generators/GhcSplit.hs
src/Rules/Libffi.hs
src/Rules/Wrappers.hs
src/Settings.hs
src/Settings/Builders/Cc.hs
src/Settings/Builders/Common.hs
src/Settings/Builders/DeriveConstants.hs
src/Settings/Builders/Ghc.hs
src/Settings/Builders/GhcCabal.hs
src/Settings/Builders/GhcPkg.hs
src/Settings/Builders/Haddock.hs
src/Settings/Builders/HsCpp.hs
src/Settings/Builders/Hsc2Hs.hs
src/Settings/Builders/Make.hs
src/Settings/Default.hs
src/Settings/Packages/GhcCabal.hs
src/Settings/Packages/IntegerGmp.hs
src/Settings/Packages/Rts.hs

index 77fc54c..4eb43db 100644 (file)
@@ -111,7 +111,8 @@ executable hadrian
 
     default-language:    Haskell2010
     default-extensions:  RecordWildCards
-    other-extensions:    DeriveGeneric
+    other-extensions:    DeriveFunctor
+                       , DeriveGeneric
                        , FlexibleInstances
                        , GeneralizedNewtypeDeriving
                        , LambdaCase
index 2f6bae5..d717f2a 100644 (file)
@@ -7,7 +7,6 @@ module Base (
     module Data.List.Extra,
     module Data.Maybe,
     module Data.Monoid,
-    MonadTrans(lift),
 
     -- * Shake
     module Development.Shake,
index 201b175..a09bb8c 100644 (file)
@@ -1,12 +1,11 @@
-{-# LANGUAGE FlexibleInstances, LambdaCase #-}
+{-# LANGUAGE DeriveFunctor, FlexibleInstances, LambdaCase #-}
 module Expression (
     -- * Expressions
-    Expr, DiffExpr, fromDiffExpr,
+    Expr, expr, exprIO,
     -- ** Operators
-    apply, append, arg, remove,
-    appendSub, appendSubD, filterSub, removeSub,
+    append, arg, remove,
     -- ** Evaluation
-    interpret, interpretInContext, interpretDiff,
+    interpret, interpretInContext,
     -- ** Predicates
     Predicate, (?), applyPredicate,
     -- ** Common expressions
@@ -16,10 +15,10 @@ module Expression (
 
     -- * Convenient accessors
     getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
-    getInput, getOutput, getSingleton,
+    getInput, getOutput, getSingleton, getSetting, getSettingList, getFlag,
+    getTopDirectory,
 
     -- * Re-exports
-    module Control.Monad.Trans.Reader,
     module Data.Monoid,
     module Builder,
     module Package,
@@ -28,6 +27,7 @@ module Expression (
     ) where
 
 import Control.Monad.Trans.Reader
+import Control.Monad.Trans
 import Data.Monoid
 
 import Base
@@ -38,53 +38,58 @@ import Stage
 import Target
 import Way
 
+import Oracles.Config.Flag
+import Oracles.Config.Setting
+import Oracles.Path
+
 -- | @Expr a@ is a computation that produces a value of type @Action a@ and can
 -- read parameters of the current build 'Target'.
-type Expr a = ReaderT Target Action a
+newtype Expr a = Expr (ReaderT Target Action a) deriving Functor
+
+expr :: Action a -> Expr a
+expr = Expr . lift
+
+exprIO :: IO a -> Expr a
+exprIO = Expr . liftIO
 
--- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
--- list is a list with efficient concatenation, encoded as a value @a -> a@. We
--- could use @Dual (Endo a)@ instead of @Diff a@, but the former may look scary.
-newtype Diff a = Diff { fromDiff :: a -> a }
+instance Monoid a => Monoid (Expr a) where
+    mempty                    = Expr $ return mempty
+    mappend (Expr x) (Expr y) = Expr $ (<>) <$> x <*> y
 
--- | @DiffExpr a@ is a computation that builds a difference list (i.e., a
--- function of type @'Action' (a -> a)@) and can read parameters of the current
--- build 'Target'.
-type DiffExpr a = Expr (Diff a)
+instance Applicative Expr where
+    pure  = Expr . pure
+    (<*>) = ap
 
--- Note the reverse order of function composition (y . x), which ensures that
--- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
--- applied first, and c2 is applied second.
-instance Monoid (Diff a) where
-    mempty = Diff id
-    Diff x `mappend` Diff y = Diff $ y . x
+instance Monad Expr where
+    return       = pure
+    Expr e >>= f = Expr $ do
+        re <- e
+        let Expr rf = f re
+        rf
 
 -- | The following expressions are used throughout the build system for
 -- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
 -- and 'Packages'.
 type Predicate = Expr Bool
-type Args      = DiffExpr [String]
-type Packages  = DiffExpr [Package]
-type Ways      = DiffExpr [Way]
+type Args      = Expr [String]
+type Packages  = Expr [Package]
+type Ways      = Expr [Way]
 
 -- Basic operations on expressions:
--- | Transform an expression by applying a given function.
-apply :: (a -> a) -> DiffExpr a
-apply = return . Diff
 
 -- | Append something to an expression.
-append :: Monoid a => a -> DiffExpr a
-append x = apply (<> x)
+append :: Monoid a => a -> Expr a
+append = Expr . return
 
 -- | Remove given elements from a list expression.
-remove :: Eq a => [a] -> DiffExpr [a]
-remove xs = apply $ filter (`notElem` xs)
+remove :: Eq a => [a] -> Expr [a] -> Expr [a]
+remove xs e = filter (`notElem` xs) <$> e
 
 -- | Apply a predicate to an expression.
 applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
 applyPredicate predicate expr = do
     bool <- predicate
-    if bool then expr else return mempty
+    if bool then expr else mempty
 
 -- | Add a single argument to 'Args'.
 arg :: String -> Args
@@ -100,104 +105,73 @@ instance PredicateLike Predicate where
     (?) = applyPredicate
 
 instance PredicateLike Bool where
-    (?) = applyPredicate . return
+    (?) = applyPredicate . Expr . return
 
 instance PredicateLike (Action Bool) where
-    (?) = applyPredicate . lift
-
--- | @appendSub@ appends a list of sub-arguments to all arguments starting with a
--- given prefix. If there is no argument with such prefix then a new argument
--- of the form @prefix=listOfSubarguments@ is appended to the expression.
--- Note: nothing is done if the list of sub-arguments is empty.
-appendSub :: String -> [String] -> Args
-appendSub prefix xs
-    | xs' == [] = mempty
-    | otherwise = apply . go $ False
-  where
-    xs' = filter (/= "") xs
-    go True  []     = []
-    go False []     = [prefix ++ "=" ++ unwords xs']
-    go found (y:ys) = if prefix `isPrefixOf` y
-                      then unwords (y : xs') : go True ys
-                      else y : go found ys
-
--- | @appendSubD@ is similar to 'appendSub' but it extracts the list of sub-arguments
--- from the given 'DiffExpr'.
-appendSubD :: String -> Args -> Args
-appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
-
-filterSub :: String -> (String -> Bool) -> Args
-filterSub prefix p = apply $ map filterSubstr
-  where
-    filterSubstr s
-        | prefix `isPrefixOf` s = unwords . filter p . words $ s
-        | otherwise             = s
-
--- | Remove given elements from a list of sub-arguments with a given prefix
--- Example: removeSub "--configure-option=CFLAGS" ["-Werror"].
-removeSub :: String -> [String] -> Args
-removeSub prefix xs = filterSub prefix (`notElem` xs)
+    (?) = applyPredicate . expr
 
 -- | Interpret a given expression according to the given 'Target'.
 interpret :: Target -> Expr a -> Action a
-interpret = flip runReaderT
+interpret target (Expr e) = runReaderT e target
 
 -- | Interpret a given expression by looking only at the given 'Context'.
 interpretInContext :: Context -> Expr a -> Action a
 interpretInContext = interpret . dummyTarget
 
--- | Extract an expression from a difference expression.
-fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
-fromDiffExpr = fmap (($ mempty) . fromDiff)
-
--- | Interpret a given difference expression in a given environment.
-interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
-interpretDiff target = interpret target . fromDiffExpr
-
 -- | Get the current build 'Context'.
 getContext :: Expr Context
-getContext = asks context
+getContext = Expr $ asks context
 
 -- | Get the 'Stage' of the current 'Context'.
 getStage :: Expr Stage
-getStage = stage <$> asks context
+getStage = Expr $ stage <$> asks context
 
 -- | Get the 'Package' of the current 'Context'.
 getPackage :: Expr Package
-getPackage = package <$> asks context
+getPackage = Expr $ package <$> asks context
 
 -- | Get the 'Way' of the current 'Context'.
 getWay :: Expr Way
-getWay = way <$> asks context
+getWay = Expr $ way <$> asks context
 
 -- | Get the 'Builder' for the current 'Target'.
 getBuilder :: Expr Builder
-getBuilder = asks builder
+getBuilder = Expr $ asks builder
 
 -- | Get the input files of the current 'Target'.
 getInputs :: Expr [FilePath]
-getInputs = asks inputs
+getInputs = Expr $ asks inputs
 
 -- | Run 'getInputs' and check that the result contains one input file only.
 getInput :: Expr FilePath
-getInput = do
+getInput = Expr $ do
     target <- ask
-    getSingleton ("Exactly one input file expected in " ++ show target)
-        <$> getInputs
+    getSingleton ("Exactly one input file expected in " ++ show target) <$> asks inputs
 
 -- | Get the files produced by the current 'Target'.
 getOutputs :: Expr [FilePath]
-getOutputs = asks outputs
+getOutputs = Expr $ asks outputs
 
 -- | Run 'getOutputs' and check that the result contains one output file only.
 getOutput :: Expr FilePath
-getOutput = do
+getOutput = Expr $ do
     target <- ask
-    getSingleton ("Exactly one output file expected in " ++ show target)
-        <$> getOutputs
+    getSingleton ("Exactly one output file expected in " ++ show target) <$> asks outputs
 
 -- | Extract a value from a singleton list, or raise an error if the list does
 -- not contain exactly one value.
 getSingleton :: String -> [a] -> a
 getSingleton _ [res] = res
 getSingleton msg _   = error msg
+
+getSetting :: Setting -> Expr String
+getSetting = expr . setting
+
+getSettingList :: SettingList -> Expr [String]
+getSettingList = expr . settingList
+
+getFlag :: Flag -> Predicate
+getFlag = expr . flag
+
+getTopDirectory :: Expr FilePath
+getTopDirectory = expr topDirectory
index 8ac753f..05359eb 100644 (file)
@@ -1,10 +1,8 @@
 module Oracles.Config.Flag (
-    Flag (..), flag, getFlag, crossCompiling, platformSupportsSharedLibs,
+    Flag (..), flag, crossCompiling, platformSupportsSharedLibs,
     ghcWithSMP, ghcWithNativeCodeGen, supportsSplitObjects
     ) where
 
-import Control.Monad.Trans.Reader
-
 import Base
 import Oracles.Config
 import Oracles.Config.Setting
@@ -44,9 +42,6 @@ flag f = do
         ++ quote (key ++ " = " ++ value) ++ "cannot be parsed."
     return $ value == "YES"
 
-getFlag :: Flag -> ReaderT a Action Bool
-getFlag = lift . flag
-
 crossCompiling :: Action Bool
 crossCompiling = flag CrossCompiling
 
index 1bf9186..6b9254d 100644 (file)
@@ -1,13 +1,11 @@
 module Oracles.Config.Setting (
-    Setting (..), SettingList (..), setting, settingList, getSetting,
-    getSettingList, anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
+    Setting (..), SettingList (..), setting, settingList,
+    anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
     ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors,
     ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost,
     relocatableBuild, installDocDir, installGhcLibDir
     ) where
 
-import Control.Monad.Trans.Reader
-
 import Base
 import Oracles.Config
 import Stage
@@ -130,12 +128,6 @@ settingList key = fmap words $ unsafeAskConfig $ case key of
     ConfLdLinkerArgs  stage -> "conf-ld-linker-args-"  ++ stageString stage
     HsCppArgs               -> "hs-cpp-args"
 
-getSetting :: Setting -> ReaderT a Action String
-getSetting = lift . setting
-
-getSettingList :: SettingList -> ReaderT a Action [String]
-getSettingList = lift . settingList
-
 matchSetting :: Setting -> [String] -> Action Bool
 matchSetting key values = fmap (`elem` values) $ setting key
 
index f05608f..13286e1 100644 (file)
@@ -1,10 +1,9 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Oracles.Path (
-    topDirectory, getTopDirectory, systemBuilderPath, pathOracle, bashPath,
+    topDirectory, systemBuilderPath, pathOracle, bashPath,
     fixAbsolutePathOnWindows
     ) where
 
-import Control.Monad.Trans.Reader
 import Data.Char
 import System.Directory
 
@@ -18,9 +17,6 @@ import Stage
 topDirectory :: Action FilePath
 topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
 
-getTopDirectory :: ReaderT a Action FilePath
-getTopDirectory = lift topDirectory
-
 -- | Determine the location of a system 'Builder'.
 systemBuilderPath :: Builder -> Action FilePath
 systemBuilderPath builder = case builder of
index b01ad2f..64aadcf 100644 (file)
@@ -5,12 +5,12 @@ import Expression
 
 -- | Track a given source file when constructing an expression.
 trackSource :: FilePath -> Expr ()
-trackSource file = lift $ need [ sourcePath -/- file ]
+trackSource file = expr $ need [ sourcePath -/- file ]
 
 -- | Turn a 'Bool' computed by an 'Action' into a 'String' expression returning
 -- "YES" (when the Boolean is 'True') or "NO" (when the Boolean is 'False').
 yesNo :: Action Bool -> Expr String
-yesNo = lift . fmap (\x -> if x then "YES" else "NO")
+yesNo = expr . fmap (\x -> if x then "YES" else "NO")
 
 -- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
 -- the resulting 'String' becomes a valid C identifier.
index ffe0cfc..c12ffd5 100644 (file)
@@ -31,7 +31,7 @@ generateConfigHs = do
     cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
     cLeadingUnderscore         <- yesNo $ flag LeadingUnderscore
     cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
-    cLibFFI                    <- lift useLibFFIForAdjustors
+    cLibFFI                    <- expr useLibFFIForAdjustors
     rtsWays                    <- getRtsWays
     cGhcRtsWithLibdw           <- getFlag WithLibdw
     let cGhcRTSWays = unwords $ map show rtsWays
index 9314916..b8eeb69 100644 (file)
@@ -19,8 +19,8 @@ undefinePackage s
 generateGhcAutoconfH :: Expr String
 generateGhcAutoconfH = do
     trackSource "Rules/Generators/GhcAutoconfH.hs"
-    configHContents  <- lift $ map undefinePackage <$> readFileLines configH
-    tablesNextToCode <- lift $ ghcEnableTablesNextToCode
+    configHContents  <- expr $ map undefinePackage <$> readFileLines configH
+    tablesNextToCode <- expr ghcEnableTablesNextToCode
     ghcUnreg         <- getFlag GhcUnregisterised
     ccLlvmBackend    <- getSetting CcLlvmBackend
     ccClangBackend   <- getSetting CcClangBackend
index d4c19ca..08e3662 100644 (file)
@@ -17,7 +17,7 @@ generateGhcSplit = do
     targetPlatform <- getSetting TargetPlatform
     ghcEnableTNC   <- yesNo ghcEnableTablesNextToCode
     perlPath       <- getBuilderPath Perl
-    contents       <- lift $ readFileLines ghcSplitSource
+    contents       <- expr $ readFileLines ghcSplitSource
     return . unlines $
         [ "#!" ++ perlPath
         , "my $TARGETPLATFORM = " ++ show targetPlatform ++ ";"
index bac9970..61befec 100644 (file)
@@ -24,10 +24,10 @@ fixLibffiMakefile top =
 -- TODO: check code duplication w.r.t. ConfCcArgs
 configureEnvironment :: Action [CmdOption]
 configureEnvironment = do
-    cFlags  <- interpretInContext libffiContext . fromDiffExpr $ mconcat
+    cFlags  <- interpretInContext libffiContext $ mconcat
                [ cArgs
                , argStagedSettingList ConfCcArgs ]
-    ldFlags <- interpretInContext libffiContext $ fromDiffExpr ldArgs
+    ldFlags <- interpretInContext libffiContext ldArgs
     sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
              , builderEnvironment "CXX" $ Cc CompileC Stage1
              , builderEnvironment "LD" Ld
index 7d90067..a9b4ffc 100644 (file)
@@ -8,7 +8,7 @@ import GHC
 import Settings (getPackages, latestBuildStage)
 import Settings.Install (installPackageDbDirectory)
 import Settings.Path (buildPath, inplacePackageDbDirectory)
-import Oracles.Path (getTopDirectory, bashPath)
+import Oracles.Path (bashPath)
 import Oracles.Config.Setting (SettingList(..), settingList)
 
 -- | Wrapper is an expression depending on the 'FilePath' to the
@@ -22,8 +22,8 @@ type Wrapper = WrappedBinary -> Expr String
 
 ghcWrapper :: WrappedBinary -> Expr String
 ghcWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
-    bash <- lift bashPath
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -31,8 +31,8 @@ ghcWrapper WrappedBinary{..} = do
 
 inplaceRunGhcWrapper :: WrappedBinary -> Expr String
 inplaceRunGhcWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
-    bash <- lift bashPath
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -41,8 +41,8 @@ inplaceRunGhcWrapper WrappedBinary{..} = do
 
 installRunGhcWrapper :: WrappedBinary -> Expr String
 installRunGhcWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
-    bash <- lift bashPath
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -51,13 +51,13 @@ installRunGhcWrapper WrappedBinary{..} = do
 
 inplaceGhcPkgWrapper :: WrappedBinary -> Expr String
 inplaceGhcPkgWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
     stage <- getStage
     top <- getTopDirectory
     -- Use the package configuration for the next stage in the wrapper.
     -- The wrapper is generated in StageN, but used in StageN+1.
     let packageDb = top -/- inplacePackageDbDirectory (succ stage)
-    bash <- lift bashPath
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -65,13 +65,13 @@ inplaceGhcPkgWrapper WrappedBinary{..} = do
 
 installGhcPkgWrapper :: WrappedBinary -> Expr String
 installGhcPkgWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
     stage <- getStage
     top <- getTopDirectory
     -- Use the package configuration for the next stage in the wrapper.
     -- The wrapper is generated in StageN, but used in StageN+1.
     let packageDb = installPackageDbDirectory binaryLibPath top (succ stage)
-    bash <- lift bashPath
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -79,16 +79,16 @@ installGhcPkgWrapper WrappedBinary{..} = do
 
 hp2psWrapper :: WrappedBinary -> Expr String
 hp2psWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
-    bash <- lift bashPath
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
 
 hpcWrapper :: WrappedBinary -> Expr String
 hpcWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
-    bash <- lift bashPath
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
@@ -96,14 +96,14 @@ hpcWrapper WrappedBinary{..} = do
 hsc2hsWrapper :: WrappedBinary -> Expr String
 hsc2hsWrapper WrappedBinary{..} = do
     top <- getTopDirectory
-    lift $ need [ sourcePath -/- "Rules/Wrappers.hs" ]
-    contents <- lift $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper"
+    expr $ need [ sourcePath -/- "Rules/Wrappers.hs" ]
+    contents <- expr $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper"
     let executableName = binaryLibPath -/- "bin" -/- binaryName
-    confCcArgs <- lift $ settingList (ConfCcArgs Stage1)
-    confGccLinkerArgs <- lift $ settingList (ConfGccLinkerArgs Stage1)
+    confCcArgs <- expr $ settingList (ConfCcArgs Stage1)
+    confGccLinkerArgs <- expr $ settingList (ConfGccLinkerArgs Stage1)
     let hsc2hsExtra = unwords (map ("-cflags=" ++) confCcArgs) ++ " " ++
                       unwords (map ("-lflags=" ++) confGccLinkerArgs)
-    bash <- lift bashPath
+    bash <- expr bashPath
     return $ unlines
         [ "#!"++bash
         , "executablename=\"" ++ executableName ++ "\""
@@ -112,7 +112,7 @@ hsc2hsWrapper WrappedBinary{..} = do
 
 haddockWrapper :: WrappedBinary -> Expr String
 haddockWrapper WrappedBinary{..} = do
-  lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
+  expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
   return $ unlines
     [ "#!/bin/bash"
     , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
@@ -120,13 +120,13 @@ haddockWrapper WrappedBinary{..} = do
 
 iservBinWrapper :: WrappedBinary -> Expr String
 iservBinWrapper WrappedBinary{..} = do
-    lift $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
     activePackages <- filter isLibrary <$> getPackages
     -- TODO: Figure our the reason of this hardcoded exclusion
     let pkgs = activePackages \\ [ cabal, process, haskeline
                                  , terminfo, ghcCompact, hpc, compiler ]
     contexts <- catMaybes <$> mapM (\p -> do
-                                        m <- lift $ latestBuildStage p
+                                        m <- expr $ latestBuildStage p
                                         return $ fmap (\s -> vanillaContext s p) m
                                    ) pkgs
     let buildPaths = map buildPath contexts
index 2f75095..c1d4fbb 100644 (file)
@@ -24,16 +24,16 @@ import Settings.Path
 import UserSettings
 
 getArgs :: Expr [String]
-getArgs = fromDiffExpr $ args flavour
+getArgs = args flavour
 
 getLibraryWays :: Expr [Way]
-getLibraryWays = fromDiffExpr $ libraryWays flavour
+getLibraryWays = libraryWays flavour
 
 getRtsWays :: Expr [Way]
-getRtsWays = fromDiffExpr $ rtsWays flavour
+getRtsWays = rtsWays flavour
 
 getPackages :: Expr [Package]
-getPackages = fromDiffExpr $ packages flavour
+getPackages = packages flavour
 
 stagePackages :: Stage -> Action [Package]
 stagePackages stage = interpretInContext (stageContext stage) getPackages
@@ -48,10 +48,10 @@ getBuildPath :: Expr FilePath
 getBuildPath = buildPath <$> getContext
 
 getPkgData :: (FilePath -> PackageData) -> Expr String
-getPkgData key = lift . pkgData . key =<< getBuildPath
+getPkgData key = expr . pkgData . key =<< getBuildPath
 
 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
-getPkgDataList key = lift . pkgDataList . key =<< getBuildPath
+getPkgDataList key = expr . pkgDataList . key =<< getBuildPath
 
 hadrianFlavours :: [Flavour]
 hadrianFlavours =
@@ -92,8 +92,8 @@ builderPath builder = case builderProvenance builder of
         let msg = error $ show builder ++ " is never built by Hadrian."
         return $ fromMaybe msg maybePath
 
-getBuilderPath :: Builder -> ReaderT a Action FilePath
-getBuilderPath = lift . builderPath
+getBuilderPath :: Builder -> Expr FilePath
+getBuilderPath = expr . builderPath
 
 -- | Was the path to a given 'Builder' specified in configuration files?
 isSpecified :: Builder -> Action Bool
index b655368..f980834 100644 (file)
@@ -7,7 +7,7 @@ ccBuilderArgs = do
   way <- getWay
   builder Cc ? mconcat
     [ append =<< getPkgDataList CcArgs
-    , argSettingList . ConfCcArgs =<< getStage
+    , getSettingList . ConfCcArgs =<< getStage
     , cIncludeArgs
 
     , builder (Cc CompileC) ? mconcat
index 18e60b5..4b76f91 100644 (file)
@@ -10,8 +10,8 @@ module Settings.Builders.Common (
     module Settings,
     module Settings.Path,
     module UserSettings,
-    cIncludeArgs, ldArgs, cArgs, cWarnings, argSetting, argSettingList,
-    argStagedBuilderPath, argStagedSettingList, bootPackageDatabaseArgs
+    cIncludeArgs, ldArgs, cArgs, cWarnings, argStagedBuilderPath,
+    argStagedSettingList, bootPackageDatabaseArgs
     ) where
 
 import Base
@@ -53,12 +53,6 @@ cWarnings = do
             , gccGe46 ? notM windowsHost ? arg "-Werror=unused-but-set-variable"
             , gccGe46 ? arg "-Wno-error=inline" ]
 
-argM :: Action String -> Args
-argM = (arg =<<) . lift
-
-argSetting :: Setting -> Args
-argSetting = argM . setting
-
 argSettingList :: SettingList -> Args
 argSettingList = (append =<<) . getSettingList
 
@@ -66,12 +60,15 @@ argStagedSettingList :: (Stage -> SettingList) -> Args
 argStagedSettingList ss = argSettingList . ss =<< getStage
 
 argStagedBuilderPath :: (Stage -> Builder) -> Args
-argStagedBuilderPath sb = argM . builderPath . sb =<< getStage
+argStagedBuilderPath sb = do
+    stage <- getStage
+    path <- expr $ builderPath (sb stage)
+    arg path
 
 bootPackageDatabaseArgs :: Args
 bootPackageDatabaseArgs = do
     stage <- getStage
-    lift $ need [packageDbStamp stage]
+    expr $ need [packageDbStamp stage]
     stage0 ? do
         path   <- getTopDirectory
         prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=")
index fc61866..8a660ae 100644 (file)
@@ -5,7 +5,7 @@ import Settings.Builders.Common
 -- TODO: do we need to support `includes_CC_OPTS += -DDYNAMIC_BY_DEFAULT`?
 deriveConstantsBuilderArgs :: Args
 deriveConstantsBuilderArgs = builder DeriveConstants ? do
-    cFlags                <- fromDiffExpr includeCcArgs
+    cFlags                <- includeCcArgs
     [outputFile, tempDir] <- getOutputs
     mconcat
         [ output "//DerivedConstants.h"             ? arg "--gen-header"
@@ -20,13 +20,13 @@ deriveConstantsBuilderArgs = builder DeriveConstants ? do
         , arg "--nm-program", arg =<< getBuilderPath Nm
         , isSpecified Objdump ? mconcat [ arg "--objdump-program"
                                         , arg =<< getBuilderPath Objdump ]
-        , arg "--target-os", argSetting TargetOs ]
+        , arg "--target-os", return <$> getSetting TargetOs ]
 
 includeCcArgs :: Args
 includeCcArgs = mconcat
     [ cArgs
     , cWarnings
-    , argSettingList $ ConfCcArgs Stage1
+    , getSettingList $ ConfCcArgs Stage1
     , flag GhcUnregisterised ? arg "-DUSE_MINIINTERPRETER"
     , arg "-Irts"
     , arg "-Iincludes"
index 126bb1c..bb7c1e0 100644 (file)
@@ -25,7 +25,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
     gmpLibs <- if stage > Stage0 && integerLibrary flavour == integerGmp
                then do -- TODO: get this data more gracefully
                    let strip = fromMaybe "" . stripPrefix "extra-libraries: "
-                   buildInfo <- lift $ readFileLines gmpBuildInfoPath
+                   buildInfo <- expr $ readFileLines gmpBuildInfoPath
                    return $ concatMap (words . strip) buildInfo
                else return []
     mconcat [ (Dynamic `wayUnit` way) ?
@@ -36,14 +36,14 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
             , append [ "-optl-l" ++           lib | lib <- libs ++ gmpLibs ]
             , append [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
 
-needTouchy :: ReaderT Target Action ()
+needTouchy :: Expr ()
 needTouchy = notStage0 ? do
-    maybePath <- lift $ programPath (vanillaContext Stage0 touchy)
-    lift . whenJust maybePath $ \path -> need [path]
+    maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
+    expr . whenJust maybePath $ \path -> need [path]
 
 splitObjectsArgs :: Args
 splitObjectsArgs = splitObjects flavour ? do
-    lift $ need [ghcSplitPath]
+    expr $ need [ghcSplitPath]
     arg "-split-objs"
 
 ghcMBuilderArgs :: Args
index 33a7b99..6f4f9df 100644 (file)
@@ -9,11 +9,10 @@ import Util
 
 ghcCabalBuilderArgs :: Args
 ghcCabalBuilderArgs = builder GhcCabal ? do
-    verbosity <- lift $ getVerbosity
+    verbosity <- expr getVerbosity
     top       <- getTopDirectory
     context   <- getContext
-    when (package context /= deriveConstants) $
-        lift (need inplaceLibCopyTargets)
+    when (package context /= deriveConstants) $ expr (need inplaceLibCopyTargets)
     mconcat [ arg "configure"
             , arg =<< getPackagePath
             , arg $ top -/- buildPath context
@@ -45,7 +44,7 @@ ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
 libraryArgs :: Args
 libraryArgs = do
     ways     <- getLibraryWays
-    withGhci <- lift ghcWithInterpreter
+    withGhci <- expr ghcWithInterpreter
     append [ if vanilla `elem` ways
              then  "--enable-library-vanilla"
              else "--disable-library-vanilla"
@@ -63,29 +62,32 @@ libraryArgs = do
 configureArgs :: Args
 configureArgs = do
     top <- getTopDirectory
-    let conf key = appendSubD $ "--configure-option=" ++ key
-        cFlags   = mconcat [ cArgs
-                           , remove ["-Werror"]
+    let conf key expr = do
+            values <- unwords <$> expr
+            not (null values) ?
+                arg ("--configure-option=" ++ key ++ "=" ++ values)
+        cFlags   = mconcat [ remove ["-Werror"] cArgs
                            , argStagedSettingList ConfCcArgs
                            , arg $ "-I" ++ top -/- generatedPath ]
         ldFlags  = ldArgs  <> (argStagedSettingList ConfGccLinkerArgs)
         cppFlags = cppArgs <> (argStagedSettingList ConfCppArgs)
+    cldFlags <- unwords <$> (cFlags <> ldFlags)
     mconcat
         [ conf "CFLAGS"   cFlags
         , conf "LDFLAGS"  ldFlags
         , conf "CPPFLAGS" cppFlags
-        , appendSubD "--gcc-options" $ cFlags <> ldFlags
-        , conf "--with-iconv-includes"    $ argSetting IconvIncludeDir
-        , conf "--with-iconv-libraries"   $ argSetting IconvLibDir
-        , conf "--with-gmp-includes"      $ argSetting GmpIncludeDir
-        , conf "--with-gmp-libraries"     $ argSetting GmpLibDir
-        , conf "--with-curses-libraries"  $ argSetting CursesLibDir
-        , crossCompiling ? (conf "--host" $ argSetting TargetPlatformFull)
+        , not (null cldFlags) ? arg ("--gcc-options=" ++ cldFlags)
+        , conf "--with-iconv-includes"    $ return <$> getSetting IconvIncludeDir
+        , conf "--with-iconv-libraries"   $ return <$> getSetting IconvLibDir
+        , conf "--with-gmp-includes"      $ return <$> getSetting GmpIncludeDir
+        , conf "--with-gmp-libraries"     $ return <$> getSetting GmpLibDir
+        , conf "--with-curses-libraries"  $ return <$> getSetting CursesLibDir
+        , crossCompiling ? (conf "--host" $ return <$> getSetting TargetPlatformFull)
         , conf "--with-cc" $ argStagedBuilderPath (Cc CompileC) ]
 
 packageConstraints :: Args
 packageConstraints = stage0 ? do
-    constraints <- lift . readFileLines $ bootPackageConstraints
+    constraints <- expr . readFileLines $ bootPackageConstraints
     append $ concat [ ["--constraint", c] | c <- constraints ]
 
 cppArgs :: Args
@@ -108,7 +110,7 @@ with :: Builder -> Args
 with b = isSpecified b ? do
     top  <- getTopDirectory
     path <- getBuilderPath b
-    lift $ needBuilder b
+    expr $ needBuilder b
     arg $ withBuilderKey b ++ unifyPath (top </> path)
 
 withStaged :: (Stage -> Builder) -> Args
@@ -125,8 +127,8 @@ buildDll0 Context {..} = do
 dll0Args :: Args
 dll0Args = do
     context  <- getContext
-    dll0     <- lift $ buildDll0 context
-    withGhci <- lift ghcWithInterpreter
+    dll0     <- expr $ buildDll0 context
+    withGhci <- expr ghcWithInterpreter
     arg . unwords . concat $ [ modules     | dll0             ]
                           ++ [ ghciModules | dll0 && withGhci ] -- see #9552
   where
index fcde08f..0b9d6e4 100644 (file)
@@ -7,7 +7,7 @@ ghcPkgBuilderArgs = mconcat
     [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ]
 
     , builder (GhcPkg Update) ? do
-        verbosity <- lift $ getVerbosity
+        verbosity <- expr getVerbosity
         mconcat [ arg "update"
                 , arg "--force"
                 , verbosity < Chatty ? arg "-v0"
index fdc6ddb..bb37d0b 100644 (file)
@@ -18,8 +18,8 @@ haddockBuilderArgs = builder Haddock ? do
     synopsis <- getPkgData Synopsis
     deps     <- getPkgDataList Deps
     depNames <- getPkgDataList DepNames
-    hVersion <- lift . pkgData . Version $ buildPath (vanillaContext Stage2 haddock)
-    ghcOpts  <- fromDiffExpr haddockGhcArgs
+    hVersion <- expr . pkgData . Version $ buildPath (vanillaContext Stage2 haddock)
+    ghcOpts  <- haddockGhcArgs
     mconcat
         [ arg $ "--odir=" ++ takeDirectory output
         , arg "--verbosity=0"
index ee2b0a6..0707e49 100644 (file)
@@ -5,7 +5,7 @@ import Settings.Builders.Common
 hsCppBuilderArgs :: Args
 hsCppBuilderArgs = builder HsCpp ? do
     stage <- getStage
-    mconcat [ argSettingList HsCppArgs
+    mconcat [ getSettingList HsCppArgs
             , arg "-P"
             , arg "-Iincludes"
             , arg $ "-I" ++ generatedPath
index 217636b..4e0b18e 100644 (file)
@@ -15,7 +15,7 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
     tArch   <- getSetting TargetArch
     tOs     <- getSetting TargetOs
     version <- if stage == Stage0
-               then lift ghcCanonVersion
+               then expr ghcCanonVersion
                else getSetting ProjectVersionInt
     mconcat [ arg $ "--cc=" ++ ccPath
             , arg $ "--ld=" ++ ccPath
@@ -35,13 +35,11 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
             , arg "-o", arg =<< getOutput ]
 
 getCFlags :: Expr [String]
-getCFlags = fromDiffExpr $ do
+getCFlags = do
     context   <- getContext
     cppArgs   <- getPkgDataList CppArgs
     depCcArgs <- getPkgDataList DepCcArgs
-    mconcat [ cArgs
-            , argStagedSettingList ConfCcArgs
-            , remove ["-O"]
+    mconcat [ remove ["-O"] (cArgs <> argStagedSettingList ConfCcArgs)
             , argStagedSettingList ConfCppArgs
             , cIncludeArgs
             , append cppArgs
@@ -50,7 +48,7 @@ getCFlags = fromDiffExpr $ do
             , arg "-include", arg $ autogenPath context -/- "cabal_macros.h" ]
 
 getLFlags :: Expr [String]
-getLFlags = fromDiffExpr $ do
+getLFlags = do
     pkgLdArgs <- getPkgDataList LdArgs
     libDirs   <- getPkgDataList DepLibDirs
     extraLibs <- getPkgDataList DepExtraLibs
index d49e600..e770769 100644 (file)
@@ -4,7 +4,7 @@ import Settings.Builders.Common
 
 makeBuilderArgs :: Args
 makeBuilderArgs = do
-    threads <- shakeThreads <$> lift getShakeOptions
+    threads <- shakeThreads <$> (expr getShakeOptions)
     let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads
     mconcat
         [ builder (Make gmpBuildPath     ) ? append ["MAKEFLAGS=-j" ++ t]
index f114a75..b65e86a 100644 (file)
@@ -4,7 +4,6 @@ module Settings.Default (
     defaultFlavour, defaultSplitObjects
     ) where
 
-import Base
 import CmdLineFlag
 import Flavour
 import GHC
@@ -95,8 +94,8 @@ defaultPackages = mconcat [ stage0 ? stage0Packages
 
 stage0Packages :: Packages
 stage0Packages = do
-    win <- lift windowsHost
-    ios <- lift iosHost
+    win <- expr windowsHost
+    ios <- expr iosHost
     append $ [ binary
              , cabal
              , checkApiAnnotations
@@ -125,10 +124,9 @@ stage0Packages = do
 
 stage1Packages :: Packages
 stage1Packages = do
-    win <- lift windowsHost
+    win <- expr windowsHost
     doc <- buildHaddock flavour
-    mconcat [ stage0Packages
-            , apply (filter isLibrary) -- Build all Stage0 libraries in Stage1
+    mconcat [ (filter isLibrary) <$> stage0Packages -- Build all Stage0 libraries in Stage1
             , append $ [ array
                        , base
                        , bytestring
@@ -200,7 +198,7 @@ defaultSplitObjects :: Predicate
 defaultSplitObjects = do
     goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
     pkg       <- getPackage
-    supported <- lift supportsSplitObjects
+    supported <- expr supportsSplitObjects
     let goodPackage = isLibrary pkg && pkg /= compiler && pkg /= rts
     return $ cmdSplitObjects && goodStage && goodPackage && supported
 
index 983292f..c162dfc 100644 (file)
@@ -14,9 +14,9 @@ import qualified Distribution.PackageDescription as DP
 
 ghcCabalPackageArgs :: Args
 ghcCabalPackageArgs = stage0 ? package ghcCabal ? builder Ghc ? do
-    cabalDeps <- lift $ pkgDependencies cabal
-    lift $ need [pkgCabalFile cabal]
-    pd <- liftIO . readGenericPackageDescription silent $ pkgCabalFile cabal
+    cabalDeps <- expr $ pkgDependencies cabal
+    expr $ need [pkgCabalFile cabal]
+    pd <- exprIO . readGenericPackageDescription silent $ pkgCabalFile cabal
     let identifier   = DP.package . packageDescription $ pd
         cabalVersion = display . pkgVersion $ identifier
 
index 7dfcb2f..fa78124 100644 (file)
@@ -20,5 +20,5 @@ integerGmpPackageArgs = package integerGmp ? do
             , builder GhcCabal ? mconcat
               [ (null gmpIncludeDir && null gmpLibDir) ?
                 arg "--configure-option=--with-intree-gmp"
-              , appendSub "--configure-option=CFLAGS" [includeGmp]
-              , appendSub "--gcc-options"             [includeGmp] ] ]
+              , arg ("--configure-option=CFLAGS=" ++ includeGmp)
+              , arg ("--gcc-options="             ++ includeGmp) ] ]
index 9252e26..5a76eae 100644 (file)
@@ -4,7 +4,6 @@ import Base
 import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
-import Oracles.Path
 import Predicate
 import Settings
 import Settings.Path
@@ -26,7 +25,7 @@ rtsLibffiLibrary way = do
 
 rtsPackageArgs :: Args
 rtsPackageArgs = package rts ? do
-    let yesNo = lift . fmap (\x -> if x then "YES" else "NO")
+    let yesNo = expr . fmap (\x -> if x then "YES" else "NO")
     projectVersion <- getSetting ProjectVersion
     hostPlatform   <- getSetting HostPlatform
     hostArch       <- getSetting HostArch
@@ -45,10 +44,10 @@ rtsPackageArgs = package rts ? do
     way            <- getWay
     path           <- getBuildPath
     top            <- getTopDirectory
-    libffiName     <- lift rtsLibffiLibraryName
+    libffiName     <- expr rtsLibffiLibraryName
     ffiIncludeDir  <- getSetting FfiIncludeDir
     ffiLibraryDir  <- getSetting FfiLibDir
-    ghclibDir      <- lift installGhcLibDir
+    ghclibDir      <- expr installGhcLibDir
     mconcat
         [ builder Cc ? mconcat
           [ arg "-Irts"