Commit b2533979 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

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

parent 6e8416e2
......@@ -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:
#=================================
......
{-# 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
......@@ -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)
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)
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
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
......
......@@ -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]
......@@ -6,6 +6,7 @@ module Settings.Packages (
import Package
import Switches
import Expression
import Oracles.Setting
import Settings.User
import Settings.Default
......
......@@ -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
......@@ -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
......
......@@ -6,6 +6,7 @@ import Way
import Stage
import Switches
import Expression
import Oracles.Flag
import Settings.User
-- Combining default ways with user modifications
......
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment