Rename Settings to Args. Rename old Args defined in Base.hs to ArgList (to be dropped...
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 14 Jul 2015 13:19:15 +0000 (14:19 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 14 Jul 2015 13:19:15 +0000 (14:19 +0100)
12 files changed:
src/Base.hs
src/Expression.hs
src/Oracles/ArgsHash.hs
src/Rules.hs
src/Rules/Data.hs
src/Rules/Util.hs
src/Settings.hs
src/Settings/GhcCabal.hs
src/Settings/GhcPkg.hs
src/Settings/User.hs
src/Settings/Util.hs
src/Ways.hs

index 9789677..0aae7cd 100644 (file)
@@ -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
index c18b0ac..47f5984 100644 (file)
@@ -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
index 3a9ff38..6a0276f 100644 (file)
@@ -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 ()
index 987ec9d..7fa126e 100644 (file)
@@ -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
index f3c6064..aaeb5fe 100644 (file)
@@ -1,10 +1,10 @@
 {-# 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)
index 8c9f1c4..a18e25e 100644 (file)
@@ -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
index 3f711a5..e4519f1 100644 (file)
@@ -1,19 +1,19 @@
 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 ]
index 56da007..f45f3ea 100644 (file)
@@ -1,8 +1,8 @@
 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)
index 601d2b8..5da4e5d 100644 (file)
@@ -1,8 +1,8 @@
 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" ]
index 35e47bd..536d976 100644 (file)
@@ -1,19 +1,19 @@
 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
index d7bfa49..ddb40e0 100644 (file)
@@ -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 :: Settings
+-- argPackageKey :: Args
 -- argPackageKey = packageData Single "PACKAGE_KEY"
 
--- argPackageDeps :: Settings
+-- argPackageDeps :: Args
 -- argPackageDeps = packageData Multiple "DEPS"
 
--- argPackageDepKeys :: Settings
+-- argPackageDepKeys :: Args
 -- argPackageDepKeys = packageData Multiple "DEP_KEYS"
 
--- argSrcDirs :: Settings
+-- argSrcDirs :: Args
 -- argSrcDirs = packageData Multiple "HS_SRC_DIRS"
 
--- argIncludeDirs :: Settings
+-- argIncludeDirs :: Args
 -- argIncludeDirs = packageData Multiple "INCLUDE_DIRS"
 
--- argDepIncludeDirs :: Settings
+-- argDepIncludeDirs :: Args
 -- argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
 
--- argPackageConstraints :: Packages -> Settings
+-- argPackageConstraints :: Packages -> Args
 -- argPackageConstraints = return . EnvironmentParameter . PackageConstraints
 
 -- -- Concatenate arguments: arg1 ++ arg2 ++ ...
--- argConcat :: Settings -> Settings
+-- argConcat :: Args -> Args
 -- argConcat = return . Fold Concat
 
 -- -- </>-concatenate arguments: arg1 </> arg2 </> ...
--- argConcatPath :: Settings -> Settings
+-- argConcatPath :: Args -> Args
 -- argConcatPath = return . Fold ConcatPath
 
 -- -- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
--- argConcatSpace :: Settings -> Settings
+-- argConcatSpace :: Args -> Args
 -- argConcatSpace = return . Fold ConcatSpace
 
 -- -- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
--- argPairs :: String -> Settings -> Settings
+-- argPairs :: String -> Args -> Args
 -- argPairs prefix settings = settings >>= (arg prefix |>) . return
 
 -- -- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
--- argPrefix :: String -> Settings -> Settings
+-- argPrefix :: String -> Args -> Args
 -- argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
 
 -- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
--- argPrefixPath :: String -> Settings -> Settings
+-- argPrefixPath :: String -> Args -> Args
 -- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
index c4cbc28..10927cb 100644 (file)
@@ -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 = ""