Implement buildPackageData rule.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 20 Apr 2015 00:25:09 +0000 (01:25 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 20 Apr 2015 00:25:09 +0000 (01:25 +0100)
19 files changed:
src/Base.hs
src/Expression/Args.hs [new file with mode: 0644]
src/Expression/Base.hs
src/Expression/Build.hs
src/Expression/PG.hs
src/Expression/Project.hs [new file with mode: 0644]
src/Expression/Resolve.hs
src/Expression/Simplify.hs
src/Main.hs
src/Oracles/Builder.hs
src/Oracles/PackageData.hs
src/Package.hs
src/PackageBuild.hs [deleted file]
src/Rules.hs [new file with mode: 0644]
src/Rules/Data.hs [new file with mode: 0644]
src/Rules/Package.hs [new file with mode: 0644]
src/Settings.hs
src/Switches.hs [new file with mode: 0644]
src/Targets.hs

index 49b0fb2..2bd350f 100644 (file)
@@ -8,6 +8,7 @@ module Base (
     module Data.Monoid,
     module Data.List,
     Stage (..),
+    TargetDir (..),
     Arg, Args,
     ShowArg (..), ShowArgs (..),
     arg, args,
@@ -28,6 +29,9 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum)
 instance Show Stage where
     show = show . fromEnum
 
+-- Need TargetDir and FilePath to be distinct types
+newtype TargetDir = TargetDir { fromTargetDir :: FilePath } deriving (Show, Eq)
+
 -- The returned string or list of strings is a part of an argument list
 -- to be passed to a Builder
 type Arg  = Action String
diff --git a/src/Expression/Args.hs b/src/Expression/Args.hs
new file mode 100644 (file)
index 0000000..817c946
--- /dev/null
@@ -0,0 +1,179 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Expression.Args (
+    Args (..), BuildParameter (..), EnvironmentParameter (..),
+    Arity (..), Combine (..),
+    Settings,
+    arg, args, argPath, argsOrdered, argBuildPath, argBuildDir,
+    argInput, argOutput,
+    argConfig, argStagedConfig, argConfigList, argStagedConfigList,
+    argBuilderPath, argStagedBuilderPath,
+    argWithBuilder, argWithStagedBuilder,
+    argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
+    argIncludeDirs, argDepIncludeDirs,
+    argConcat, argConcatPath, argConcatSpace,
+    argPairs, argPrefix, argPrefixPath,
+    argPackageConstraints
+    ) where
+
+import Base hiding (arg, args, Args)
+import Util
+import Oracles.Builder
+import Expression.Build
+
+-- Settings comprise the following primitive elements
+data Args
+    = Plain String                              -- e.g. "-O2"
+    | BuildParameter BuildParameter             -- e.g. build path
+    | EnvironmentParameter EnvironmentParameter -- e.g. host OS
+    | Fold Combine Settings                     -- e.g. ccSettings
+    deriving (Show, Eq)
+
+-- Build parameters to be determined during the build process
+data BuildParameter
+    = PackagePath -- path to the current package, e.g. "libraries/deepseq"
+    | BuildDir    -- build directory, e.g. "dist-install"
+    | Input       -- input file(s), e.g. "src.hs"
+    | Output      -- output file(s), e.g. ["src.o", "src.hi"]
+    deriving (Show, Eq)
+
+-- Environment parameters to be determined using oracles
+data EnvironmentParameter
+    = BuilderPath Builder                -- look up path to a Builder
+    | Config Arity String                -- look up configuration flag(s)
+    | PackageData                        -- look up package-data.mk flag(s)
+      {
+        pdArity       :: Arity,          -- arity of value (Single or Multiple)
+        pdKey         :: String,         -- key to look up, e.g. "PACKAGE_KEY"
+        pdPackagePath :: Maybe FilePath, -- path to the current package
+        pdBuildDir    :: Maybe FilePath  -- build directory
+      }
+    | PackageConstraints Packages        -- package version constraints
+    deriving (Show, Eq)
+
+-- Method for combining settings elements in Fold Combine Settings
+data Combine = Id            -- Keep given settings as is
+             | Concat        -- Concatenate: a ++ b
+             | ConcatPath    -- </>-concatenate: a </> b
+             | ConcatSpace   -- concatenate with a space: a ++ " " ++ b
+             deriving (Show, Eq)
+
+data Arity = Single   -- expands to a single argument
+           | Multiple -- expands to a list of arguments
+           deriving (Show, Eq)
+
+type Settings = BuildExpression Args
+
+-- A single argument
+arg :: String -> Settings
+arg = return . Plain
+
+-- A single FilePath argument
+argPath :: FilePath -> Settings
+argPath = return . Plain . unifyPath
+
+-- A set of arguments (unordered)
+args :: [String] -> Settings
+args = msum . map arg
+
+-- An (ordered) list of arguments
+argsOrdered :: [String] -> Settings
+argsOrdered = mproduct . map arg
+
+argBuildPath :: Settings
+argBuildPath = return $ BuildParameter $ PackagePath
+
+argBuildDir :: Settings
+argBuildDir = return $ BuildParameter $ BuildDir
+
+argInput :: Settings
+argInput = return $ BuildParameter $ Input
+
+argOutput :: Settings
+argOutput = return $ BuildParameter $ Output
+
+argConfig :: String -> Settings
+argConfig = return . EnvironmentParameter . Config Single
+
+argConfigList :: String -> Settings
+argConfigList = return . EnvironmentParameter . Config Multiple
+
+stagedKey :: Stage -> String -> String
+stagedKey stage key = key ++ "-stage" ++ show stage
+
+argStagedConfig :: String -> Settings
+argStagedConfig key =
+    msum $ map (\s -> stage s ? argConfig (stagedKey s key)) [Stage0 ..]
+
+argStagedConfigList :: String -> Settings
+argStagedConfigList key =
+    msum $ map (\s -> stage s ? argConfigList (stagedKey s key)) [Stage0 ..]
+
+-- evaluates to the path to a given builder
+argBuilderPath :: Builder -> Settings
+argBuilderPath = return . EnvironmentParameter . BuilderPath
+
+-- as above but takes current stage into account
+argStagedBuilderPath :: (Stage -> Builder) -> Settings
+argStagedBuilderPath f =
+    msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
+
+-- evaluates to 'with-builder=path/to/builder' for a given builder
+argWithBuilder :: Builder -> Settings
+argWithBuilder builder =
+    argPrefix (withBuilderKey builder) (argBuilderPath builder)
+
+-- as above but takes current stage into account
+argWithStagedBuilder :: (Stage -> Builder) -> Settings
+argWithStagedBuilder f =
+    msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]
+
+packageData :: Arity -> String -> Settings
+packageData arity key =
+    return $ EnvironmentParameter $ PackageData arity key Nothing Nothing
+
+-- Accessing key value pairs from package-data.mk files
+argPackageKey :: Settings
+argPackageKey = packageData Single "PACKAGE_KEY"
+
+argPackageDeps :: Settings
+argPackageDeps = packageData Multiple "DEPS"
+
+argPackageDepKeys :: Settings
+argPackageDepKeys = packageData Multiple "DEP_KEYS"
+
+argSrcDirs :: Settings
+argSrcDirs = packageData Multiple "HS_SRC_DIRS"
+
+argIncludeDirs :: Settings
+argIncludeDirs = packageData Multiple "INCLUDE_DIRS"
+
+argDepIncludeDirs :: Settings
+argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
+
+argPackageConstraints :: Packages -> Settings
+argPackageConstraints = return . EnvironmentParameter . PackageConstraints
+
+-- Concatenate arguments: arg1 ++ arg2 ++ ...
+argConcat :: Settings -> Settings
+argConcat = return . Fold Concat
+
+-- </>-concatenate arguments: arg1 </> arg2 </> ...
+argConcatPath :: Settings -> Settings
+argConcatPath = return . Fold ConcatPath
+
+-- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
+argConcatSpace :: Settings -> Settings
+argConcatSpace = return . Fold ConcatSpace
+
+-- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
+argPairs :: String -> Settings -> Settings
+argPairs prefix settings = settings >>= (arg prefix |>) . return
+
+-- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
+argPrefix :: String -> Settings -> Settings
+argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
+
+-- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
+argPrefixPath :: String -> Settings -> Settings
+argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
index b14175a..17bbe9d 100644 (file)
 {-# LANGUAGE FlexibleInstances #-}
 
 module Expression.Base (
+    module Expression.Args,
     module Expression.Build,
+    module Expression.Project,
+    module Expression.Resolve,
+    module Expression.Simplify,
     module Expression.Predicate,
-    (?), (??), whenExists,
-    Args (..), -- TODO: hide?
-    Combine (..), -- TODO: hide?
-    Settings,
-    Packages,
-    FilePaths,
-    Ways,
-    project,
-    arg, args, argPath, argsOrdered, argBuildPath, argBuildDir,
-    argInput, argOutput,
-    argConfig, argStagedConfig, argConfigList, argStagedConfigList,
-    argBuilderPath, argStagedBuilderPath,
-    argWithBuilder, argWithStagedBuilder,
-    argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
-    argIncludeDirs, argDepIncludeDirs,
-    argConcat, argConcatPath, argConcatSpace,
-    argPairs, argPrefix, argPrefixPath,
-    argBootPkgConstraints,
-    setPackage, setBuilder, setBuilderFamily, setStage, setWay,
-    setFile, setConfig
+    module Control.Applicative,
     ) where
 
-import Base hiding (arg, args, Args)
-import Ways
-import Util
-import Package (Package)
-import Oracles.Builder
-import Expression.PG
+import Base
+import Expression.Args
+    hiding ( Args, BuildParameter, EnvironmentParameter, Arity, Combine )
+import Expression.Build hiding (BuildVariable)
 import Expression.Predicate
-import Expression.Build
-
--- Settings can be built out of the following primitive elements
-data Args
-    = Plain String           -- a plain old string argument: e.g., "-O2"
-    | BuildPath              -- evaluates to build path: "libraries/base"
-    | BuildDir               -- evaluates to build directory: "dist-install"
-    | Input                  -- evaluates to input file(s): "src.c"
-    | Output                 -- evaluates to output file(s): "src.o"
-    | Config String          -- evaluates to the value of a given config key
-    | ConfigList String      -- as above, but evaluates to a list of values
-    | BuilderPath Builder    -- evaluates to the path to a given builder
-    | PackageData String     -- looks up value a given key in package-data.mk
-    | PackageDataList String -- as above, but evaluates to a list of values
-    | BootPkgConstraints     -- evaluates to boot package constraints
-    | Fold Combine Settings  -- fold settings using a given combine method
-
-data Combine = Id            -- Keep given settings as is
-             | Concat        -- Concatenate: a ++ b
-             | ConcatPath    -- </>-concatenate: a </> b
-             | ConcatSpace   -- concatenate with a space: a ++ " " ++ b
-
-type Ways      = BuildExpression Way
-type Settings  = BuildExpression Args
-type Packages  = BuildExpression Package
-type FilePaths = BuildExpression FilePath
-
--- A single argument
-arg :: String -> Settings
-arg = return . Plain
-
--- A single FilePath argument
-argPath :: FilePath -> Settings
-argPath = return . Plain . unifyPath
-
--- A set of arguments (unordered)
-args :: [String] -> Settings
-args = msum . map arg
-
--- An (ordered) list of arguments
-argsOrdered :: [String] -> Settings
-argsOrdered = mproduct . map arg
-
-argBuildPath :: Settings
-argBuildPath = return BuildPath
-
-argBuildDir :: Settings
-argBuildDir = return BuildDir
-
-argInput :: Settings
-argInput = return Input
-
-argOutput :: Settings
-argOutput = return Output
-
-argConfig :: String -> Settings
-argConfig = return . Config
-
-argConfigList :: String -> Settings
-argConfigList = return . ConfigList
-
-argStagedConfig :: String -> Settings
-argStagedConfig key =
-    msum $ map (\s -> stage s ? argConfig (stagedKey s)) [Stage0 ..]
-  where
-    stagedKey :: Stage -> String
-    stagedKey stage = key ++ "-stage" ++ show stage
-
-argStagedConfigList :: String -> Settings
-argStagedConfigList key =
-    msum $ map (\s -> stage s ? argConfigList (stagedKey s)) [Stage0 ..]
-  where
-    stagedKey :: Stage -> String
-    stagedKey stage = key ++ "-stage" ++ show stage
-
-argBuilderPath :: Builder -> Settings
-argBuilderPath = return . BuilderPath
-
--- evaluates to the path to a given builder, taking current stage into account
-argStagedBuilderPath :: (Stage -> Builder) -> Settings
-argStagedBuilderPath f =
-    msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
-
-argWithBuilder :: Builder -> Settings
-argWithBuilder builder =
-    let key = case builder of
-            Ar       -> "--with-ar="
-            Ld       -> "--with-ld="
-            Gcc _    -> "--with-gcc="
-            Ghc _    -> "--with-ghc="
-            Alex     -> "--with-alex="
-            Happy    -> "--with-happy="
-            GhcPkg _ -> "--with-ghc-pkg="
-            HsColour -> "--with-hscolour="
-    in
-    argPrefix key (argBuilderPath builder)
-
-argWithStagedBuilder :: (Stage -> Builder) -> Settings
-argWithStagedBuilder f =
-    msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]
-
--- Accessing key value pairs from package-data.mk files
-argPackageKey :: Settings
-argPackageKey = return $ PackageData "PACKAGE_KEY"
-
-argPackageDeps :: Settings
-argPackageDeps = return $ PackageDataList "DEPS"
-
-argPackageDepKeys :: Settings
-argPackageDepKeys = return $ PackageDataList "DEP_KEYS"
-
-argSrcDirs :: Settings
-argSrcDirs = return $ PackageDataList "HS_SRC_DIRS"
-
-argIncludeDirs :: Settings
-argIncludeDirs = return $ PackageDataList "INCLUDE_DIRS"
-
-argDepIncludeDirs :: Settings
-argDepIncludeDirs = return $ PackageDataList "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
-
-argBootPkgConstraints :: Settings
-argBootPkgConstraints = return BootPkgConstraints
-
--- Concatenate arguments: arg1 ++ arg2 ++ ...
-argConcat :: Settings -> Settings
-argConcat = return . Fold Concat
-
--- </>-concatenate arguments: arg1 </> arg2 </> ...
-argConcatPath :: Settings -> Settings
-argConcatPath = return . Fold ConcatPath
-
--- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
-argConcatSpace :: Settings -> Settings
-argConcatSpace = return . Fold ConcatSpace
-
--- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
-argPairs :: String -> Settings -> Settings
-argPairs prefix settings = settings >>= (arg prefix |>) . return
-
--- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
-argPrefix :: String -> Settings -> Settings
-argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
-
--- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
-argPrefixPath :: String -> Settings -> Settings
-argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
-
--- Partially evaluate expression using a truth-teller (compute a 'projection')
-project :: (BuildVariable -> Maybe Bool) -> BuildExpression v
-                                         -> BuildExpression v
-project _ Epsilon = Epsilon
-project t (Vertex v) = Vertex v -- TODO: go deeper
-project t (Overlay   l r) = Overlay   (project  t l) (project t r)
-project t (Sequence  l r) = Sequence  (project  t l) (project t r)
-project t (Condition l r) = Condition (evaluate t l) (project t r)
-
--- Partial evaluation of setting
-setPackage :: Package -> BuildExpression v -> BuildExpression v
-setPackage = project . matchPackage
-
-setBuilder :: Builder -> BuildExpression v -> BuildExpression v
-setBuilder = project . matchBuilder
-
-setBuilderFamily :: (Stage -> Builder) -> BuildExpression v
-                                       -> BuildExpression v
-setBuilderFamily = project . matchBuilderFamily
-
-setStage :: Stage -> BuildExpression v -> BuildExpression v
-setStage = project . matchStage
-
-setWay :: Way -> BuildExpression v -> BuildExpression v
-setWay = project . matchWay
-
-setFile :: FilePath -> BuildExpression v -> BuildExpression v
-setFile = project . matchFile
-
-setConfig :: String -> String -> BuildExpression v -> BuildExpression v
-setConfig key = project . matchConfig key
-
---type ArgsTeller = Args -> Maybe [String]
-
---fromPlain :: ArgsTeller
---fromPlain (Plain list) = Just list
---fromPlain _            = Nothing
-
---tellArgs :: ArgsTeller -> Args -> Args
---tellArgs t a = case t a of
---    Just list -> Plain list
---    Nothing   -> a
+import Expression.Project
+import Expression.Resolve
+import Expression.Simplify
+import Control.Applicative
index 8a7372d..507d90c 100644 (file)
@@ -3,22 +3,17 @@
 module Expression.Build (
     BuildVariable (..),
     BuildPredicate (..),
-    BuildExpression (..),
-    evaluate, simplify, tellTruth,
-    linearise, (|>), msum, mproduct, fromList, fromOrderedList,
-    packages, package, matchPackage,
-    builders, builder, matchBuilder, matchBuilderFamily,
-    stages, stage, notStage, matchStage,
-    ways, way, matchWay,
-    files, file, matchFile,
-    configValues, config, configYes, configNo, configNonEmpty, matchConfig,
-    supportsPackageKey, targetPlatforms, targetPlatform,
-    targetOss, targetOs, targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
-    platformSupportsSharedLibs, crossCompiling,
-    gccIsClang, gccLt46, windowsHost
+    BuildExpression,
+    Ways, Packages, TargetDirs,
+    (?), (??), whenExists, support,
+    (|>), msum, mproduct, fromList, fromOrderedList,
+    packages, package,
+    builders, builder, stagedBuilder,
+    stages, stage, notStage,
+    ways, way, files, file,
+    configValues, config, configYes, configNo, configNonEmpty
     ) where
 
