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

Rename Settings to Args. Rename old Args defined in Base.hs to ArgList (to be dropped later).

parent 92ef7772
......@@ -9,9 +9,8 @@ module Base (
module Data.Monoid,
module Data.List,
Stage (..),
Arg, Args,
Arg, ArgList,
ShowArg (..), ShowArgs (..),
arg, args,
Condition (..),
filterOut,
productArgs, concatArgs
......@@ -31,13 +30,14 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
instance Show Stage where
show = show . fromEnum
-- Instances for storing Target in the Shake database
instance Binary Stage
instance Hashable Stage
-- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder
type Arg = Action String
type Args = Action [String]
type Arg = Action String
type ArgList = Action [String]
type Condition = Action Bool
......@@ -55,7 +55,7 @@ instance ShowArg a => ShowArg (Action a) where
showArg = (showArg =<<)
class ShowArgs a where
showArgs :: a -> Args
showArgs :: a -> ArgList
instance ShowArgs [String] where
showArgs = return
......@@ -63,27 +63,21 @@ instance ShowArgs [String] where
instance ShowArgs [Arg] where
showArgs = sequence
instance ShowArgs [Args] where
instance ShowArgs [ArgList] where
showArgs = mconcat
instance ShowArgs a => ShowArgs (Action a) where
showArgs = (showArgs =<<)
args :: ShowArgs a => a -> Args
args = showArgs
arg :: ShowArg a => a -> Args
arg a = args [showArg a]
-- Filter out given arg(s) from a collection
filterOut :: ShowArgs a => Args -> a -> Args
filterOut :: ShowArgs a => ArgList -> a -> ArgList
filterOut as exclude = do
exclude' <- showArgs exclude
filter (`notElem` exclude') <$> as
-- Generate a cross product collection of two argument collections
-- Example: productArgs ["-a", "-b"] "c" = args ["-a", "c", "-b", "c"]
productArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
productArgs :: (ShowArgs a, ShowArgs b) => a -> b -> ArgList
productArgs as bs = do
as' <- showArgs as
bs' <- showArgs bs
......@@ -91,7 +85,7 @@ productArgs as bs = do
-- Similar to productArgs but concat resulting arguments pairwise
-- Example: concatArgs ["-a", "-b"] "c" = args ["-ac", "-bc"]
concatArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
concatArgs :: (ShowArgs a, ShowArgs b) => a -> b -> ArgList
concatArgs as bs = do
as' <- showArgs as
bs' <- showArgs bs
......
......@@ -4,14 +4,14 @@ module Expression (
module Data.Monoid,
module Control.Monad.Reader,
Expr, DiffExpr, fromDiffExpr,
Predicate, Settings, Ways, Packages,
Predicate, Args, Ways, Packages,
append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
interpret, interpretExpr,
applyPredicate, (?), (??), stage, package, builder, file, way,
configKeyValue, configKeyValues
) where
import Base hiding (arg, args, Args, TargetDir)
import Base hiding (Args)
import Ways
import Target
import Oracles
......@@ -47,12 +47,12 @@ instance Monoid (Diff a) where
Diff x `mappend` Diff y = Diff $ y . x
-- The following expressions are used throughout the build system for
-- specifying conditions (Predicate), lists of arguments (Settings), Ways and
-- specifying conditions (Predicate), lists of arguments (Args), Ways and
-- Packages.
type Predicate = Expr Bool
type Settings = DiffExpr [String] -- TODO: rename to Args
type Ways = DiffExpr [Way]
type Args = DiffExpr [String]
type Packages = DiffExpr [Package]
type Ways = DiffExpr [Way]
-- Basic operations on expressions:
-- 1) append something to an expression
......@@ -83,7 +83,7 @@ appendM mx = lift mx >>= append
-- 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] -> Settings
appendSub :: String -> [String] -> Args
appendSub prefix xs
| xs' == [] = mempty
| otherwise = return . Diff $ go False
......@@ -97,10 +97,10 @@ appendSub prefix xs
-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
appendSubD :: String -> Settings -> Settings
appendSubD :: String -> Args -> Args
appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
filterSub :: String -> (String -> Bool) -> Settings
filterSub :: String -> (String -> Bool) -> Args
filterSub prefix p = return . Diff $ map filterSubstr
where
filterSubstr s
......@@ -109,7 +109,7 @@ filterSub prefix p = return . Diff $ map filterSubstr
-- Remove given elements from a list of sub-arguments with a given prefix
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
removeSub :: String -> [String] -> Settings
removeSub :: String -> [String] -> Args
removeSub prefix xs = filterSub prefix (`notElem` xs)
-- Interpret a given expression in a given environment
......
......@@ -5,9 +5,9 @@ module Oracles.ArgsHash (
) where
import Development.Shake.Classes
import Base
import Expression
import Base hiding (args)
import Settings
import Expression
newtype ArgsHashKey = ArgsHashKey Target
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
......@@ -18,5 +18,5 @@ askArgsHash = askOracle . ArgsHashKey
-- Oracle for storing per-target argument list hashes
argsHashOracle :: Rules ()
argsHashOracle = do
addOracle $ \(ArgsHashKey target) -> hash <$> interpret target settings
addOracle $ \(ArgsHashKey target) -> hash <$> interpret target args
return ()
......@@ -4,7 +4,7 @@ module Rules (
module Rules.Package,
) where
import Base hiding (arg, args, Args)
import Base
import Control.Monad
import Expression
import Rules.Package
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Rules.Data (
cabalSettings, ghcPkgSettings, buildPackageData
cabalArgs, ghcPkgArgs, buildPackageData
) where
import Base hiding (arg, args, Args)
import Base
import Package
import Expression hiding (when, liftIO)
import Oracles.Flag (when)
......
......@@ -11,9 +11,9 @@ import Oracles.ArgsHash
build :: Target -> Action ()
build target = do
args <- interpret target settings
argList <- interpret target args
putColoured Green (show target)
putColoured Green (show args)
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) args
run (getBuilder target) argList
module Settings (
settings
args
) where
import Base hiding (arg, args)
import Base hiding (arg, args, Args)
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.User
import Expression hiding (when, liftIO)
settings :: Settings
settings = defaultSettings <> userSettings
args :: Args
args = defaultArgs <> userArgs
-- TODO: add all other settings
defaultSettings :: Settings
defaultSettings = mconcat
[ cabalSettings
, ghcPkgSettings
, customPackageSettings ]
defaultArgs :: Args
defaultArgs = mconcat
[ cabalArgs
, ghcPkgArgs
, customPackageArgs ]
module Settings.GhcCabal (
cabalSettings, bootPackageDbSettings, customPackageSettings
cabalArgs, bootPackageDbArgs, customPackageArgs
) where
import Base hiding (arg, args)
import Base
import Oracles.Base
import Oracles.Builder
import Ways
......@@ -16,20 +16,20 @@ import Settings.Util
import Settings.Packages
import Settings.TargetDirectory
cabalSettings :: Settings
cabalSettings = builder GhcCabal ? do
cabalArgs :: Args
cabalArgs = builder GhcCabal ? do
stage <- asks getStage
pkg <- asks getPackage
mconcat [ arg "configure"
, arg $ pkgPath pkg
, arg $ targetDirectory stage pkg
, dllSettings
, dllArgs
, argWith $ Ghc stage
, argWith $ GhcPkg stage
, stage0 ? bootPackageDbSettings
, librarySettings
, stage0 ? bootPackageDbArgs
, libraryArgs
, configKeyNonEmpty "hscolour" ? argWith HsColour
, configureSettings
, configureArgs
, stage0 ? packageConstraints
, argWith $ Gcc stage
, notStage Stage0 ? argWith Ld
......@@ -38,8 +38,8 @@ cabalSettings = builder GhcCabal ? do
, argWith Happy ]
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
librarySettings :: Settings
librarySettings = do
libraryArgs :: Args
libraryArgs = do
ways <- fromDiffExpr Settings.Ways.ways
ghcInterpreter <- ghcWithInterpreter
dynamicPrograms <- dynamicGhcPrograms
......@@ -56,15 +56,15 @@ librarySettings = do
then "--enable-shared"
else "--disable-shared" ]
configureSettings :: Settings
configureSettings = do
configureArgs :: Args
configureArgs = do
stage <- asks getStage
let conf key = appendSubD $ "--configure-option=" ++ key
cFlags = mconcat [ ccSettings
cFlags = mconcat [ ccArgs
, remove ["-Werror"]
, argStagedConfig "conf-cc-args" ]
ldFlags = ldSettings <> argStagedConfig "conf-gcc-linker-args"
cppFlags = cppSettings <> argStagedConfig "conf-cpp-args"
ldFlags = ldArgs <> argStagedConfig "conf-gcc-linker-args"
cppFlags = cppArgs <> argStagedConfig "conf-cpp-args"
mconcat
[ conf "CFLAGS" cFlags
, conf "LDFLAGS" ldFlags
......@@ -78,18 +78,18 @@ configureSettings = do
, crossCompiling ? (conf "--host" $ argConfig "target-platform-full")
, conf "--with-cc" . argM . showArg $ Gcc stage ]
bootPackageDbSettings :: Settings
bootPackageDbSettings = do
bootPackageDbArgs :: Args
bootPackageDbArgs = do
sourcePath <- lift $ askConfig "ghc-source-path"
arg $ "--package-db=" ++ sourcePath </> "libraries/bootstrapping.conf"
-- This is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument;
-- * otherwise, we must collapse it into one space-separated string.
dllSettings :: Settings
dllSettings = arg ""
dllArgs :: Args
dllArgs = arg ""
packageConstraints :: Settings
packageConstraints :: Args
packageConstraints = do
pkgs <- fromDiffExpr packages
constraints <- lift $ forM pkgs $ \pkg -> do
......@@ -102,12 +102,12 @@ packageConstraints = do
[v] -> return $ prefix ++ dropWhile (not . isDigit) v
_ -> redError $ "Cannot determine package version in '"
++ cabal ++ "'."
args $ concatMap (\c -> ["--constraint", c]) $ constraints
append $ concatMap (\c -> ["--constraint", c]) $ constraints
-- TODO: should be in a different file
-- TODO: put all validating options together in one file
ccSettings :: Settings
ccSettings = validating ? do
ccArgs :: Args
ccArgs = validating ? do
let gccGe46 = liftM not gccLt46
mconcat [ arg "-Werror"
, arg "-Wall"
......@@ -116,18 +116,18 @@ ccSettings = validating ? do
gccGe46 ? windowsHost ? arg "-Werror=unused-but-set-variable"
, gccGe46 ? arg "-Wno-error=inline" )]
ldSettings :: Settings
ldSettings = mempty
ldArgs :: Args
ldArgs = mempty
cppSettings :: Settings
cppSettings = mempty
cppArgs :: Args
cppArgs = mempty
customPackageSettings :: Settings
customPackageSettings = mconcat
customPackageArgs :: Args
customPackageArgs = mconcat
[ package integerGmp2 ?
mconcat [ windowsHost ? builder GhcCabal ?
arg "--configure-option=--with-intree-gmp"
, ccArgs ["-Ilibraries/integer-gmp2/gmp"] ]
, appendCcArgs ["-Ilibraries/integer-gmp2/gmp"] ]
, package base ?
builder GhcCabal ? arg ("--flags=" ++ pkgName integerLibrary)
......
module Settings.GhcPkg (
ghcPkgSettings
ghcPkgArgs
) where
import Base hiding (arg, args)
import Base
import Switches
import Expression hiding (when, liftIO)
import Settings.Util
......@@ -10,12 +10,12 @@ import Oracles.Builder
import Settings.GhcCabal
import Settings.TargetDirectory
ghcPkgSettings :: Settings
ghcPkgSettings = do
ghcPkgArgs :: Args
ghcPkgArgs = do
pkg <- asks getPackage
stage <- asks getStage
builder (GhcPkg stage) ? mconcat
[ arg "update"
, arg "--force"
, stage0 ? bootPackageDbSettings
, stage0 ? bootPackageDbArgs
, arg $ targetPath stage pkg </> "inplace-pkg-config" ]
module Settings.User (
module Settings.Default,
userSettings, userPackages, userWays, userTargetDirectory,
userArgs, userPackages, userWays, userTargetDirectory,
userKnownPackages, integerLibrary,
buildHaddock, validating
) where
import Base hiding (arg, args, Args)
import Base hiding (Args)
import Package
import Settings.Default
import Expression
-- No user-specific settings by default
-- TODO: rename to userArgs
userSettings :: Settings
userSettings = mempty
userArgs :: Args
userArgs = mempty
-- Control which packages get to be built
userPackages :: Packages
......
......@@ -2,9 +2,9 @@
module Settings.Util (
-- Primitive settings elements
arg, argM, args, argWith,
arg, argM, argWith,
argConfig, argStagedConfig, argConfigList, argStagedConfigList,
ccArgs,
appendCcArgs,
-- argBuilderPath, argStagedBuilderPath,
-- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
-- argIncludeDirs, argDepIncludeDirs,
......@@ -18,95 +18,91 @@ import Oracles hiding (not)
import Expression
-- A single argument
arg :: String -> Settings
arg :: String -> Args
arg = append . return
argM :: Action String -> Settings
argM :: Action String -> Args
argM = appendM . fmap return
-- A list of arguments
args :: [String] -> Settings
args = append
argWith :: Builder -> Settings
argWith :: Builder -> Args
argWith = argM . with
argConfig :: String -> Settings
argConfig :: String -> Args
argConfig = appendM . fmap return . askConfig
argConfigList :: String -> Settings
argConfigList :: String -> Args
argConfigList = appendM . fmap words . askConfig
stagedKey :: Stage -> String -> String
stagedKey stage key = key ++ "-stage" ++ show stage
argStagedConfig :: String -> Settings
argStagedConfig :: String -> Args
argStagedConfig key = do
stage <- asks getStage
argConfig (stagedKey stage key)
argStagedConfigList :: String -> Settings
argStagedConfigList :: String -> Args
argStagedConfigList key = do
stage <- asks getStage
argConfigList (stagedKey stage key)
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
ccArgs :: [String] -> Settings
ccArgs xs = do
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
stage <- asks getStage
mconcat [ builder (Gcc stage) ? args xs
mconcat [ builder (Gcc stage) ? append xs
, builder GhcCabal ? appendSub "--configure-option=CFLAGS" xs
, builder GhcCabal ? appendSub "--gcc-options" xs ]
-- packageData :: Arity -> String -> Settings
-- packageData :: Arity -> String -> Args
-- packageData arity key =
-- return $ EnvironmentParameter $ PackageData arity key Nothing Nothing
-- -- Accessing key value pairs from package-data.mk files
-- argPackageKey :: Args
-- argPackageKey = packageData Single "PACKAGE_KEY"
-- argPackageDeps :: Args
-- argPackageDeps = packageData Multiple "DEPS"
-- argPackageDepKeys :: Args
-- argPackageDepKeys = packageData Multiple "DEP_KEYS"
-- argSrcDirs :: Args
-- argSrcDirs = packageData Multiple "HS_SRC_DIRS"
-- argIncludeDirs :: Args
-- argIncludeDirs = packageData Multiple "INCLUDE_DIRS"
-- argDepIncludeDirs :: Args
-- argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
-- argPackageConstraints :: Packages -> Args
-- argPackageConstraints = return . EnvironmentParameter . PackageConstraints
-- -- Concatenate arguments: arg1 ++ arg2 ++ ...
-- argConcat :: Args -> Args
-- argConcat = return . Fold Concat
-- -- </>-concatenate arguments: arg1 </> arg2 </> ...
-- argConcatPath :: Args -> Args
-- argConcatPath = return . Fold ConcatPath
-- -- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
-- argConcatSpace :: Args -> Args
-- argConcatSpace = return . Fold ConcatSpace
-- -- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
-- argPairs :: String -> Args -> Args
-- argPairs prefix settings = settings >>= (arg prefix |>) . return
-- -- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
-- argPrefix :: String -> Args -> Args
-- argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
-- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
-- argPrefixPath :: String -> Args -> Args
-- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
......@@ -4,7 +4,7 @@ module Ways ( -- TODO: rename to "Way"?
WayUnit (..),
Way, tag,
allWays, defaultWays,
allWays,
vanilla, profiling, logging, parallel, granSim,
threaded, threadedProfiling, threadedLogging,
......@@ -13,7 +13,6 @@ module Ways ( -- TODO: rename to "Way"?
threadedDynamic, threadedDebugDynamic, debugDynamic,
loggingDynamic, threadedLoggingDynamic,
wayHcArgs,
wayPrefix,
hisuf, osuf, hcsuf, obootsuf, ssuf, libsuf,
detectWay
......@@ -87,27 +86,27 @@ allWays = [vanilla, profiling, logging, parallel, granSim,
threadedDynamic, threadedDebugDynamic, debugDynamic,
loggingDynamic, threadedLoggingDynamic]
defaultWays :: Stage -> Action [Way]
defaultWays stage = do
sharedLibs <- platformSupportsSharedLibs
return $ [vanilla]
++ [profiling | stage /= Stage0]
++ [dynamic | sharedLibs ]
-- defaultWays :: Stage -> Action [Way]
-- defaultWays stage = do
-- sharedLibs <- platformSupportsSharedLibs
-- return $ [vanilla]
-- ++ [profiling | stage /= Stage0]
-- ++ [dynamic | sharedLibs ]
-- TODO: do '-ticky' in all debug ways?
wayHcArgs :: Way -> Args
wayHcArgs (Way _ units) = args
[ if (Dynamic `elem` units)
then args ["-fPIC", "-dynamic"]
else arg "-static"
, when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
, when (Debug `elem` units) $ arg "-optc-DDEBUG"
, when (Profiling `elem` units) $ arg "-prof"
, when (Logging `elem` units) $ arg "-eventlog"
, when (Parallel `elem` units) $ arg "-parallel"
, when (GranSim `elem` units) $ arg "-gransim"
, when (units == [Debug] || units == [Debug, Dynamic]) $
args ["-ticky", "-DTICKY_TICKY"] ]
-- wayHcArgs :: Way -> Args
-- wayHcArgs (Way _ units) = args
-- [ if (Dynamic `elem` units)
-- then args ["-fPIC", "-dynamic"]
-- else arg "-static"
-- , when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
-- , when (Debug `elem` units) $ arg "-optc-DDEBUG"
-- , when (Profiling `elem` units) $ arg "-prof"
-- , when (Logging `elem` units) $ arg "-eventlog"
-- , when (Parallel `elem` units) $ arg "-parallel"
-- , when (GranSim `elem` units) $ arg "-gransim"
-- , when (units == [Debug] || units == [Debug, Dynamic]) $
-- args ["-ticky", "-DTICKY_TICKY"] ]
wayPrefix :: Way -> String
wayPrefix way | isVanilla way = ""
......
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