Commit 8cf38baf authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Finish translation of Data.hs argument lists.

parent d7cd023a
......@@ -3,6 +3,7 @@
module Expression.ArgList (
ArgList (..),
ArgsTeller,
plain,
fromPlain,
tellArgs
) where
......@@ -10,9 +11,14 @@ module Expression.ArgList (
import Data.Monoid
data ArgList = Plain [String]
| KeyValue String
| PackageKey String
| PackageDeps String
| PackageDepKeys String
deriving Eq
plain :: String -> ArgList
plain s = Plain [s]
type ArgsTeller = ArgList -> Maybe [String]
......@@ -29,4 +35,3 @@ tellArgs :: ArgsTeller -> ArgList -> ArgList
tellArgs t a = case t a of
Just list -> Plain list
Nothing -> a
{-# LANGUAGE FlexibleInstances #-}
module Expression (
module Expression.Base (
Guard,
Settings,
module Expression.ArgList,
module Expression.Predicate,
opts, fence, (?),
ArgList (..),
Ways, targetWays,
remove,
opt, opts, subSettings, optBuildPath, optBuildDist, optPath,
optBootPkgConstraints,
packages, package, setPackage,
builders, builder, setBuilder,
builders, builder, setBuilder, setBuilderFamily,
stages, stage, notStage, setStage,
ways, way, setWay,
files, file, setFile,
keyValues, keyValue, keyYes, keyNo, setKeyValue,
packageKey, packageDeps, packageDepKeys
optKeyValue, optBuilder, optStagedBuilder,
crossCompiling,
keyValues, keyValue, keyYes, keyNo, keyNonEmpty, setKeyValue,
packageKey, packageDeps, packageDepKeys,
supportsPackageKey, targetPlatforms, targetPlatform,
targetOss, targetArchs,
dynamicGhcPrograms, ghcWithInterpreter
) where
import Base
......@@ -21,7 +28,8 @@ import Package.Base (Package)
import Oracles.Builder
import Expression.PG
import Expression.Predicate
import Expression.ArgList
import Expression.PGPredicate
-- import Expression.ArgList
data BuildParameter = WhenPackage Package
| WhenBuilder Builder
......@@ -32,22 +40,101 @@ data BuildParameter = WhenPackage Package
type Guard = Predicate BuildParameter
instance Monoid Guard where
mempty = Evaluated True
mappend = And
type Matcher = TruthTeller BuildParameter
type Settings = PG Guard ArgList
type Expression v = PGPredicate BuildParameter v
opts :: [String] -> Settings
opts = mconcat . map (\s -> Vertex $ Plain [s])
type Settings = Expression ArgList
type Ways = Expression Way
data ArgList = Plain [String]
| Complex String Settings
| Path String Settings
| BuildPath
| BuildDist
| BootPkgConstraints
| KeyValue String
| BuilderPath Builder
| PackageKey String
| PackageDeps String
| PackageDepKeys String
plain :: String -> ArgList
plain s = Plain [s]
subSettings :: String -> Settings -> Settings
subSettings prefix = Vertex . Complex prefix
type ArgsTeller = ArgList -> Maybe [String]
-- Monoid instance for args-tellers (asks them one by one)
instance Monoid ArgsTeller where
mempty = const Nothing
p `mappend` q = \a -> getFirst $ First (p a) <> First (q a)
fence :: Settings -> Settings -> Settings
fence = Sequence
fromPlain :: ArgsTeller
fromPlain (Plain list) = Just list
fromPlain _ = Nothing
(?) :: Guard -> Settings -> Settings
(?) = Condition
tellArgs :: ArgsTeller -> ArgList -> ArgList
tellArgs t a = case t a of
Just list -> Plain list
Nothing -> a
-- TODO: move to Targets.hs
targetWays :: Ways
targetWays = Vertex vanilla
<> notStage Stage0 ? Vertex profiling
<> platformSupportsSharedLibs ? Vertex dynamic
-- TODO: rename to 'arg' and args'
opt :: String -> Settings
opt = Vertex . plain
opts :: [String] -> Settings
opts = mconcat . map opt
optBuildPath, optBuildDist, optBootPkgConstraints :: Settings
optBuildPath = Vertex $ BuildPath
optBuildDist = Vertex $ BuildDist
optBootPkgConstraints = Vertex $ BootPkgConstraints
optPath :: String -> Settings -> Settings
optPath prefix = Vertex . Path prefix
---- Extract all plain and unconditional arguments.
---- Overlay subexpressions are evaluated in arbitrary order.
--plainArgs :: PGPredicate p v -> [v]
--plainArgs Epsilon = []
--plainArgs (Vertex (Plain args)) = args
--plainArgs (Vertex _) = []
--plainArgs (Overlay l r) = (++) <$> plainArgs l <*> plainArgs r -- TODO: union
--plainArgs (Sequence l r) = (++) <$> plainArgs l <*> plainArgs r
--plainArgs (Condition x r) = case tellTruth x of
-- Just True -> plainArgs r
-- _ -> []
-- Partially evaluate Settings using a truth-teller (compute a 'projection')
project :: Matcher -> Settings -> Settings
project _ Epsilon = Epsilon
project m (Vertex v) = case v of
Complex l r -> Vertex $ Complex l (project m r)
_ -> Vertex v
project m (Overlay l r) = Overlay (project m l) (project m r)
project m (Sequence l r) = Sequence (project m l) (project m r)
project m (Condition l r) = Condition (evaluate m l) (project m r)
remove :: [String] -> Settings -> Settings
remove _ Epsilon = Epsilon
remove a v @ (Vertex (Plain b))
| a == b = Epsilon
| otherwise = v
remove _ v @ (Vertex _) = v
remove a (Overlay l r) = Overlay (remove a l) (remove a r)
remove a (Sequence l r) = Sequence (remove a l) (remove a r)
remove a (Condition x r) = Condition x (remove a r)
infixl 7 ?
alternatives :: (a -> BuildParameter) -> [a] -> Guard
alternatives p = multiOr . map (Parameter . p)
......@@ -93,9 +180,10 @@ file f = files [f]
keyValue :: String -> String -> Guard
keyValue key value = keyValues key [value]
keyYes, keyNo :: String -> Guard
keyYes key = keyValues key ["YES"]
keyNo key = keyValues key ["NO" ]
keyYes, keyNo, keyNonEmpty :: String -> Guard
keyYes key = keyValues key ["YES"]
keyNo key = keyValues key ["NO" ]
keyNonEmpty key = Not $ keyValues key [""]
-- Partial evaluation of settings
......@@ -105,6 +193,9 @@ setPackage = project . matchPackage
setBuilder :: Builder -> Settings -> Settings
setBuilder = project . matchBuilder
setBuilderFamily :: (Stage -> Builder) -> Settings -> Settings
setBuilderFamily f = mconcat $ map (setBuilder . f) [Stage0 ..]
setStage :: Stage -> Settings -> Settings
setStage = project . matchStage
......@@ -119,8 +210,6 @@ setKeyValue key = project . matchKeyValue key
-- Truth-tellers for partial evaluation
type Matcher = TruthTeller BuildParameter
matchPackage :: Package -> Matcher
matchPackage p (WhenPackage p') = Just $ p == p'
matchPackage _ _ = Nothing
......@@ -149,6 +238,16 @@ matchKeyValue _ _ _ = Nothing
-- Argument templates
optKeyValue :: String -> Settings
optKeyValue = Vertex . KeyValue
optBuilder :: Builder -> Settings
optBuilder = Vertex . BuilderPath
optStagedBuilder :: (Stage -> Builder) -> Settings
optStagedBuilder f =
mconcat $ map (\s -> builder (f s) ? optBuilder (f s)) [Stage0 ..]
packageKey :: String -> Settings
packageKey = Vertex . PackageKey
......@@ -157,3 +256,46 @@ packageDeps = Vertex . PackageDeps
packageDepKeys :: String -> Settings
packageDepKeys = Vertex . PackageDepKeys
-- Derived guards
supportsPackageKey :: Guard
supportsPackageKey = keyYes "supports-package-key"
targetPlatforms :: [String] -> Guard
targetPlatforms = keyValues "target-platform-full"
targetPlatform :: String -> Guard
targetPlatform s = targetPlatforms [s]
targetOss :: [String] -> Guard
targetOss = keyValues "target-os"
targetArchs :: [String] -> Guard
targetArchs = keyValues "target-arch"
solarisBrokenShld :: Guard
solarisBrokenShld = keyYes "solaris-broken-shld"
platformSupportsSharedLibs :: Guard
platformSupportsSharedLibs =
Not $ (targetPlatforms [ "powerpc-unknown-linux"
, "x86_64-unknown-mingw32"
, "i386-unknown-mingw32" ]
`Or`
solarisBrokenShld `And` targetPlatform "i386-unknown-solaris2")
dynamicGhcPrograms :: Guard
dynamicGhcPrograms = keyYes "dynamic-ghc-programs"
ghcWithInterpreter :: Guard
ghcWithInterpreter =
targetOss [ "mingw32", "cygwin32", "linux", "solaris2"
, "freebsd", "dragonfly", "netbsd", "openbsd"
, "darwin", "kfreebsdgnu" ]
`And`
targetArchs ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
crossCompiling :: Guard
crossCompiling = keyYes "cross-compiling"
{-# LANGUAGE FlexibleInstances #-}
module Expression.PG (
module Expression.Predicate,
PG (..),
fromList,
mapP,
project,
linearise
PG (..) -- , fromList, mapP
) where
import Data.Monoid
import Control.Applicative
import Expression.Predicate
-- A generic Parameterised Graph datatype
-- * p is the type of predicates
......@@ -27,30 +20,14 @@ instance Monoid (PG p v) where
mappend = Overlay
-- For constructing a PG from an unordered list use mconcat.
fromList :: [v] -> PG p v
fromList = foldr Sequence Epsilon . map Vertex
--fromList :: [v] -> PG p v
--fromList = foldr Sequence Epsilon . map Vertex
-- 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)
--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)
-- Partially evaluate a PG using a truth-teller (compute a 'projection')
project :: TruthTeller a -> PG (Predicate a) v -> PG (Predicate a) v
project t = mapP (evaluate t)
-- Linearise a PG into a list. Returns Nothing if the given expression
-- cannot be uniquely evaluated due to remaining parameters.
-- Overlay subexpressions are evaluated in arbitrary order.
linearise :: PG (Predicate a) v -> Maybe [v]
linearise Epsilon = Just []
linearise (Vertex v) = Just [v]
linearise (Overlay l r) = (++) <$> linearise l <*> linearise r -- TODO: union
linearise (Sequence l r) = (++) <$> linearise l <*> linearise r
linearise (Condition x r) = case tellTruth x of
Just True -> linearise r
Just False -> Just []
Nothing -> Nothing
{-# LANGUAGE FlexibleInstances #-}
module Expression.PGPredicate (
module Expression.PG,
module Expression.Predicate,
PGPredicate (..),
fence, (?), ite,
whenExists,
remove,
project,
linearise
) where
......@@ -35,19 +31,6 @@ whenExists a (Overlay l r) = Or (whenExists a l) (whenExists a r)
whenExists a (Sequence l r) = Or (whenExists a l) (whenExists a r)
whenExists a (Condition x r) = And x (whenExists a r)
remove :: Eq v => v -> PGPredicate p v -> PGPredicate p v
remove _ Epsilon = Epsilon
remove a v @ (Vertex b)
| a == b = Epsilon
| otherwise = v
remove a (Overlay l r) = Overlay (remove a l) (remove a r)
remove a (Sequence l r) = Sequence (remove a l) (remove a r)
remove a (Condition x r) = Condition x (remove a r)
-- Partially evaluate a PG using a truth-teller (compute a 'projection')
project :: TruthTeller p -> PGPredicate p v -> PGPredicate p v
project t = mapP (evaluate t)
-- Linearise a PG into a list. Returns Nothing if the given expression
-- cannot be uniquely evaluated due to remaining parameters.
-- Overlay subexpressions are evaluated in arbitrary order.
......@@ -60,3 +43,4 @@ linearise (Condition x r) = case tellTruth x of
Just True -> linearise r
Just False -> Just []
Nothing -> Nothing
......@@ -20,6 +20,7 @@ import Oracles.Option
-- GhcPkg Stage0 is the bootstrapping GhcPkg
-- GhcPkg StageN, N > 0, is the one built on stage 0 (TODO: need only Stage1?)
-- TODO: add Cpp and Haddock builders
-- TODO: rename Gcc to Cc?
data Builder = Ar
| Ld
| Alex
......
......@@ -6,7 +6,11 @@ module Settings (
) where
import Base
import Expression
import Ways
import Oracles.Builder
import Expression.Base
import Expression.Predicate
import Expression.PGPredicate
data IntegerLibrary = IntegerGmp | IntegerGmp2 | IntegerSimple
......@@ -22,35 +26,110 @@ integerLibraryName = case integerLibrary of
buildHaddock :: Bool
buildHaddock = True
supportsPackageKey :: Guard
supportsPackageKey = keyYes "supports-package-key"
whenPackageKey :: Guard
whenPackageKey = supportsPackageKey <> notStage Stage0
whenPackageKey = supportsPackageKey `And` notStage Stage0
depSettings :: Settings
depSettings =
packageSettings :: Settings
packageSettings =
opts ["-hide-all-packages", "-no-user-package-db", "-include-pkg-deps"]
<>
stage Stage0 ? opts ["-package-db libraries/bootstrapping.conf"]
<>
whenPackageKey ?
ite whenPackageKey
(packageKey "-this-package-key" <> packageDepKeys "-package-key")
(packageKey "-package-name" <> packageDeps "-package" )
librarySettings :: Ways -> Settings
librarySettings ways =
ite (whenExists vanilla ways)
(opt "--enable-library-vanilla")
(opt "--disable-library-vanilla")
<>
ite (ghcWithInterpreter
`And` (Not dynamicGhcPrograms)
`And` whenExists vanilla ways)
(opt "--enable-library-for-ghci")
(opt "--disable-library-for-ghci")
<>
ite (whenExists profiling ways)
(opt "--enable-library-profiling")
(opt "--disable-library-profiling")
<>
(Not $ whenPackageKey) ?
(packageKey "-package-name" <> packageDeps "-package")
--packageArgs :: Stage -> FilePath -> Args
--packageArgs stage pathDist = do
-- usePackageKey <- SupportsPackageKey || stage /= Stage0
-- args [ arg "-hide-all-packages"
-- , arg "-no-user-package-db"
-- , arg "-include-pkg-deps"
-- , when (stage == Stage0) $
-- arg "-package-db libraries/bootstrapping.conf"
-- , if usePackageKey
-- then productArgs ["-this-package-key"] [arg $ PackageKey pathDist]
-- <> productArgs ["-package-key" ] [args $ DepKeys pathDist]
-- else productArgs ["-package-name" ] [arg $ PackageKey pathDist]
-- <> productArgs ["-package" ] [args $ Deps pathDist]
-- ]
ite (whenExists dynamic ways)
(opt "--enable-shared")
(opt "--disable-shared")
ccSettings :: Settings
ccSettings = mempty
ldSettings :: Settings
ldSettings = mempty
cppSettings :: Settings
cppSettings = mempty
configureSettings :: Settings
configureSettings =
let conf key = subSettings $ "--configure-option=" ++ key ++ "="
ccSettings' = remove ["-Werror"] ccSettings
in
mconcat [ conf "CFLAGS" ccSettings'
, conf "LDFLAGS" ldSettings
, conf "CPPFLAGS" cppSettings
, subSettings "--gcc-options=" $ ccSettings' <> ldSettings
, conf "--with-iconv-includes" $ optKeyValue "iconv-include-dirs"
, conf "--with-iconv-libraries" $ optKeyValue "iconv-lib-dirs"
, conf "--with-gmp-includes" $ optKeyValue "gmp-include-dirs"
, conf "--with-gmp-libraries" $ optKeyValue "gmp-lib-dirs"
-- TODO: why TargetPlatformFull and not host?
, crossCompiling ?
conf "--host" (optKeyValue "target-platform-full")
, conf "--with-cc" $ optStagedBuilder 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 = opt ""
-- customConfArgs
customConfigureSettings :: Settings
customConfigureSettings = mempty
-- bootPackageDb
bootPackageDbSettings :: Settings
bootPackageDbSettings =
stage Stage0 ?
optPath "--package-db="
(optKeyValue "ghc-source-path" <> opt "libraries/bootstrapping.conf")
cabalSettings :: Settings
cabalSettings =
opt "configure"
`fence` optBuildPath
`fence` optBuildDist
`fence` dllSettings
`fence` mconcat
[ optStagedBuilder Ghc -- TODO: used to be limited to max stage1 GHC
, optStagedBuilder GhcPkg
, customConfigureSettings
, bootPackageDbSettings
, librarySettings targetWays
, keyNonEmpty "hscolour" ? optBuilder HsColour -- TODO: more reuse
, configureSettings
, stage Stage0 ? optBootPkgConstraints
, optStagedBuilder Gcc
, notStage Stage0 ? optBuilder Ld
, optBuilder Ar
, optBuilder Alex
, optBuilder Happy ] -- TODO: reorder with's
ghcPkgSettings :: Settings
ghcPkgSettings =
opt "update"
`fence` mconcat
[ opt "--force"
, optPath "" $
mconcat [optBuildPath, optBuildDist, opt "inplace-pkg-config"]
, bootPackageDbSettings ]
{-# LANGUAGE NoImplicitPrelude #-}
module Targets (
targetPackages, targetPackagesInStage
targetPackages, targetPackagesInStage,
targetWays
) where
import Package.Base
import Settings
import Expression.Base
-- These are the packages we build:
-- TODO: this should eventually be removed and replaced by the top-level
-- target, i.e. GHC (and perhaps, something else)
targetPackages :: [Package]
targetPackages =
[ library "array" [ Stage1]
, library "base" [ Stage1] `customise` baseTraits
, library "bin-package-db" [Stage0, Stage1]
, library "binary" [Stage0, Stage1]
, library "bytestring" [ Stage1]
, library "Cabal/Cabal" [Stage0, Stage1] `customise` cabalTraits
, library "containers" [ Stage1]
, library "deepseq" [ Stage1]
, library "directory" [ Stage1]
, library "filepath" [ Stage1]
, library "ghc-prim" [ Stage1] `customise` ghcPrimTraits
, library "haskeline" [ Stage1]
, library "hoopl" [Stage0, Stage1]
, library "hpc" [Stage0, Stage1]
, library integerLibraryName [ Stage1] `customise` intLibTraits
, library "parallel" [ Stage1]
, library "pretty" [ Stage1]
, library "primitive" [ Stage1]
, library "process" [ Stage1]
, library "stm" [ Stage1]
, library "template-haskell" [ Stage1]
, library "terminfo" [Stage0, Stage1] `customise` terminfoTraits
, library "time" [ Stage1]
, library "transformers" [Stage0, Stage1]
, library "unix" [ Stage1] `customise` unixTraits
, library "Win32" [ Stage1] `customise` win32Traits
, library "xhtml" [ Stage1] `customise` xhtmlTraits
]
targetPackages = [deepseq]
--[ library "array" [ Stage1]
--, library "base" [ Stage1] `customise` baseTraits
--, library "bin-package-db" [Stage0, Stage1]
--, library "binary" [Stage0, Stage1]
--, library "bytestring" [ Stage1]
--, library "Cabal/Cabal" [Stage0, Stage1] `customise` cabalTraits
--, library "containers" [ Stage1]
--, library "deepseq" [ Stage1]
--, library "directory" [ Stage1]
--, library "filepath" [ Stage1]
--, library "ghc-prim" [ Stage1] `customise` ghcPrimTraits
--, library "haskeline" [ Stage1]
--, library "hoopl" [Stage0, Stage1]
--, library "hpc" [Stage0, Stage1]
--, library integerLibraryName [ Stage1] `customise` intLibTraits
--, library "parallel" [ Stage1]
--, library "pretty" [ Stage1]
--, library "primitive" [ Stage1]
--, library "process" [ Stage1]
--, library "stm" [ Stage1]
--, library "template-haskell" [ Stage1]
--, library "terminfo" [Stage0, Stage1] `customise` terminfoTraits
--, library "time" [ Stage1]
--, library "transformers" [Stage0, Stage1]
--, library "unix" [ Stage1] `customise` unixTraits
--, library "Win32" [ Stage1] `customise` win32Traits
--, library "xhtml" [ Stage1] `customise` xhtmlTraits
--]
baseTraits :: Package -> Package
baseTraits = updateSettings (\settings ->
settings { customConfArgs = arg $ "--flags=" ++ integerLibraryName })
-- Package definitions:
deepseq :: Package
deepseq = library "deepseq" [Stage1]
-- see Note [Cabal package weirdness]
cabalTraits :: Package -> Package
cabalTraits (Package name path cabal todo) = Package name path "Cabal" todo
--baseTraits :: Package -> Package
--baseTraits = updateSettings (\settings ->
-- settings { customConfArgs = arg $ "--flags=" ++ integerLibraryName })
ghcPrimTraits :: Package -> Package
ghcPrimTraits = updateSettings (\settings ->
settings { customConfArgs = arg "--flag=include-ghc-prim" })