-import Control.Applicative
 import Base
 import Ways
 import Oracles.Builder
@@ -69,65 +64,9 @@ alternatives f = foldr (||) false . map (variable . f)
 
 type BuildExpression v = PG BuildPredicate v
 
--- Partially evaluate a BuildPredicate with a truth-teller function
--- that takes a BuildVariable and returns a Maybe Bool, where Nothing
--- is returned if the argument cannot be evaluated.
-evaluate :: (BuildVariable -> Maybe Bool) -> BuildPredicate -> BuildPredicate
-evaluate _ p @ (Evaluated _) = p
-evaluate t p @ (Unevaluated q) = case t q of
-    Just bool -> Evaluated bool
-    Nothing   -> p
-evaluate t (Not p  ) = Not (evaluate t p)
-evaluate t (And p q) = And (evaluate t p) (evaluate t q)
-evaluate t (Or  p q) = Or  (evaluate t p) (evaluate t q)
-
--- Attempt to fully evaluate a predicate (a truth-teller function!). Returns
--- Nothing if the predicate cannot be evaluated due to remaining unevaluated
--- variables.
-tellTruth :: BuildPredicate -> Maybe Bool
-tellTruth p = case simplify p of
-    Evaluated bool -> Just bool
-    _              -> Nothing
-
--- Simplify the predicate by constant propagation
-instance Simplify BuildPredicate where
-    simplify p @ (Evaluated _) = p
-    simplify p @ (Unevaluated _) = p
-    simplify (Not p) = case p' of
-        Evaluated bool -> Evaluated (not bool)
-        _              -> Not p'
-      where p' = simplify p
-    simplify (And p q)
-        | p' == false = false
-        | q' == false = false
-        | p' == true  = q'
-        | q' == true  = p'
-        | otherwise   = And p' q'
-      where
-        p' = simplify p
-        q' = simplify q
-    simplify (Or p q)
-        | p' == true  = true
-        | q' == true  = true
-        | p' == false = q'
-        | q' == false = p'
-        | otherwise   = Or p' q'
-      where
-        p' = simplify p
-        q' = simplify q
-
--- Linearise a build expression into a list. Returns Nothing if the given
--- expression cannot be uniquely evaluated due to remaining variables.
--- Overlay subexpressions are linearised in arbitrary order.
-linearise :: BuildExpression v -> Maybe [v]
-linearise Epsilon         = Just []
-linearise (Vertex v)      = Just [v]
-linearise (Overlay   p q) = (++) <$> linearise p <*> linearise q -- TODO: union
-linearise (Sequence  p q) = (++) <$> linearise p <*> linearise q
-linearise (Condition x q) = case tellTruth x of
-    Just True  -> linearise q
-    Just False -> Just []
-    Nothing    -> Nothing
+type Ways       = BuildExpression Way
+type Packages   = BuildExpression Package
+type TargetDirs = BuildExpression TargetDir
 
 -- Basic GHC build predicates
 packages :: [Package] -> BuildPredicate
