Migrate all user-configurable settings from system.default to Settings/User.hs.

cfg/system.config.in

@@ -32,8 +32,6 @@ gcc-lt-46    = @GccLT46@
 # Build options:
 #===============
 
-lax-dependencies     = NO
-dynamic-ghc-programs = NO
 supports-package-key = @SUPPORTS_PACKAGE_KEY@
 solaris-broken-shld  = @SOLARIS_BROKEN_SHLD@
 split-objects-broken = @SplitObjsBroken@
@@ -74,8 +72,6 @@ conf-ld-linker-args-stage0  = @CONF_LD_LINKER_OPTS_STAGE0@
 conf-ld-linker-args-stage1  = @CONF_LD_LINKER_OPTS_STAGE1@
 conf-ld-linker-args-stage2  = @CONF_LD_LINKER_OPTS_STAGE2@
 
-src-hc-args                  = -H32m -O
-
 # Include and library directories:
 #=================================
 

src/Builder.hs

 {-# LANGUAGE DeriveGeneric #-}
 
 module Builder (
-    Builder (..), builderKey, builderPath, needBuilder
+    Builder (..), builderKey, builderPath, specified
     ) where
 
 import Util
 import Stage
 import Data.List
 import Oracles.Base
-import Oracles.Flag
 import Oracles.Setting
 import GHC.Generics
 
@@ -56,6 +55,9 @@ builderPath builder = do
                      ++ "' in configuration files."
     fixAbsolutePathOnWindows $ if null path then "" else path -<.> exe
 
+specified :: Builder -> Action Bool
+specified = fmap (not . null) . builderPath
+
 -- TODO: get rid of code duplication (windowsHost)
 -- On Windows: if the path starts with "/", prepend it with the correct path to
 -- the root, e.g: "/usr/local/bin/ghc.exe" => "C:/msys/usr/local/bin/ghc.exe".
@@ -76,17 +78,6 @@ fixAbsolutePathOnWindows path = do
 -- certain situations this can lead to build failures, in which case you
 -- should reset the flag (at least temporarily).
 
--- Make sure the builder exists on the given path and rebuild it if out of date
-needBuilder :: Builder -> Action ()
-needBuilder ghc @ (Ghc stage) = do
-    path    <- builderPath ghc
-    laxDeps <- test LaxDeps
-    if laxDeps then orderOnly [path] else need [path]
-
-needBuilder builder = do
-    path <- builderPath builder
-    need [path]
-
 -- Instances for storing in the Shake database
 instance Binary Builder
 instance Hashable Builder

src/Expression.hs

@@ -4,11 +4,11 @@ module Expression (
     module Data.Monoid,
     module Control.Monad.Reader,
     Expr, DiffExpr, fromDiffExpr,
-    Predicate, Args, Ways, Packages,
+    Predicate, PredicateLike (..), applyPredicate, (??),
+    Args, Ways, Packages,
     append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
     interpret, interpretExpr,
-    applyPredicate, (?), (??), stage, package, builder, file, way,
-    configKeyValue, configKeyValues
+    stage, package, builder, file, way
     ) where
 
 import Way
@@ -72,11 +72,28 @@ applyPredicate predicate expr = do
     if bool then expr else return mempty
 
 -- A convenient operator for predicate application
-(?) :: Monoid a => Predicate -> Expr a -> Expr a
-(?) = applyPredicate
+class PredicateLike a where
+    (?)  :: Monoid m => a -> Expr m -> Expr m
+    notP :: a -> Predicate
 
 infixr 8 ?
 
+instance PredicateLike Predicate where
+    (?)  = applyPredicate
+    notP = liftM not
+
+instance PredicateLike Bool where
+    (?)  = applyPredicate . return
+    notP = return . not
+
+instance PredicateLike (Action Bool) where
+    (?)  = applyPredicate . lift
+    notP = lift . fmap not
+
+-- An equivalent of if-then-else for predicates
+(??) :: (PredicateLike a, Monoid m) => a -> (Expr m, Expr m) -> Expr m
+p ?? (t, f) = p ? t <> notP p ? f
+
 -- A monadic version of append
 appendM :: Monoid a => Action a -> DiffExpr a
 appendM mx = lift mx >>= append
@@ -126,10 +143,6 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
 interpret :: Monoid a => Target -> DiffExpr a -> Action a
 interpret target = interpretExpr target . fromDiffExpr
 
--- An equivalent of if-then-else for predicates
-(??) :: Monoid a => Predicate -> (Expr a, Expr a) -> Expr a
-p ?? (t, f) = p ? t <> (liftM not p) ? f
-
 -- Basic predicates (see Switches.hs for derived predicates)
 stage :: Stage -> Predicate
 stage s = liftM (s ==) (asks getStage)
@@ -145,11 +158,3 @@ file f = liftM (any (f ?==)) (asks getFiles)
 
 way :: Way -> Predicate
 way w = liftM (w ==) (asks getWay)
-
-configKeyValue :: String -> String -> Predicate
-configKeyValue key value = liftM (value ==) (lift $ askConfig key)
-
--- Check if there is at least one match
--- Example: configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
-configKeyValues :: String -> [String] -> Predicate
-configKeyValues key values = liftM (`elem` values) (lift $ askConfig key)

src/Oracles/Flag.hs

 module Oracles.Flag (
-    Flag (..),
-    test
+    Flag (..), flag,
+    supportsPackageKey, crossCompiling, gccIsClang, gccLt46,
+    platformSupportsSharedLibs
     ) where
 
 import Util
 import Oracles.Base
+import Oracles.Setting
+import Control.Monad
 
-data Flag = LaxDeps
-          | DynamicGhcPrograms
-          | GccIsClang
+data Flag = GccIsClang
           | GccLt46
           | CrossCompiling
-          | Validating
           | SupportsPackageKey
           | SolarisBrokenShld
           | SplitObjectsBroken
           | GhcUnregisterised
 
--- TODO: Give the warning *only once* per key
-test :: Flag -> Action Bool
-test flag = do
-    (key, defaultValue) <- return $ case flag of
-        LaxDeps            -> ("lax-dependencies"     , False)
-        DynamicGhcPrograms -> ("dynamic-ghc-programs" , False)
-        GccIsClang         -> ("gcc-is-clang"         , False)
-        GccLt46            -> ("gcc-lt-46"            , False)
-        CrossCompiling     -> ("cross-compiling"      , False)
-        Validating         -> ("validating"           , False)
-        SupportsPackageKey -> ("supports-package-key" , False)
-        SolarisBrokenShld  -> ("solaris-broken-shld"  , False)
-        SplitObjectsBroken -> ("split-objects-broken" , False)
-        GhcUnregisterised  -> ("ghc-unregisterised"   , False)
-    let defaultString = if defaultValue then "YES" else "NO"
-    value <- askConfigWithDefault key $ -- TODO: warn just once
-        do putColoured Red $ "\nFlag '"
-                ++ key
-                ++ "' not set in configuration files. "
-                ++ "Proceeding with default value '"
-                ++ defaultString
-                ++ "'.\n"
-           return defaultString
+flag :: Flag -> Action Bool
+flag f = do
+    key <- return $ case f of
+        GccIsClang         -> "gcc-is-clang"
+        GccLt46            -> "gcc-lt-46"
+        CrossCompiling     -> "cross-compiling"
+        SupportsPackageKey -> "supports-package-key"
+        SolarisBrokenShld  -> "solaris-broken-shld"
+        SplitObjectsBroken -> "split-objects-broken"
+        GhcUnregisterised  -> "ghc-unregisterised"
+    value <- askConfigWithDefault key . redError
+        $ "\nFlag '" ++ key ++ "' not set in configuration files."
+    unless (value == "YES" || value == "NO") . redError
+        $ "\nFlag '" ++ key ++ "' is set to '" ++ value
+        ++ "' instead of 'YES' or 'NO'."
     return $ value == "YES"
+
+supportsPackageKey :: Action Bool
+supportsPackageKey = flag SupportsPackageKey
+
+crossCompiling :: Action Bool
+crossCompiling = flag CrossCompiling
+
+gccIsClang :: Action Bool
+gccIsClang = flag GccIsClang
+
+gccLt46 :: Action Bool
+gccLt46 = flag GccLt46
+
+platformSupportsSharedLibs :: Action Bool
+platformSupportsSharedLibs = do
+    badPlatform   <- targetPlatforms [ "powerpc-unknown-linux"
+                                     , "x86_64-unknown-mingw32"
+                                     , "i386-unknown-mingw32" ]
+    solaris       <- targetPlatform    "i386-unknown-solaris2"
+    solarisBroken <- flag SolarisBrokenShld
+    return $ not (badPlatform || solaris && solarisBroken)

src/Oracles/Setting.hs

 module Oracles.Setting (
     Setting (..), SettingList (..),
     setting, settingList,
-    windowsHost
+    targetPlatform, targetPlatforms, targetOs, targetOss, notTargetOs,
+    targetArchs, windowsHost, notWindowsHost, ghcWithInterpreter
     ) where
 
 import Stage
@@ -53,7 +54,42 @@ settingList key = fmap words $ askConfig $ case key of
     GmpIncludeDirs          -> "gmp-include-dirs"
     GmpLibDirs              -> "gmp-lib-dirs"
 
+matchSetting :: Setting -> [String] -> Action Bool
+matchSetting key values = do
+    value <- setting key
+    return $ value `elem` values
+
+targetPlatforms :: [String] -> Action Bool
+targetPlatforms = matchSetting TargetPlatformFull
+
+targetPlatform :: String -> Action Bool
+targetPlatform s = targetPlatforms [s]
+
+targetOss :: [String] -> Action Bool
+targetOss = matchSetting TargetOs
+
+targetOs :: String -> Action Bool
+targetOs s = targetOss [s]
+
+notTargetOs :: String -> Action Bool
+notTargetOs = fmap not . targetOs
+
+targetArchs :: [String] -> Action Bool
+targetArchs = matchSetting TargetArch
+
 windowsHost :: Action Bool
 windowsHost = do
     hostOsCpp <- setting HostOsCpp
     return $ hostOsCpp `elem` ["mingw32", "cygwin32"]
+
+notWindowsHost :: Action Bool
+notWindowsHost = fmap not windowsHost
+
+ghcWithInterpreter :: Action Bool
+ghcWithInterpreter = do
+    goodOs <- targetOss [ "mingw32", "cygwin32", "linux", "solaris2"
+                        , "freebsd", "dragonfly", "netbsd", "openbsd"
+                        , "darwin", "kfreebsdgnu" ]
+    goodArch <- targetArchs [ "i386", "x86_64", "powerpc", "sparc"
+                            , "sparc64", "arm" ]
+    return $ goodOs && goodArch

src/Rules/Actions.hs

 module Rules.Actions (
-    build, buildWhen, run, verboseRun,
+    build, buildWhen, run, verboseRun
     ) where
 
 import Util
 import Builder
 import Expression
 import Settings.Args
+import Settings.Util
 import Oracles.ArgsHash
 import Development.Shake
 
@@ -15,8 +16,6 @@ import Development.Shake
 build :: FullTarget -> Action ()
 build target = do
     argList <- interpret target args
-    putColoured Green (show target)
-    putColoured Green (show argList)
     -- The line below forces the rule to be rerun if the args hash has changed
     argsHash <- askArgsHash target
     run (getBuilder target) argList

src/Settings/GhcCabal.hs

@@ -10,6 +10,8 @@ import Util
 import Switches
 import Expression
 import Oracles.Base
+import Oracles.Flag
+import Oracles.Setting
 import Settings.User
 import Settings.Ways
 import Settings.Util
@@ -30,7 +32,7 @@ cabalArgs = builder GhcCabal ? do
             , with $ GhcPkg stage
             , stage0 ? bootPackageDbArgs
             , libraryArgs
-            , configKeyNonEmpty "hscolour" ? with HsColour
+            , with HsColour
             , configureArgs
             , stage0 ? packageConstraints
             , with $ Gcc stage
@@ -42,13 +44,12 @@ 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
-    ghcInterpreter  <- ghcWithInterpreter
-    dynamicPrograms <- dynamicGhcPrograms
+    ways           <- fromDiffExpr Settings.Ways.ways
+    ghcInterpreter <- lift $ ghcWithInterpreter
     append [ if vanilla `elem` ways
              then  "--enable-library-vanilla"
              else "--disable-library-vanilla"
-           , if vanilla `elem` ways && ghcInterpreter && not dynamicPrograms
+           , if vanilla `elem` ways && ghcInterpreter && not dynamicGhcPrograms
              then  "--enable-library-for-ghci"
              else "--disable-library-for-ghci"
            , if profiling `elem` ways
@@ -151,7 +152,7 @@ withBuilderKey builder = case builder of
 
 -- Expression 'with Gcc' appends "--with-gcc=/path/to/gcc" and needs Gcc.
 with :: Builder -> Args
-with builder = do
+with builder = specified builder ? do
     path <- lift $ builderPath builder
     lift $ needBuilder builder
     append [withBuilderKey builder ++ path]

src/Settings/Packages.hs

@@ -6,6 +6,7 @@ module Settings.Packages (
 import Package
 import Switches
 import Expression
+import Oracles.Setting
 import Settings.User
 import Settings.Default
 

src/Settings/User.hs

@@ -2,7 +2,7 @@ module Settings.User (
     module Settings.Default,
     userArgs, userPackages, userWays, userTargetDirectory,
     userKnownPackages, integerLibrary,
-    buildHaddock, validating
+    buildHaddock, validating, dynamicGhcPrograms, laxDependencies
     ) where
 
 import Stage
@@ -35,10 +35,18 @@ userTargetDirectory = defaultTargetDirectory
 integerLibrary :: Package
 integerLibrary = integerGmp2
 
--- User-defined predicates
--- TODO: migrate more predicates here from configuration files
+-- User-defined flags. Note the following type semantics:
+-- * Bool: a plain Boolean flag whose value is known at compile time
+-- * Action Bool: a flag whose value can depend on the build environment
+-- * Predicate: a flag depending on the build environment and the current target
+validating :: Bool
+validating = False
+
+dynamicGhcPrograms :: Bool
+dynamicGhcPrograms = False
+
+laxDependencies :: Bool
+laxDependencies = False
+
 buildHaddock :: Predicate
 buildHaddock = return True
-
-validating :: Predicate
-validating = return False

src/Settings/Util.hs

@@ -3,6 +3,7 @@ module Settings.Util (
     arg, argPath, argM,
     argConfig, argStagedConfig, argConfigList, argStagedConfigList,
     appendCcArgs,
+    needBuilder
     -- argBuilderPath, argStagedBuilderPath,
     -- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
     -- argIncludeDirs, argDepIncludeDirs,
@@ -14,6 +15,7 @@ module Settings.Util (
 import Util
 import Stage
 import Builder
+import Settings.User
 import Oracles.Base
 import Expression
 
@@ -55,6 +57,20 @@ appendCcArgs xs = do
             , builder GhcCabal    ? appendSub "--configure-option=CFLAGS" xs
             , builder GhcCabal    ? appendSub "--gcc-options" xs ]
 
+-- Make sure a builder exists on the given path and rebuild it if out of date.
+-- If laxDependencies is true (Settings/User.hs) then we do not rebuild GHC
+-- even if it is out of date (can save a lot of build time when changing GHC).
+needBuilder :: Builder -> Action ()
+needBuilder ghc @ (Ghc stage) = do
+    path <- builderPath ghc
+    if laxDependencies then orderOnly [path] else need [path]
+
+needBuilder builder = do
+    path <- builderPath builder
+    need [path]
+
+
+
 -- packageData :: Arity -> String -> Args
 -- packageData arity key =
 --     return $ EnvironmentParameter $ PackageData arity key Nothing Nothing

src/Settings/Ways.hs

@@ -6,6 +6,7 @@ import Way
 import Stage
 import Switches
 import Expression
+import Oracles.Flag
 import Settings.User
 
 -- Combining default ways with user modifications

src/Switches.hs

 module Switches (
     notStage, stage0, stage1, stage2,
-    configKeyYes, configKeyNo, configKeyNonEmpty,
-    supportsPackageKey, targetPlatforms, targetPlatform,
-    targetOss, targetOs, notTargetOs,
-    targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
-    platformSupportsSharedLibs, crossCompiling,
-    gccIsClang, gccLt46, windowsHost, notWindowsHost,
-    registerPackage
+    registerPackage, splitObjects
     ) where
 
 import Stage
+import Oracles.Flag
+import Oracles.Setting
 import Expression
 
 -- Derived predicates
 notStage :: Stage -> Predicate
-notStage = liftM not . stage
+notStage = notP . stage
 
 stage0 :: Predicate
 stage0 = stage Stage0
@@ -25,84 +21,17 @@ stage1 = stage Stage1
 stage2 :: Predicate
 stage2 = stage Stage2
 
-configKeyYes :: String -> Predicate
-configKeyYes key = configKeyValue key "YES"
-
-configKeyNo :: String -> Predicate
-configKeyNo key = configKeyValue key "NO"
-
-configKeyNonEmpty :: String -> Predicate
-configKeyNonEmpty key = liftM not $ configKeyValue key ""
-
--- Predicates based on configuration files
-supportsPackageKey :: Predicate
-supportsPackageKey = configKeyYes "supports-package-key"
-
-targetPlatforms :: [String] -> Predicate
-targetPlatforms = configKeyValues "target-platform-full"
-
-targetPlatform :: String -> Predicate
-targetPlatform s = targetPlatforms [s]
-
-targetOss :: [String] -> Predicate
-targetOss = configKeyValues "target-os"
-
-targetOs :: String -> Predicate
-targetOs s = targetOss [s]
-
-notTargetOs :: String -> Predicate
-notTargetOs = liftM not . targetOs
-
-targetArchs :: [String] -> Predicate
-targetArchs = configKeyValues "target-arch"
-
-platformSupportsSharedLibs :: Predicate
-platformSupportsSharedLibs = do
-    badPlatform   <- targetPlatforms [ "powerpc-unknown-linux"
-                                     , "x86_64-unknown-mingw32"
-                                     , "i386-unknown-mingw32" ]
-    solaris       <- targetPlatform    "i386-unknown-solaris2"
-    solarisBroken <- configKeyYes "solaris-broken-shld"
-    return $ not (badPlatform || solaris && solarisBroken)
-
-dynamicGhcPrograms :: Predicate
-dynamicGhcPrograms = configKeyYes "dynamic-ghc-programs"
-
-ghcWithInterpreter :: Predicate
-ghcWithInterpreter = do
-    goodOs <- targetOss [ "mingw32", "cygwin32", "linux", "solaris2"
-                        , "freebsd", "dragonfly", "netbsd", "openbsd"
-                        , "darwin", "kfreebsdgnu" ]
-    goodArch <- targetArchs [ "i386", "x86_64", "powerpc", "sparc"
-                            , "sparc64", "arm" ]
-    return $ goodOs && goodArch
-
-crossCompiling :: Predicate
-crossCompiling = configKeyYes "cross-compiling"
-
-gccIsClang :: Predicate
-gccIsClang = configKeyYes "gcc-is-clang"
-
-gccLt46 :: Predicate
-gccLt46 = configKeyYes "gcc-lt-46"
-
-windowsHost :: Predicate
-windowsHost = configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
-
-notWindowsHost :: Predicate
-notWindowsHost = liftM not windowsHost
-
 -- TODO: Actually, we don't register compiler in some circumstances -- fix.
 registerPackage :: Predicate
 registerPackage = return True
 
--- splitObjects :: Stage -> Condition
--- splitObjects stage = do
---     arch <- showArg TargetArch
---     os   <- showArg TargetOs
---     not SplitObjectsBroken && not GhcUnregisterised
---         && stage == Stage1
---         && arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
---         && os   `elem` ["mingw32", "cygwin32", "linux", "darwin",
---                        "solaris2", "freebsd", "dragonfly", "netbsd",
---                        "openbsd"]
+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