Commit 4ad4d412 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Implement buildPackageData rule.

parent 8bdc64cc
......@@ -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
......
{-# 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)
{-# 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
......@@ -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" ]
||