@@ -154,6 +93,9 @@ package p = packages [p]
 builder :: Builder -> BuildPredicate
 builder b = builders [b]
 
+stagedBuilder :: (Stage -> Builder) -> BuildPredicate
+stagedBuilder s2b = builders $ map s2b [Stage0 ..]
+
 stage :: Stage -> BuildPredicate
 stage s = stages [s]
 
@@ -177,89 +119,3 @@ configNo key = configValues key ["NO" ]
 
 configNonEmpty :: String -> BuildPredicate
 configNonEmpty key = not $ configValues key [""]
-
--- Truth-tellers for partial evaluation
-
-matchPackage :: Package -> BuildVariable -> Maybe Bool
-matchPackage p (PackageVariable p') = Just $ p == p'
-matchPackage _ _                    = Nothing
-
-matchBuilder :: Builder -> BuildVariable -> Maybe Bool
-matchBuilder b (BuilderVariable b') = Just $ b == b'
-matchBuilder _ _                    = Nothing
-
-matchBuilderFamily :: (Stage -> Builder) -> BuildVariable -> Maybe Bool
-matchBuilderFamily f (BuilderVariable b) = Just $ b `elem` map f [Stage0 ..]
-matchBuilderFamily _ _                   = Nothing
-
-matchStage :: Stage -> BuildVariable -> Maybe Bool
-matchStage s (StageVariable s') = Just $ s == s'
-matchStage _ _                  = Nothing
-
-matchWay :: Way -> BuildVariable -> Maybe Bool
-matchWay w (WayVariable w') = Just $ w == w'
-matchWay _ _                = Nothing
-
-matchFile :: FilePath -> BuildVariable -> Maybe Bool
-matchFile file (FileVariable pattern) = Just $ pattern ?== file
-matchFile _ _                     = Nothing
-
-matchConfig :: String -> String -> BuildVariable -> Maybe Bool
-matchConfig key value (ConfigVariable key' value')
-    | key == key'   = Just $ value == value'
-    | otherwise     = Nothing
-matchKeyValue _ _ _ = Nothing
-
--- Derived predicates
-
-supportsPackageKey :: BuildPredicate
-supportsPackageKey = configYes "supports-package-key"
-
-targetPlatforms :: [String] -> BuildPredicate
-targetPlatforms = configValues "target-platform-full"
-
-targetPlatform :: String -> BuildPredicate
-targetPlatform s = targetPlatforms [s]
-
-targetOss :: [String] -> BuildPredicate
-targetOss = configValues "target-os"
-
-targetOs :: String -> BuildPredicate
-targetOs s = targetOss [s]
-
-targetArchs :: [String] -> BuildPredicate
-targetArchs = configValues "target-arch"
-
-solarisBrokenShld :: BuildPredicate
-solarisBrokenShld = configYes "solaris-broken-shld"
-
-platformSupportsSharedLibs :: BuildPredicate
-platformSupportsSharedLibs =
-    not (targetPlatforms [ "powerpc-unknown-linux"
-                         , "x86_64-unknown-mingw32"
-                         , "i386-unknown-mingw32" ]
-        ||
-        solarisBrokenShld && targetPlatform "i386-unknown-solaris2")
-
-dynamicGhcPrograms :: BuildPredicate
-dynamicGhcPrograms = configYes "dynamic-ghc-programs"
-
-ghcWithInterpreter :: BuildPredicate
-ghcWithInterpreter =
-    targetOss [ "mingw32", "cygwin32", "linux", "solaris2"
-              , "freebsd", "dragonfly", "netbsd", "openbsd"
-              , "darwin", "kfreebsdgnu" ]
-    &&
-    targetArchs ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
-
-crossCompiling :: BuildPredicate
-crossCompiling = configYes "cross-compiling"
-
-gccIsClang :: BuildPredicate
-gccIsClang = configYes "gcc-is-clang"
-
-gccLt46 :: BuildPredicate
-gccLt46 = configYes "gcc-lt-46"
-
-windowsHost :: BuildPredicate
-windowsHost = configValues "host-os-cpp" ["mingw32", "cygwin32"]
index 4c5015e..7241915 100644 (file)
@@ -1,15 +1,13 @@
 {-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
 
 module Expression.PG (
-    module Expression.Simplify,
     module Expression.Predicate,
     PG (..),
-    (|>), (?), (??), whenExists,
+    bimap, (|>), (?), (??), whenExists, support,
     msum, mproduct,
     fromList, fromOrderedList
     ) where
 
-import Expression.Simplify
 import Data.Functor
 import Control.Monad
 import Control.Applicative
@@ -28,6 +26,13 @@ data PG p v = Epsilon
 instance Functor (PG p) where
     fmap = liftM
 
+bimap :: (p -> q) -> (v -> w) -> PG p v -> PG q w
+bimap _ _ Epsilon = Epsilon
+bimap f g (Vertex      v) = Vertex    (g v)
+bimap f g (Overlay   l r) = Overlay   (bimap f g l) (bimap f g r)
+bimap f g (Sequence  l r) = Sequence  (bimap f g l) (bimap f g r)
+bimap f g (Condition l r) = Condition (f l)         (bimap f g r)
+
 instance Applicative (PG p) where
     pure = return
     (<*>) = ap
@@ -82,13 +87,20 @@ whenExists a (Overlay   l r) = whenExists a l || whenExists a r
 whenExists a (Sequence  l r) = whenExists a l || whenExists a r
 whenExists a (Condition x r) = x              && whenExists a r
 
--- Map over all PG predicates, e.g., partially evaluate a given PG.
---mapP :: (p -> p) -> PG p v -> PG p v
---mapP _ Epsilon         = Epsilon
---mapP _ v @ (Vertex _)  = v
---mapP f (Overlay   l r) = Overlay   (mapP f l) (mapP f r)
---mapP f (Sequence  l r) = Sequence  (mapP f l) (mapP f r)
---mapP f (Condition x r) = Condition (f x     ) (mapP f r)
+support :: Ord v => PG p v -> [v]
+support Epsilon         = []
+support (Vertex      v) = [v]
+support (Overlay   l r) = support l `union` support r
+support (Sequence  l r) = support l `union` support r
+support (Condition _ r) = support r
+
+union :: Ord v => [v] -> [v] -> [v]
+union ls     []     = ls
+union []     rs     = rs
+union (l:ls) (r:rs) = case compare l r of
+    LT -> l : union ls (r:rs)
+    EQ -> l : union ls rs
+    GT -> r : union (l:ls) rs
 
 instance (Show p, Show v) => Show (PG p v) where
     showsPrec _ Epsilon       = showString "()"
@@ -102,32 +114,3 @@ instance (Show p, Show v) => Show (PG p v) where
 
     showsPrec d (Condition l r) =
         showChar '[' . shows l . showChar ']' . showsPrec 2 r
-
-instance (Simplify p, Predicate p, Eq p, Eq v) => Simplify (PG p v) where
-    simplify Epsilon = Epsilon
-    simplify v @ (Vertex _) = v
-    simplify (Overlay l r)
-        | l' == Epsilon = r'
-        | r' == Epsilon = l'
-        | l' == r'      = l'
-        | otherwise     = Overlay l' r'
-      where
-        l' = simplify l
-        r' = simplify r
-    simplify (Sequence l r)
-        | l' == Epsilon = r'
-        | r' == Epsilon = l'
-        | otherwise     = Sequence l' r'
-      where
-        l' = simplify l
-        r' = simplify r
-    simplify (Condition l r)
-        | l' == true    = r'
-        | l' == false   = Epsilon
-        | r' == Epsilon = Epsilon
-        | otherwise     = Condition l' r'
-      where
-        l' = simplify l
-        r' = simplify r
-
-
diff --git a/src/Expression/Project.hs b/src/Expression/Project.hs
new file mode 100644 (file)
index 0000000..c19a195
--- /dev/null
@@ -0,0 +1,133 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+
+module Expression.Project (
+    Project (..)
+    ) where
+
+import Base hiding (Args)
+import Package
+import Ways
+import Oracles.Builder
+import Expression.PG
+import Expression.Args
+import Expression.Build
+
+class Project a b where
+    project :: a -> b -> b
+    project = const id
+
+-- Project recursively through Not, And and Or
+pmap :: Project a BuildPredicate => a -> BuildPredicate -> BuildPredicate
+pmap a (Not p  ) = Not (project a p)
+pmap a (And p q) = And (project a p) (project a q)
+pmap a (Or  p q) = Or  (project a p) (project a q)
+pmap _ p         = p
+
+instance Project Package BuildPredicate where
+    project pkg (Unevaluated (PackageVariable pkg')) = Evaluated $ pkg == pkg'
+    project pkg p = pmap pkg p
+
+instance Project Builder BuildPredicate where
+    project b (Unevaluated (BuilderVariable b')) = Evaluated $ b == b'
+    project b p = pmap b p
+
+instance Project (Stage -> Builder) BuildPredicate where
+    project s2b (Unevaluated (BuilderVariable b)) =
+        Evaluated $ b `elem` map s2b [Stage0 ..]
+    project s2b p = pmap s2b p
+
+instance Project Way BuildPredicate where
+    project w (Unevaluated (WayVariable w')) = Evaluated $ w == w'
+    project w p = pmap w p
+
+instance Project Stage BuildPredicate where
+    project s (Unevaluated (StageVariable s')) = Evaluated $ s == s'
+    project s p = pmap s p
+
+instance Project FilePath BuildPredicate where
+    project f (Unevaluated (FileVariable p)) = Evaluated $ p ?== f
+    project f p = pmap f p
+
+-- TargetDirs do not appear in build predicates
+instance Project TargetDir BuildPredicate where
+
+-- Nothing to project in expressions containing FilePaths, Packages or Ways
+instance Project a TargetDir where
+instance Project a Package where
+instance Project a Way where
+
+-- Projecting on Way, Stage, Builder, FilePath and staged Builder is trivial:
+-- only (Fold Combine Settings) and (EnvironmentParameter PackageConstraints)
+-- can be affected (more specifically, the predicates contained in them).
+-- This is handled with 'amap'.
+amap :: (Project a Settings, Project a Packages) => a -> Args -> Args
+amap p (Fold combine settings) = Fold combine (project p settings)
+amap p (EnvironmentParameter (PackageConstraints ps)) =
+    EnvironmentParameter $ PackageConstraints $ project p ps
+amap _ a = a
+
+instance Project Way Args where
+    project = amap
+
+instance Project Stage Args where
+    project = amap
+
+instance Project Builder Args where
+    project = amap
+
+instance Project FilePath Args where
+    project = amap
+
+instance Project (Stage -> Builder) Args where
+    project = amap
+
+-- Projecting on Package and TargetDir is more interesting.
+instance Project Package Args where
+    project p (BuildParameter PackagePath) = Plain $ pkgPath p
+    project p (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
+        EnvironmentParameter $ pd { pdPackagePath = Just $ pkgPath p }
+    project p a = amap p a
+
+instance Project TargetDir Args where
+    project (TargetDir d) (BuildParameter BuildDir) = Plain d
+    project (TargetDir d) (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
+        EnvironmentParameter $ pd { pdBuildDir = Just d }
+    project d a = amap d a
+
+-- Projecting a build expression requires examining all predicates and vertices
+instance (Project Package v, Project Package BuildPredicate)
+    => Project Package (BuildExpression v) where
+    project p = bimap (project p) (project p)
+
+instance (Project Builder v, Project Builder BuildPredicate)
+    => Project Builder (BuildExpression v) where
+    project b = bimap (project b) (project b)
+
+instance (Project (Stage -> Builder) v,
+    Project (Stage -> Builder) BuildPredicate)
+    => Project (Stage -> Builder) (BuildExpression v) where
+    project s2b = bimap (project s2b) (project s2b)
+
+instance (Project Stage v, Project Stage BuildPredicate)
+    => Project Stage (BuildExpression v) where
+    project s = bimap (project s) (project s)
+
+instance (Project TargetDir v, Project TargetDir BuildPredicate)
+    => Project TargetDir (BuildExpression v) where
+    project d = bimap (project d) (project d)
+
+instance (Project Way v, Project Way BuildPredicate)
+    => Project Way (BuildExpression v) where
+    project w = bimap (project w) (project w)
+
+instance (Project FilePath v, Project FilePath BuildPredicate)
+    => Project FilePath (BuildExpression v) where
+    project f = bimap (project f) (project f)
+
+-- Composing projections
+instance (Project a z, Project b z) => Project (a, b) z where
+    project (p, q) = project p . project q
+
+instance (Project a z, Project b z, Project c z) => Project (a, b, c) z where
+    project (p, q, r) = project p . project q . project r
+
index 2d283b2..55205b6 100644 (file)
@@ -1,57 +1,75 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
 
 module Expression.Resolve (
-    Resolve (..)
+    Resolve (..), evaluate
     ) where
 
-import Base hiding (Args)
+import Base hiding (Args, arg)
 import Package
 import Ways
 import Util
+import Control.Monad
+import Expression.Simplify
 import Oracles.Base
+import Oracles.PackageData
 import Expression.PG
-import Expression.Base
+import Expression.Args
+import Expression.Build
 
 -- Resolve unevaluated variables by calling the associated oracles
 class Resolve a where
     resolve :: a -> Action a
     resolve = return . id
 
+evaluate :: (Simplify a, Resolve a) => a -> Action a
+evaluate = resolve . simplify
+
 -- Nothing to resolve for expressions containing FilePaths, Packages or Ways
-instance Resolve FilePath where
+instance Resolve TargetDir where
 instance Resolve Package where
 instance Resolve Way where
 
---data Args
---    = Plain String           -- a plain old string argument: e.g., "-O2"
---    | BuildPath              -- evaluates to build path: "libraries/base"
---    | BuildDir               -- evaluates to build directory: "dist-install"
---    | Input                  -- evaluates to input file(s): "src.c"
---    | Output                 -- evaluates to output file(s): "src.o"
---    | Config String          -- evaluates to the value of a given config key
---    | ConfigList String
---    | BuilderPath Builder    -- evaluates to the path to a given builder
---    | PackageData String     -- looks up value a given key in package-data.mk
---    | PackageDataList String
---    | BootPkgConstraints     -- evaluates to boot package constraints
---    | Fold Combine Settings  -- fold settings using a given combine method
-
 instance Resolve Args where
-    resolve (Config key) = do
+    resolve (EnvironmentParameter (Config Single key)) = do
         value <- askConfig key
         return $ Plain value
 
-    resolve (ConfigList key) = do
+    resolve (EnvironmentParameter (Config Multiple key)) = do
         values <- words <$> askConfig key
-        return $ Fold Id $ argsOrdered values
+        return $ Fold Id $ argsOrdered values -- TODO: dedup 'Fold Id'
+
+    resolve (EnvironmentParameter (BuilderPath builder)) = do
+        value <- showArg builder
+        return $ Plain value
 
-    resolve (BuilderPath builder) = do
-        path <- showArg builder
-        return $ Plain $ unifyPath path
+    resolve a @ (EnvironmentParameter (PackageData _ _ Nothing _)) = return a
+    resolve a @ (EnvironmentParameter (PackageData _ _ _ Nothing)) = return a
 
-    --resolve (PackageData key) = ...
-    --resolve (PackageDataList key) = ...
-    --resolve (BootPkgConstraints) = ...
+    resolve (EnvironmentParameter
+            (PackageData Single key (Just path) (Just dir))) = do
+        value <- askPackageData (path </> dir) key
+        return $ Plain value
+
+    resolve (EnvironmentParameter
+            (PackageData Multiple key (Just path) (Just dir))) = do
+        values <- words <$> askPackageData (path </> dir) key
+        return $ Fold Id $ argsOrdered values
+
+    resolve (EnvironmentParameter (PackageConstraints pkgs)) = do
+        pkgs' <- evaluate $ pkgs
+        constraints <- case linearise pkgs' of
+            Nothing      -> redError "Cannot determine boot packages."
+            Just pkgList -> forM pkgList $ \pkg -> do
+                let cabal  = pkgPath pkg </> pkgCabal pkg
+                    prefix = dropExtension (pkgCabal pkg) ++ " == "
+                need [cabal]
+                content <- lines <$> liftIO (readFile cabal)
+                let vs = filter (("ersion:" `isPrefixOf`) . drop 1) content
+                case vs of
+                    [v] -> return $ arg (prefix ++ dropWhile (not . isDigit) v)
+                    _   -> redError $ "Cannot determine package version in '"
+                                    ++ cabal ++ "'."
+        return $ Fold Id (argPairs "--constraint" $ msum constraints)
 
     resolve (Fold op settings) = do
         settings' <- resolve settings
@@ -59,7 +77,6 @@ instance Resolve Args where
 
     resolve a = return a
 
-
 instance Resolve BuildPredicate where
     resolve p @ (Evaluated _) = return p
 
index 9d766f3..af7c73b 100644 (file)
@@ -1,6 +1,123 @@
+{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, FlexibleInstances #-}
+
 module Expression.Simplify (
-    Simplify (..)
+    Simplify (..), linearise, fromSettings,
     ) where
 
+import Base hiding (Args)
+import Ways
+import Package
+import Expression.PG
+import Expression.Args
+import Expression.Build
+
+-- Simplify expressions by constant propagation
 class Simplify a where
     simplify :: a -> a
+    simplify = id
+
+-- Linearise a build expression into a list. Returns Nothing if the given
+-- expression cannot be uniquely evaluated due to remaining variables.
+-- Overlay subexpressions are linearised in arbitrary order.
+linearise :: (Predicate p, Simplify (PG p v)) => PG p v -> Maybe [v]
+linearise = go . simplify
+  where
+    go Epsilon         = Just []
+    go (Vertex v)      = Just [v]
+    go (Overlay   p q) = (++) <$> go p <*> go q -- TODO: union
+    go (Sequence  p q) = (++) <$> go p <*> go q
+    go (Condition _ _) = Nothing
+
+fromArgs :: Args -> BuildExpression (Maybe [String])
+fromArgs (Plain s) = return $ Just [s]
+fromArgs (Fold Id          s) = return    $                     fromSettings s
+fromArgs (Fold Concat      s) = singleton $ concat          <$> fromSettings s
+fromArgs (Fold ConcatPath  s) = singleton $ concatPath      <$> fromSettings s
+fromArgs (Fold ConcatSpace s) = singleton $ intercalate " " <$> fromSettings s
+fromArgs _ = return Nothing
+
+singleton :: Maybe String -> BuildExpression (Maybe [String])
+singleton (Just s) = return $ Just [s]
+singleton Nothing  = return Nothing
+
+concatPath :: [FilePath] -> FilePath
+concatPath [] = ""
+concatPath [f] = f
+concatPath (f : fs) = f </> concatPath fs
+
+fromSettings :: Settings -> Maybe [String]
+fromSettings settings = case linearise (settings >>= fromArgs) of
+    Just list -> concatMaybes list
+    Nothing   -> Nothing
+  where
+    concatMaybes :: [Maybe [a]] -> Maybe [a]
+    concatMaybes [] = Just []
+    concatMaybes (Just a : as) = case concatMaybes as of
+        Just rest -> Just $ a ++ rest
+        Nothing   -> Nothing
+    concatMaybes (Nothing : _) = Nothing
+
+instance Simplify BuildPredicate where
+    simplify p @ (Evaluated _) = p
+    simplify p @ (Unevaluated _) = p
+    simplify (Not p) = case p' of
+        Evaluated bool -> Evaluated (not bool)
+        _              -> Not p'
+      where p' = simplify p
+    simplify (And p q)
+        | p' == false = false
+        | q' == false = false
+        | p' == true  = q'
+        | q' == true  = p'
+        | otherwise   = And p' q'
+      where
+        p' = simplify p
+        q' = simplify q
+    simplify (Or p q)
+        | p' == true  = true
+        | q' == true  = true
+        | p' == false = q'
+        | q' == false = p'
+        | otherwise   = Or p' q'
+      where
+        p' = simplify p
+        q' = simplify q
+
+-- Nothing to simplify here
+instance Simplify Way where
+instance Simplify Package where
+instance Simplify TargetDir where
+instance Simplify (Maybe [String]) where
+
+-- Only Fold can be simplified in Args
+instance Simplify Args where
+    simplify (Fold combine settings) = Fold combine (simplify settings)
+    simplify a = a
+
+instance (Simplify p, Simplify v, Predicate p, Eq p, Eq v) => Simplify (PG p v)
+  where
+    simplify Epsilon = Epsilon
+    simplify (Vertex v) = Vertex $ simplify v
+    simplify (Overlay l r)
+        | l' == Epsilon = r'
+        | r' == Epsilon = l'
+        | l' == r'      = l'
+        | otherwise     = Overlay l' r'
+      where
+        l' = simplify l
+        r' = simplify r
+    simplify (Sequence l r)
+        | l' == Epsilon = r'
+        | r' == Epsilon = l'
+        | otherwise     = Sequence l' r'
+      where
+        l' = simplify l
+        r' = simplify r
+    simplify (Condition l r)
+        | l' == true    = r'
+        | l' == false   = Epsilon
+        | r' == Epsilon = Epsilon
+        | otherwise     = Condition l' r'
+      where
+        l' = simplify l
+        r' = simplify r
index e28f52c..c79746e 100644 (file)
@@ -1,65 +1,12 @@
 import Base
+import Rules
 import Config
 import Oracles
-import Package
-import Targets
-import Settings
-import Expression.Base
-import Expression.Simplify
-import Expression.Resolve
-import Util
-
-buildSettings = empty
-
-setBuildDir = undefined
-
-buildPackage :: Package -> Ways -> Settings -> Action ()
-buildPackage = undefined
 
 main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
-    oracleRules
-    autoconfRules
-    configureRules
-    --packageRules
-
-    action $ do
-        forM_ [Stage0 ..] $ \stage -> do
-            pkgs <- resolve $ setStage stage targetPackages
-            case linearise pkgs of
-                Nothing      -> redError "Cannot determine target packages."
-                Just pkgList ->
-                    forM_ pkgList $ \pkg -> do
-                        let eval = setPackage pkg . setStage stage
-                        dirs <- resolve $ eval targetDirectories
-                        case linearise dirs of
-                            Just [dir] -> do
-                                let eval' = setBuildDir dir . eval
-                                ways <- resolve $ eval' targetWays
-                                stgs <- resolve $ eval' buildSettings
-                                buildPackage pkg ways stgs
-                            _ -> redError "Cannot determine target directory."
-
-
-
-
-        --forM_ targetPackages $ \pkg @ (Package name path _ todo) -> do
-        --        forM_ todo $ \todoItem @ (stage, dist, settings) -> do
-
-        --            -- Want top .o and .a files for the pkg/todo combo
-        --            -- We build *only one* vanilla .o file (not sure why)
-        --            -- We build .way_a file for each way (or its dynamic version).
-        --            -- TODO: Check BUILD_GHCI_LIB flag to decide if .o is needed
-        --            -- TODO: move this into a separate file (perhaps, to Targets.hs?)
-        --            action $ when (buildWhen settings) $ do
-        --                let pathDist = path </> dist
-        --                    buildDir = pathDist </> "build"
-        --                key <- showArg (PackageKey pathDist)
-        --                let oFile = buildDir </> "Hs" ++ key <.> "o"
-        --                ways'  <- ways settings
-        --                libFiles <- forM ways' $ \way -> do
-        --                    extension <- libsuf way
-        --                    return $ buildDir </> "libHs" ++ key <.> extension
-        --                need $ [oFile] ++ libFiles
+    oracleRules     -- see module Oracles
+    packageRules    -- see module Rules
+    autoconfRules   -- see module Config
+    configureRules  -- see module Config
+    generateTargets -- see module Rules
 
-        --            -- Build rules for the package
-        --            buildPackage pkg todoItem
index 7dd3bfd..316217f 100644 (file)
@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Oracles.Builder (
-    Builder (..),
+    Builder (..), builderKey, withBuilderKey,
     with, run, verboseRun, specified
     ) where
 
@@ -32,25 +32,27 @@ data Builder = Ar
              | GhcPkg Stage
              deriving (Show, Eq)
 
+builderKey :: Builder -> String
+builderKey builder = case builder of
+    Ar            -> "ar"
+    Ld            -> "ld"
+    Alex          -> "alex"
+    Happy         -> "happy"
+    HsColour      -> "hscolour"
+    GhcCabal      -> "ghc-cabal"
+    Ghc Stage0    -> "system-ghc"
+    Ghc Stage1    -> "ghc-stage1"
+    Ghc Stage2    -> "ghc-stage2"
+    Ghc Stage3    -> "ghc-stage3"
+    Gcc Stage0    -> "system-gcc"
+    Gcc _         -> "gcc"
+    GhcPkg Stage0 -> "system-ghc-pkg"
+    GhcPkg _      -> "ghc-pkg"
+
 instance ShowArg Builder where
     showArg builder = toStandard <$> do
-        let key = case builder of
-                Ar            -> "ar"
-                Ld            -> "ld"
-                Alex          -> "alex"
-                Happy         -> "happy"
-                HsColour      -> "hscolour"
-                GhcCabal      -> "ghc-cabal"
-                Ghc Stage0    -> "system-ghc"
-                Ghc Stage1    -> "ghc-stage1"
-                Ghc Stage2    -> "ghc-stage2"
-                Ghc Stage3    -> "ghc-stage3"
-                Gcc Stage0    -> "system-gcc"
-                Gcc _         -> "gcc"
-                GhcPkg Stage0 -> "system-ghc-pkg"
-                GhcPkg _      -> "ghc-pkg"
-        cfgPath <- askConfigWithDefault key $
-            redError $ "\nCannot find path to '" ++ key
+        cfgPath <- askConfigWithDefault (builderKey builder) $
+            redError $ "\nCannot find path to '" ++ (builderKey builder)
                      ++ "' in configuration files."
         let cfgPathExe = if null cfgPath then "" else cfgPath -<.> exe
         windows <- windowsHost
@@ -82,18 +84,21 @@ needBuilder builder = do
 -- Action 'with Gcc' returns '--with-gcc=/path/to/gcc' and needs Gcc
 with :: Builder -> Args
 with builder = do
-    let key = case builder of
-            Ar       -> "--with-ar="
-            Ld       -> "--with-ld="
-            Gcc _    -> "--with-gcc="
-            Ghc _    -> "--with-ghc="
-            Alex     -> "--with-alex="
-            Happy    -> "--with-happy="
-            GhcPkg _ -> "--with-ghc-pkg="
-            HsColour -> "--with-hscolour="
     exe <- showArg builder
     needBuilder builder
-    return [key ++ exe]
+    return [withBuilderKey builder ++ exe]
+
+withBuilderKey :: Builder -> String
+withBuilderKey builder = case builder of
+    Ar       -> "--with-ar="
+    Ld       -> "--with-ld="
+    Gcc _    -> "--with-gcc="
+    Ghc _    -> "--with-ghc="
+    Alex     -> "--with-alex="
+    Happy    -> "--with-happy="
+    GhcPkg _ -> "--with-ghc-pkg="
+    HsColour -> "--with-hscolour="
+    _        -> error "withBuilderKey: not supported builder"
 
 -- Run the builder with a given collection of arguments
 verboseRun :: ShowArgs a => Builder -> a -> Action ()
index f505c83..ff6d6c1 100644 (file)
@@ -2,7 +2,7 @@
 
 module Oracles.PackageData (
     PackageData (..), MultiPackageData (..),
-    PackageDataKey (..)
+    PackageDataKey (..), askPackageData
     ) where
 
 import Development.Shake.Classes
@@ -38,6 +38,15 @@ data MultiPackageData = Modules        FilePath
 newtype PackageDataKey = PackageDataKey (FilePath, String)
                         deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
+askPackageData :: FilePath -> String -> Action String
+askPackageData path key = do
+    let fullKey = replaceSeparators '_' $ path ++ "_" ++ key
+        pkgData = path </> "package-data.mk"
+    value <- askOracle $ PackageDataKey (pkgData, fullKey)
+    return $ fromMaybe
+        (error $ "No key '" ++ key ++ "' in " ++ pkgData ++ ".") value
+
+-- TODO: remove
 instance ShowArg PackageData where
     showArg packageData = do
         let (key, path) = case packageData of
index 970ed3a..e5dc94e 100644 (file)
@@ -1,4 +1,4 @@
-module Package (Package, library, setCabal) where
+module Package (Package (..), library, setCabal) where
 
 import Base
 import Util
@@ -8,7 +8,7 @@ data Package = Package
      {
          pkgName  :: String,   -- Examples: "deepseq", "Cabal/Cabal"
          pkgPath  :: FilePath, -- "libraries/deepseq", "libraries/Cabal/Cabal"
-         pkgCabal :: FilePath  -- "deepseq.cabal", "Cabal.cabal"
+         pkgCabal :: FilePath  -- "deepseq.cabal", "Cabal.cabal" (relative)
      }
 
 instance Show Package where
@@ -17,6 +17,9 @@ instance Show Package where
 instance Eq Package where
     (==) = (==) `on` pkgName
 
+instance Ord Package where
+    compare = compare `on` pkgName
+
 libraryPackage :: String -> String -> Package
 libraryPackage name cabalName =
     Package
diff --git a/src/PackageBuild.hs b/src/PackageBuild.hs
deleted file mode 100644 (file)
index f7a98a7..0000000
+++ /dev/null
@@ -1,67 +0,0 @@
-module Package (Package, library, setCabal, packageRules) where
-
---import Package.Base
---import Package.Data
---import Package.Compile
---import Package.Library
---import Package.Dependencies
---import Targets
---import Settings
-
--- pkgPath is the path to the source code relative to the root
-data Package = Package
-     {
-         pkgName  :: String,   -- Examples: "deepseq", "Cabal/Cabal"
-         pkgPath  :: FilePath, -- "libraries/deepseq", "libraries/Cabal/Cabal"
-         pkgCabal :: FilePath  -- "deepseq.cabal", "Cabal.cabal"
-     }
-
-instance Eq Package where
-    (==) = (==) `on` pkgName
-
-libraryPackage :: String -> String -> Package
-libraryPackage name cabalName =
-    Package
-        name
-        (unifyPath $ "libraries" </> name)
-        cabalName
-
-library :: String -> Package
-library name = libraryPackage name (name <.> "cabal")
-
-setCabal :: Package -> FilePath -> Package
-setCabal pkg cabalName = pkg { pkgCabal = cabalName }
-
--- Rule buildPackageX is defined in module Package.X
-buildPackage :: Package -> TodoItem -> Rules ()
-buildPackage = mempty -- buildPackageData
-            --<> buildPackageDependencies
-            --<> buildPackageCompile
-            --<> buildPackageLibrary
-
---packageRules :: Rules ()
---packageRules = do
---    -- TODO: control targets from command line arguments
-
---    -- The package list (targetPackages) is defined in Targets.hs
---    forM_ targetPackages $ \pkg @ (Package name path _ todo) -> do
---        forM_ todo $ \todoItem @ (stage, dist, settings) -> do
-
---            -- Want top .o and .a files for the pkg/todo combo
---            -- We build *only one* vanilla .o file (not sure why)
---            -- We build .way_a file for each way (or its dynamic version).
---            -- TODO: Check BUILD_GHCI_LIB flag to decide if .o is needed
---            -- TODO: move this into a separate file (perhaps, to Targets.hs?)
---            action $ when (buildWhen settings) $ do
---                let pathDist = path </> dist
---                    buildDir = pathDist </> "build"
---                key <- showArg (PackageKey pathDist)
---                let oFile = buildDir </> "Hs" ++ key <.> "o"
---                ways'  <- ways settings
---                libFiles <- forM ways' $ \way -> do
---                    extension <- libsuf way
---                    return $ buildDir </> "libHs" ++ key <.> extension
---                need $ [oFile] ++ libFiles
-
---            -- Build rules for the package
---            buildPackage pkg todoItem
diff --git a/src/Rules.hs b/src/Rules.hs
new file mode 100644 (file)
index 0000000..7cb5c25
--- /dev/null
@@ -0,0 +1,41 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Rules (
+    generateTargets, packageRules,
+    module Rules.Package,
+    ) where
+
+import Base hiding (arg, args, Args)
+import Util
+import Control.Monad
+import Targets
+import Settings
+import Package
+import Expression.Base
+import Rules.Package
+
+generateTargets :: Rules ()
+generateTargets = action $
+    forM_ [Stage0 ..] $ \stage -> do
+        pkgs <- evaluate $ project stage targetPackages
+        case linearise pkgs of
+            Nothing      -> redError "Cannot determine target packages."
+            Just pkgList -> do
+                forM_ pkgList $ \pkg -> do
+                    dirs <- evaluate $ project (stage, pkg) targetDirectories
+                    case linearise dirs of
+                        Just [TargetDir dir] -> do
+                            need [pkgPath pkg </> dir </> "package-data.mk"]
+                        _ -> redError "Cannot determine target directory."
+
+packageRules :: Rules ()
+packageRules = do
+    forM_ [Stage0 ..] $ \stage -> do
+        forM_ (support $ simplify $ project stage targetPackages) $ \pkg -> do
+            let dirs = project (stage, pkg) targetDirectories
+            case linearise dirs of
+                Just [dir] -> do
+                    let ways     = project (stage, pkg) targetWays
+                        stgs     = project (stage, pkg, dir) buildSettings
+                        buildDir = pkgPath pkg </> fromTargetDir dir
+                    buildPackage stage pkg buildDir ways stgs
+                _ -> action $ redError "Cannot determine target directory."
diff --git a/src/Rules/Data.hs b/src/Rules/Data.hs
new file mode 100644 (file)
index 0000000..2cb84bb
--- /dev/null
@@ -0,0 +1,184 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Rules.Data (
+    cabalSettings, ghcPkgSettings, buildPackageData
+    ) where
+
+import qualified Ways
+import Base hiding (arg, args, Args)
+import Package
+import Expression.Base
+import Oracles.Flag (when)
+import Oracles.Builder
+import Targets
+import Switches
+import Util
+
+librarySettings :: Ways -> Settings
+librarySettings ways = msum
+    [ whenExists Ways.vanilla ways     ?? ( arg  "--enable-library-vanilla"
+                                          , arg "--disable-library-vanilla" )
+    , (ghcWithInterpreter
+      && not dynamicGhcPrograms
+      && whenExists Ways.vanilla ways) ?? ( arg  "--enable-library-for-ghci"
+                                          , arg "--disable-library-for-ghci" )
+    , whenExists Ways.profiling ways   ?? ( arg  "--enable-library-profiling"
+                                          , arg "--disable-library-profiling" )
+    , whenExists Ways.dynamic ways     ?? ( arg  "--enable-shared"
+                                          , arg "--disable-shared" )]
+
+configureSettings :: Settings
+configureSettings =
+    let conf key = argPrefix ("--configure-option=" ++ key ++ "=")
+                 . argConcatSpace
+    in
+    msum [ conf "CFLAGS"   ccSettings
+         , conf "LDFLAGS"  ldSettings
+         , conf "CPPFLAGS" cppSettings
+         , argPrefix "--gcc-options=" $
+           argConcatSpace (ccSettings <|> ldSettings)
+         , conf "--with-iconv-includes"  (argConfig "iconv-include-dirs")
+         , conf "--with-iconv-libraries" (argConfig "iconv-lib-dirs")
+         , conf "--with-gmp-includes"    (argConfig "gmp-include-dirs")
+         , conf "--with-gmp-libraries"   (argConfig "gmp-lib-dirs")
+         -- TODO: why TargetPlatformFull and not host?
+         , crossCompiling ?
+           conf "--host"    (argConfig "target-platform-full")
+         , conf "--with-cc" (argStagedBuilderPath Gcc) ]
+
+bootPackageDbSettings :: Settings
+bootPackageDbSettings =
+    stage Stage0 ?
+        argPrefix "--package-db="
+        (argConcatPath $ argConfig "ghc-source-path" |>
+                         argPath "libraries/bootstrapping.conf")
+
+dllSettings :: Settings
+dllSettings = arg ""
+
+cabalSettings :: Settings
+cabalSettings =
+    mproduct
+    [ arg "configure" -- start with builder, e.g. argBuilderPath GhcCabal?
+    , argBuildPath
+    , argBuildDir
+    , dllSettings
+    , msum
+      [ argWithStagedBuilder Ghc -- TODO: used to be limited to max stage1 GHC
+      , argWithStagedBuilder GhcPkg
+      , customConfigureSettings
+      , stage Stage0 ? bootPackageDbSettings
+      , librarySettings targetWays
+      , configNonEmpty "hscolour" ? argWithBuilder HsColour -- TODO: more reuse
+      , configureSettings
+      , argPackageConstraints (stage Stage0 ? targetPackages)
+      , argWithStagedBuilder Gcc
+      , notStage Stage0 ? argWithBuilder Ld
+      , argWithBuilder Ar
+      , argWithBuilder Alex
+      , argWithBuilder Happy ]] -- TODO: reorder with's
+
+ghcPkgSettings :: Settings
+ghcPkgSettings =
+    arg "update" |> msum
+        [ arg "--force"
+        , argConcatPath $
+          msum [argBuildPath, argBuildDir, arg "inplace-pkg-config"]
+        , bootPackageDbSettings ]
+
+-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
+-- 1) Drop lines containing '$'
+-- For example, get rid of
+-- libraries/Win32_dist-install_CMM_SRCS  := $(addprefix cbits/,$(notdir ...
+-- Reason: we don't need them and we can't parse them.
+-- 2) Replace '/' and '\' with '_' before '='
+-- For example libraries/deepseq/dist-install_VERSION = 1.4.0.0
+-- is replaced by libraries_deepseq_dist-install_VERSION = 1.4.0.0
+-- Reason: Shake's built-in makefile parser doesn't recognise slashes
+
+postProcessPackageData :: FilePath -> Action ()
+postProcessPackageData file = do
+    pkgData <- (filter ('$' `notElem`) . lines) <$> liftIO (readFile file)
+    length pkgData `seq` writeFileLines file $ map processLine pkgData
+      where
+        processLine line = replaceSeparators '_' prefix ++ suffix
+          where
+            (prefix, suffix) = break (== '=') line
+
+-- 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
+
+-- Build package-data.mk by using GhcCabal to process pkgCabal file
+buildPackageData :: Stage -> Package -> FilePath -> Ways -> Settings -> Rules ()
+buildPackageData stage pkg dir ways settings =
+    (dir </>) <$>
+    [ "package-data.mk"
+    , "haddock-prologue.txt"
+    , "inplace-pkg-config"
+    , "setup-config"
+    , "build" </> "autogen" </> "cabal_macros.h"
+    -- TODO: Is this needed? Also check out Paths_cpsa.hs.
+    -- , "build" </> "autogen" </> ("Paths_" ++ name) <.> "hs"
+    ] &%> \_ -> do
+        let configure = pkgPath pkg </> "configure"
+        need [pkgPath pkg </> pkgCabal pkg]
+        -- GhcCabal will run the configure script, so we depend on it
+        -- We still don't know who build the configure script from configure.ac
+        when (doesFileExist $ configure <.> "ac") $ need [configure]
+        run' GhcCabal settings
+        -- TODO: when (registerPackage settings) $
+        run' (GhcPkg stage) settings
+        postProcessPackageData $ dir </> "package-data.mk"
+
+run' :: Builder -> Settings -> Action ()
+run' builder settings = do
+    settings' <- evaluate (project builder settings)
+    case fromSettings settings' of
+        Nothing   ->
+            redError $ "Cannot determine " ++ show builder ++ " settings."
+        Just args -> do
+            putColoured Green (show args)
+            run builder args
+
+--buildRule :: Package -> TodoItem -> Rules ()
+--buildRule pkg @ (Package name path cabal _) todo @ (stage, dist, settings) =
+--    let pathDist  = path </> dist
+--        cabalPath = path </> cabal
+--        configure = path </> "configure"
+--    in
+--    -- All these files are produced by a single run of GhcCabal
+--    (pathDist </>) <$>
+--    [ "package-data.mk"
+--    , "haddock-prologue.txt"
+--    , "inplace-pkg-config"
+--    , "setup-config"
+--    , "build" </> "autogen" </> "cabal_macros.h"
+--    -- TODO: Is this needed? Also check out Paths_cpsa.hs.
+--    -- , "build" </> "autogen" </> ("Paths_" ++ name) <.> "hs"
+--    ] &%> \_ -> do
+--        need [cabalPath]
+--        when (doesFileExist $ configure <.> "ac") $ need [configure]
+--        -- GhcCabal will run the configure script, so we depend on it
+--        -- We still don't know who build the configure script from configure.ac
+--        run GhcCabal $ cabalArgs pkg todo
+--        when (registerPackage settings) $
+--            run (GhcPkg stage) $ ghcPkgArgs pkg todo
+--        postProcessPackageData $ pathDist </> "package-data.mk"
+
+ccSettings :: Settings
+ccSettings = msum
+    [ package integerLibrary ? argPath "-Ilibraries/integer-gmp2/gmp"
+    , builder GhcCabal ? argStagedConfig "conf-cc-args"
+    , validating ? msum
+        [ not (builder GhcCabal) ? arg "-Werror"
+        , arg "-Wall"
+        , gccIsClang ??
+          ( arg "-Wno-unknown-pragmas" <|>
+            not gccLt46 && windowsHost ? arg "-Werror=unused-but-set-variable"
+          , not gccLt46 ? arg "-Wno-error=inline" )]]
+
+ldSettings :: Settings
+ldSettings = builder GhcCabal ? argStagedConfig "conf-gcc-linker-args"
+
+cppSettings :: Settings
+cppSettings = builder GhcCabal ? argStagedConfig "conf-cpp-args"
diff --git a/src/Rules/Package.hs b/src/Rules/Package.hs
new file mode 100644 (file)
index 0000000..a36f64b
--- /dev/null
@@ -0,0 +1,11 @@
+module Rules.Package (
+    buildPackage
+    ) where
+
+import Base
+import Package
+import Rules.Data
+import Expression.Base
+
+buildPackage :: Stage -> Package -> FilePath -> Ways -> Settings -> Rules ()
+buildPackage = buildPackageData
index b9cdcfc..c2f39e7 100644 (file)
@@ -1,18 +1,19 @@
 {-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
 
 module Settings (
-    -- IntegerLibrary (..), integerLibrary, integerLibraryName,
-    buildHaddock
+    buildSettings
     ) where
 
 import Base hiding (arg, args, Args)
-import Targets
-import Ways
+import Rules.Data
+import Switches
 import Oracles.Builder
 import Expression.Base
 
-validating :: BuildPredicate
-validating = false
+buildSettings :: Settings
+buildSettings = msum
+    [ builder       GhcCabal ? cabalSettings
+    , stagedBuilder GhcPkg   ? ghcPkgSettings ]
 
 packageSettings :: Settings
 packageSettings = msum
@@ -24,106 +25,3 @@ packageSettings = msum
         argPairs "-package-key"      argPackageDepKeys
       , argPairs "-package-name"     argPackageKey <|>
         argPairs "-package"          argPackageDeps )]
-
-librarySettings :: Ways -> Settings
-librarySettings ways = msum
-    [ whenExists vanilla ways     ?? ( arg  "--enable-library-vanilla"
-                                     , arg "--disable-library-vanilla" )
-    , (ghcWithInterpreter
-      && not dynamicGhcPrograms
-      && whenExists vanilla ways) ?? ( arg  "--enable-library-for-ghci"
-                                     , arg "--disable-library-for-ghci" )
-    , whenExists profiling ways   ?? ( arg  "--enable-library-profiling"
-                                     , arg "--disable-library-profiling" )
-    , whenExists dynamic ways     ?? ( arg  "--enable-shared"
-                                     , arg "--disable-shared" )]
-
-ccSettings :: Settings
-ccSettings = msum
-    [ package integerLibrary ? argPath "-Ilibraries/integer-gmp2/gmp"
-    , builder GhcCabal ? argStagedConfig "conf-cc-args"
-    , validating ? msum
-        [ not (builder GhcCabal) ? arg "-Werror"
-        , arg "-Wall"
-        , gccIsClang ??
-          ( arg "-Wno-unknown-pragmas" <|>
-            not gccLt46 && windowsHost ? arg "-Werror=unused-but-set-variable"
-          , not gccLt46 ? arg "-Wno-error=inline" )]]
-
-ldSettings :: Settings
-ldSettings = builder GhcCabal ? argStagedConfig "conf-gcc-linker-args"
-
-cppSettings :: Settings
-cppSettings = builder GhcCabal ? argStagedConfig "conf-cpp-args"
-
-configureSettings :: Settings
-configureSettings =
-    let conf key = argPrefix ("--configure-option=" ++ key ++ "=")
-                 . argConcatSpace
-    in
-    msum [ conf "CFLAGS"   ccSettings
-         , conf "LDFLAGS"  ldSettings
-         , conf "CPPFLAGS" cppSettings
-         , argPrefix "--gcc-options=" $
-           argConcatSpace (ccSettings <|> ldSettings)
-         , conf "--with-iconv-includes"  (argConfig "iconv-include-dirs")
-         , conf "--with-iconv-libraries" (argConfig "iconv-lib-dirs")
-         , conf "--with-gmp-includes"    (argConfig "gmp-include-dirs")
-         , conf "--with-gmp-libraries"   (argConfig "gmp-lib-dirs")
-         -- TODO: why TargetPlatformFull and not host?
-         , crossCompiling ?
-           conf "--host"    (argConfig "target-platform-full")
-         , conf "--with-cc" (argStagedBuilderPath Gcc) ]
-
--- 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 ""
-
--- customConfArgs
-customConfigureSettings :: Settings
-customConfigureSettings = msum
-    [ package base    ? arg ("--flags=" ++ integerLibraryName)
-    , package ghcPrim ? arg "--flag=include-ghc-prim"
-    , package integerLibrary && windowsHost ?
-        arg "--configure-option=--with-intree-gmp"
-    ]
-
-bootPackageDbSettings :: Settings
-bootPackageDbSettings =
-    stage Stage0 ?
-        argPrefix "--package-db="
-        (argConcatPath $ argConfig "ghc-source-path" |>
-                         argPath "libraries/bootstrapping.conf")
-
-cabalSettings :: Settings
-cabalSettings =
-    mproduct
-    [ argBuilderPath GhcCabal
-    , arg "configure"
-    , argBuildPath
-    , argBuildDir
-    , dllSettings
-    , msum
-      [ argWithStagedBuilder Ghc -- TODO: used to be limited to max stage1 GHC
-      , argWithStagedBuilder GhcPkg
-      , customConfigureSettings
-      , stage Stage0 ? bootPackageDbSettings
-      , librarySettings targetWays
-      , configNonEmpty "hscolour" ? argWithBuilder HsColour -- TODO: more reuse
-      , configureSettings
-      , stage Stage0 ? argBootPkgConstraints
-      , argWithStagedBuilder Gcc
-      , notStage Stage0 ? argWithBuilder Ld
-      , argWithBuilder Ar
-      , argWithBuilder Alex
-      , argWithBuilder Happy ]] -- TODO: reorder with's
-
-ghcPkgSettings :: Settings
-ghcPkgSettings =
-    arg "update" |> msum
-        [ arg "--force"
-        , argConcatPath $
-          msum [argBuildPath, argBuildDir, arg "inplace-pkg-config"]
-        , bootPackageDbSettings ]
diff --git a/src/Switches.hs b/src/Switches.hs
new file mode 100644 (file)
index 0000000..aea6a06
--- /dev/null
@@ -0,0 +1,78 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Switches (
+    buildHaddock, validating,
+    IntegerLibraryImpl (..), integerLibraryImpl,
+    supportsPackageKey, targetPlatforms, targetPlatform,
+    targetOss, targetOs, targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
+    platformSupportsSharedLibs, crossCompiling,
+    gccIsClang, gccLt46, windowsHost
+    ) where
+
+import Expression.Base
+
+-- User-defined switches
+buildHaddock :: BuildPredicate
+buildHaddock = true
+
+validating :: BuildPredicate
+validating = false
+
+-- Support for multiple integer library implementations
+data IntegerLibraryImpl = IntegerGmp | IntegerGmp2 | IntegerSimple
+
+integerLibraryImpl :: IntegerLibraryImpl
+integerLibraryImpl = IntegerGmp2
+
+-- Predicates based on configuration files
+supportsPackageKey :: BuildPredicate
+supportsPackageKey = configYes "supports-package-key"
+
+targetPlatforms :: [String] -> BuildPredicate
+targetPlatforms = configValues "target-platform-full"
+
+targetPlatform :: String -> BuildPredicate
+targetPlatform s = targetPlatforms [s]
+
+targetOss :: [String] -> BuildPredicate
+targetOss = configValues "target-os"
+
+targetOs :: String -> BuildPredicate
+targetOs s = targetOss [s]
+
+targetArchs :: [String] -> BuildPredicate
+targetArchs = configValues "target-arch"
+
+solarisBrokenShld :: BuildPredicate
+solarisBrokenShld = configYes "solaris-broken-shld"
+
+platformSupportsSharedLibs :: BuildPredicate
+platformSupportsSharedLibs =
+    not (targetPlatforms [ "powerpc-unknown-linux"
+                         , "x86_64-unknown-mingw32"
+                         , "i386-unknown-mingw32" ]
+        ||
+        solarisBrokenShld && targetPlatform "i386-unknown-solaris2")
+
+dynamicGhcPrograms :: BuildPredicate
+dynamicGhcPrograms = configYes "dynamic-ghc-programs"
+
+ghcWithInterpreter :: BuildPredicate
+ghcWithInterpreter =
+    targetOss [ "mingw32", "cygwin32", "linux", "solaris2"
+              , "freebsd", "dragonfly", "netbsd", "openbsd"
+              , "darwin", "kfreebsdgnu" ]
+    &&
+    targetArchs ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
+
+crossCompiling :: BuildPredicate
+crossCompiling = configYes "cross-compiling"
+
+gccIsClang :: BuildPredicate
+gccIsClang = configYes "gcc-is-clang"
+
+gccLt46 :: BuildPredicate
+gccLt46 = configYes "gcc-lt-46"
+
+windowsHost :: BuildPredicate
+windowsHost = configValues "host-os-cpp" ["mingw32", "cygwin32"]
index 5cd530f..3ec4d19 100644 (file)
@@ -1,8 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 module Targets (
-    buildHaddock,
     targetWays, targetPackages, targetDirectories,
-    IntegerLibraryImpl (..), integerLibraryImpl, integerLibraryName,
+    customConfigureSettings,
     array, base, binPackageDb, binary, bytestring, cabal, containers, deepseq,
     directory, filepath, ghcPrim, haskeline, hoopl, hpc, integerLibrary,
     parallel, pretty, primitive, process, stm, templateHaskell, terminfo, time,
@@ -10,13 +9,11 @@ module Targets (
     ) where
 
 import qualified Ways
-import Base
+import Base hiding (arg, args, Args)
+import Switches
 import Package
 import Expression.Base
 
-buildHaddock :: BuildPredicate
-buildHaddock = true
-
 -- These are the packages we build
 targetPackages :: Packages
 targetPackages = msum
@@ -50,28 +47,10 @@ targetWays = msum
 -- * build/           : contains compiled object code
 -- * doc/             : produced by haddock
 -- * package-data.mk  : contains output of ghc-cabal applied to pkgCabal
-targetDirectories :: FilePaths
+targetDirectories :: TargetDirs
 targetDirectories =
-    stage Stage0 ?? (return "dist-boot", return "dist-install")
-
--- Support for multiple integer library implementations
-data IntegerLibraryImpl = IntegerGmp | IntegerGmp2 | IntegerSimple
-
-integerLibraryImpl :: IntegerLibraryImpl
-integerLibraryImpl = IntegerGmp2
-
-integerLibraryName :: String
-integerLibraryName = case integerLibraryImpl of
-    IntegerGmp    -> "integer-gmp"
-    IntegerGmp2   -> "integer-gmp2"
-    IntegerSimple -> "integer-simple"
-
--- see Note [Cabal name weirdness]
-integerLibraryCabal :: FilePath
-integerLibraryCabal = case integerLibraryImpl of
-        IntegerGmp    -> "integer-gmp.cabal"
-        IntegerGmp2   -> "integer-gmp.cabal" -- Indeed, why make life easier?
-        IntegerSimple -> "integer-simple.cabal"
+    stage Stage0 ?? ( return $ TargetDir "dist-boot"
+                    , return $ TargetDir "dist-install")
 
 -- Package definitions
 array, base, binPackageDb, binary, bytestring, cabal, containers, deepseq,
@@ -107,6 +86,28 @@ unix            = library "unix"
 win32           = library "Win32"
 xhtml           = library "xhtml"
 
+integerLibraryName :: String
+integerLibraryName = case integerLibraryImpl of
+    IntegerGmp    -> "integer-gmp"
+    IntegerGmp2   -> "integer-gmp2"
+    IntegerSimple -> "integer-simple"
+
+-- see Note [Cabal name weirdness]
+integerLibraryCabal :: FilePath
+integerLibraryCabal = case integerLibraryImpl of
+        IntegerGmp    -> "integer-gmp.cabal"
+        IntegerGmp2   -> "integer-gmp.cabal" -- Indeed, why make life easier?
+        IntegerSimple -> "integer-simple.cabal"
+
+-- Custom configure settings for packages
+customConfigureSettings :: Settings
+customConfigureSettings = msum
+    [ package base    ? arg ("--flags=" ++ integerLibraryName)
+    , package ghcPrim ? arg "--flag=include-ghc-prim"
+    , package integerLibrary && windowsHost ?
+        arg "--configure-option=--with-intree-gmp"
+    ]
+
 -- TODISCUSS
 -- Note [Cabal name weirdness]
 -- Find out if we can move the contents to just Cabal/