Commit 5b1c2153 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Switch to difference lists.

parent b5bf68d5
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
module Control.Monad.Reader,
Ways,
Expr, DiffExpr, fromDiff,
Predicate,
Expression,
Ways, Packages,
Environment (..), defaultEnvironment,
append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
interpret,
whenPredicate, (?), (??), stage, notStage, builder, notBuilder, package,
applyPredicate, (?), (??), stage, notStage, builder, notBuilder, package,
configKeyValue, configKeyValues,
configKeyYes, configKeyNo, configKeyNonEmpty
) where
......@@ -32,27 +33,71 @@ defaultEnvironment = Environment
getPackage = error "Package not set in the environment"
}
type Expression a = ReaderT Environment Action a
type Expr a = ReaderT Environment Action a
type DiffExpr a = Expr (Endo a)
type Ways = Expression [Way]
type Predicate = Expression Bool
type Predicate = Expr Bool
type Ways = DiffExpr [Way]
type Packages = DiffExpr [Package]
instance Monoid a => Monoid (Expression a) where
instance Monoid a => Monoid (Expr a) where
mempty = return mempty
mappend = liftM2 mappend
interpret :: Environment -> Expression a -> Action a
append :: Monoid a => a -> DiffExpr a
append x = return $ Endo (<> x)
appendM :: Monoid a => Action a -> DiffExpr a
appendM mx = lift mx >>= append
remove :: Eq a => [a] -> DiffExpr [a]
remove xs = return . Endo $ filter (`notElem` xs)
-- appendSub appends a list of sub-arguments to all arguments starting with a
-- 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] -> DiffExpr [String]
appendSub prefix xs
| xs == [] = mempty
| otherwise = return $ Endo (go False)
where
go True [] = []
go False [] = [prefix ++ "=" ++ unwords xs]
go found (y:ys) = if prefix `isPrefixOf` y
then unwords (y : xs) : go True ys
else go found ys
-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
appendSubD :: String -> DiffExpr [String] -> DiffExpr [String]
appendSubD prefix diffExpr = fromDiff diffExpr >>= appendSub prefix
filterSub :: String -> (String -> Bool) -> DiffExpr [String]
filterSub prefix p = return . Endo $ map filterSubstr
where
filterSubstr s
| prefix `isPrefixOf` s = unwords . filter p . words $ s
| otherwise = s
removeSub :: String -> [String] -> DiffExpr [String]
removeSub prefix xs = filterSub prefix (`notElem` xs)
interpret :: Environment -> Expr a -> Action a
interpret = flip runReaderT
whenPredicate :: Monoid a => Predicate -> Expression a -> Expression a
whenPredicate predicate expr = do
fromDiff :: Monoid a => DiffExpr a -> Expr a
fromDiff = fmap (($ mempty) . appEndo)
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
bool <- predicate
if bool then expr else return mempty
(?) :: Monoid a => Predicate -> Expression a -> Expression a
(?) = whenPredicate
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate
(??) :: Monoid a => Predicate -> (Expression a, Expression a) -> Expression a
(??) :: Monoid a => Predicate -> (Expr a, Expr a) -> Expr a
p ?? (t, f) = p ? t <> (liftM not p) ? f
infixr 8 ?
......@@ -77,7 +122,7 @@ configKeyValue key value = liftM (value ==) (lift $ askConfig key)
-- checks if there is at least one match
configKeyValues :: String -> [String] -> Predicate
configKeyValues key values = liftM (flip elem $ values) (lift $ askConfig key)
configKeyValues key values = liftM (`elem` values) (lift $ askConfig key)
configKeyYes :: String -> Predicate
configKeyYes key = configKeyValue key "YES"
......
......@@ -4,7 +4,7 @@ module Expression.Settings (
Settings,
-- Primitive settings elements
arg, args,
arg, argM, args,
argConfig, argStagedConfig, argConfigList, argStagedConfigList,
-- argBuilderPath, argStagedBuilderPath,
-- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
......@@ -18,21 +18,24 @@ import Base hiding (Args, arg, args)
import Oracles hiding (not)
import Expression
type Settings = Expression [String]
type Settings = DiffExpr [String]
-- A single argument
arg :: String -> Settings
arg = return . return
arg = append . return
argM :: Action String -> Settings
argM = appendM . fmap return
-- A list of arguments
args :: [String] -> Settings
args = return
args = append
argConfig :: String -> Settings
argConfig = lift . fmap return . askConfig
argConfig = appendM . fmap return . askConfig
argConfigList :: String -> Settings
argConfigList = lift . fmap words . askConfig
argConfigList = appendM . fmap words . askConfig
stagedKey :: Stage -> String -> String
stagedKey stage key = key ++ "-stage" ++ show stage
......
......@@ -16,19 +16,18 @@ import Rules.Package
-- TODO: make interpret total
generateTargets :: Rules ()
generateTargets = action $
forM_ [Stage0 ..] $ \stage ->
forM_ targetPackages $ \pkg -> do
let env = defaultEnvironment { getStage = stage, getPackage = pkg }
dir = targetDirectory stage pkg
required <- interpret env (packagePredicate pkg)
when required $ need [pkgPath pkg </> dir </> "package-data.mk"]
forM_ [Stage0 ..] $ \stage -> do
let env = defaultEnvironment { getStage = stage }
pkgs <- interpret env $ fromDiff targetPackages
forM_ pkgs $ \pkg -> do
let dir = targetDirectory stage pkg
need [pkgPath pkg </> dir </> "package-data.mk"]
-- TODO: simplify
-- TODO: make interpret total
-- TODO: add Stage2 (compiler only?)
packageRules :: Rules ()
packageRules =
forM_ [Stage0, Stage1] $ \stage -> do
forM_ targetPackages $ \pkg -> do
forM_ allPackages $ \pkg -> do
let env = defaultEnvironment { getStage = stage, getPackage = pkg }
buildPackage env targetWays buildSettings
......@@ -2,7 +2,7 @@ module Rules.Data (
cabalSettings, ghcPkgSettings, buildPackageData
) where
import qualified Ways
import Ways hiding (parallel)
import Base hiding (arg, args, Args)
import Package
import Expression hiding (when, liftIO)
......@@ -17,61 +17,53 @@ import Util
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
librarySettings :: Ways -> Settings
librarySettings waysExpression = do
ways <- waysExpression
ghcInterp <- ghcWithInterpreter
dynPrograms <- dynamicGhcPrograms
return $ [ if Ways.vanilla `elem` ways
then "--enable-library-vanilla"
else "--disable-library-vanilla"
, if Ways.vanilla `elem` ways && ghcInterp && not dynPrograms
then "--enable-library-for-ghci"
else "--disable-library-for-ghci"
, if Ways.profiling `elem` ways
then "--enable-library-profiling"
else "--disable-library-profiling"
, if Ways.dynamic `elem` ways
then "--enable-shared"
else "--disable-shared" ]
ways <- fromDiff waysExpression
ghcInterpreter <- ghcWithInterpreter
dynamicPrograms <- dynamicGhcPrograms
append [ if vanilla `elem` ways
then "--enable-library-vanilla"
else "--disable-library-vanilla"
, if vanilla `elem` ways && ghcInterpreter && not dynamicPrograms
then "--enable-library-for-ghci"
else "--disable-library-for-ghci"
, if profiling `elem` ways
then "--enable-library-profiling"
else "--disable-library-profiling"
, if dynamic `elem` ways
then "--enable-shared"
else "--disable-shared" ]
configureSettings :: Settings
configureSettings = do
let conf key expr = do
value <- liftM unwords expr
return $ if value == ""
then []
else ["--configure-option=" ++ key ++ "=" ++ value]
let conf key = appendSubD $ "--configure-option=" ++ key
stage <- asks getStage
gccPath <- lift $ showArg (Gcc stage)
gccSettings <- liftM unwords (ccSettings <> ldSettings)
mconcat [ conf "CFLAGS" ccSettings
, conf "LDFLAGS" ldSettings
, conf "CPPFLAGS" cppSettings
, arg $ "--gcc-options=" ++ gccSettings
, 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" (arg gccPath) ]
mconcat
[ conf "CFLAGS" ccSettings
, conf "LDFLAGS" ldSettings
, conf "CPPFLAGS" cppSettings
, appendSubD "--gcc-options" $ 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" . argM . showArg $ Gcc stage ]
bootPackageDbSettings :: Settings
bootPackageDbSettings = do
sourcePath <- lift $ askConfig "ghc-source-path"
return $ ["--package-db=" ++ sourcePath </> "libraries/bootstrapping.conf"]
arg $ "--package-db=" ++ sourcePath </> "libraries/bootstrapping.conf"
dllSettings :: Settings
dllSettings = arg ""
with' :: Builder -> Settings
with' builder = lift $ with builder
with' builder = appendM $ with builder
packageConstraints :: Settings
packageConstraints = do
pkgs <- filterM packagePredicate targetPackages
pkgs <- fromDiff targetPackages
constraints <- lift $ forM pkgs $ \pkg -> do
let cabal = pkgPath pkg </> pkgCabal pkg
prefix = dropExtension (pkgCabal pkg) ++ " == "
......@@ -82,7 +74,7 @@ packageConstraints = do
[v] -> return $ prefix ++ dropWhile (not . isDigit) v
_ -> redError $ "Cannot determine package version in '"
++ cabal ++ "'."
return $ concatMap (\c -> ["--constraint", c]) $ constraints
args $ concatMap (\c -> ["--constraint", c]) $ constraints
cabalSettings :: Settings
cabalSettings = do
......@@ -167,7 +159,7 @@ buildPackageData env ways settings =
run' :: Environment -> Builder -> Settings -> Action ()
run' env builder settings = do
args <- interpret (env {getBuilder = builder}) settings
args <- interpret (env {getBuilder = builder}) $ fromDiff settings
putColoured Green (show args)
run builder args
......
module Targets (
targetWays, targetPackages, targetDirectory, packagePredicate,
targetWays, targetPackages, targetDirectory, allPackages,
customConfigureSettings,
array, base, binPackageDb, binary, bytestring, cabal, containers, deepseq,
directory, filepath, ghcPrim, haskeline, hoopl, hpc, integerLibrary,
......@@ -7,7 +7,7 @@ module Targets (
transformers, unix, win32, xhtml
) where
import qualified Ways
import Ways hiding (parallel)
import Base hiding (arg, args, Args, TargetDir)
import Package
import Switches
......@@ -15,46 +15,31 @@ import Expression
import Expression.Settings
-- These are the packages we build
targetPackages :: [Package]
targetPackages =
[ array, base, binPackageDb, binary, bytestring, cabal, compiler
, containers, deepseq, directory, filepath, ghcPrim, haskeline
, hoopl, hpc, integerLibrary, parallel, pretty, primitive, process
, stm, templateHaskell, terminfo, time, transformers, unix, win32, xhtml ]
targetPackages :: Packages
targetPackages = mconcat
[ stage Stage0 ? packagesStage0
, stage Stage1 ? packagesStage1 ]
packagesStage0 :: Packages
packagesStage0 = mconcat
[ append [binPackageDb, binary, cabal, compiler, hoopl, hpc, transformers]
, notWindowsHost ? notTargetOs "ios" ? append [terminfo] ]
-- Some packages are built conditionally
-- TODO: make this function total (it only reads stage from the environment)
packagePredicate :: Package -> Predicate
packagePredicate pkg = do
stage <- asks getStage
windows <- windowsHost
ios <- targetOs "ios"
haddock <- buildHaddock
let result
| stage == Stage0 && pkg `notElem`
[ binPackageDb
, binary
, cabal
, compiler
, hoopl
, hpc
, terminfo
, transformers ] = False
| pkg == terminfo = not windows && not ios
| pkg == unix = not windows
| pkg == win32 = windows
| pkg == xhtml = haddock
| stage == Stage0 = True
| stage == Stage1 = True
| otherwise = False -- TODO: enable Stage2
return result
packagesStage1 :: Packages
packagesStage1 = mconcat
[ append [ array, base, bytestring, containers, deepseq, directory
, filepath, ghcPrim, haskeline, integerLibrary, parallel
, pretty, primitive, process, stm, templateHaskell, time ]
, windowsHost ? append [win32]
, notWindowsHost ? append [unix]
, buildHaddock ? append [xhtml] ]
-- Packages will be build these ways
targetWays :: Ways
targetWays = mconcat
[ return [Ways.vanilla] -- always build vanilla
, notStage Stage0 ? return [Ways.profiling]
, platformSupportsSharedLibs ? return [Ways.dynamic] ]
[ append [vanilla] -- always build vanilla
, notStage Stage0 ? append [profiling]
, platformSupportsSharedLibs ? append [dynamic] ]
-- Build results will be placed into a target directory with the following
-- typical structure:
......@@ -63,15 +48,17 @@ targetWays = mconcat
-- * package-data.mk : contains output of ghc-cabal applied to pkgCabal
targetDirectory :: Stage -> Package -> FilePath
targetDirectory stage package
| package == compiler = "stage" ++ show (1 + fromEnum stage)
| package == compiler = "stage" ++ show (fromEnum stage + 1)
| stage == Stage0 = "dist-boot"
| otherwise = "dist-install"
-- Package definitions
array, base, binPackageDb, binary, bytestring, cabal, containers, deepseq,
directory, filepath, ghcPrim, haskeline, hoopl, hpc, integerLibrary,
parallel, pretty, primitive, process, stm, templateHaskell, terminfo, time,
transformers, unix, win32, xhtml :: Package
allPackages :: [Package]
allPackages =
[ array, base, binPackageDb, binary, bytestring, cabal, compiler
, containers, deepseq, directory, filepath, ghcPrim, haskeline
, hoopl, hpc, integerLibrary, parallel, pretty, primitive, process
, stm, templateHaskell, terminfo, time, transformers, unix, win32, xhtml ]
array = library "array"
base = library "base"
......@@ -118,11 +105,10 @@ integerLibraryCabal = case integerLibraryImpl of
-- Custom configure settings for packages
customConfigureSettings :: Settings
customConfigureSettings = mconcat
[ package base ? arg ("--flags=" ++ integerLibraryName)
, package ghcPrim ? arg "--flag=include-ghc-prim"
, package integerLibrary ?
windowsHost ? arg "--configure-option=--with-intree-gmp"
]
[ package integerLibrary ?
windowsHost ? appendSub "--configure-option" ["--with-intree-gmp"]
, package base ? appendSub "--flags" [integerLibraryName]
, package ghcPrim ? appendSub "--flag" ["include-ghc-prim"]]
-- Note [Cabal name weirdness]
-- Find out if we can move the contents to just Cabal/
......
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