Commit cb2003ce authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Continue major refactoring for expression-based build system.

parent 21b789ea
......@@ -6,19 +6,24 @@ module Expression.Base (
(?), (??), whenExists,
Args (..), -- hide?
Settings,
Packages,
FilePaths,
Ways,
remove, project,
arg, args, argsOrdered, argPairs, argBuildPath, argBuildDist,
argConfig, argBuilderPath, argStagedBuilderPath,
argPackageKey, argPackageDeps, argPackageDepKeys,
argComplex, argPath, argBootPkgConstraints,
project,
arg, args, argsOrdered, argBuildPath, argBuildDir,
argInput, argOutput,
argConfig, argConfigStaged, argBuilderPath, argStagedBuilderPath,
argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
argIncludeDirs, argDepIncludeDirs,
argConcat, argConcatPath, argPairs, argPrefix,
argBootPkgConstraints,
setPackage, setBuilder, setBuilderFamily, setStage, setWay,
setFile, setConfig
) where
import Base hiding (arg, args, Args)
import Ways
import Package.Base (Package)
import Package (Package)
import Oracles.Builder
import Expression.PG
import Expression.Predicate
......@@ -26,95 +31,116 @@ import Expression.Build
-- Settings can be built out of the following primitive elements
data Args
= Plain [String] -- an (ordered) list of arguments: ["-i", "dir"]
| Pairs String [String] -- resolves to a list of pairs: "-i dir1 -i dir2"
| BuildPath -- evaluates to build path: libraries/base
| BuildDist -- evaluates to build subdirectory: dist-install
| Config String -- evaluates to the value of a given config key
| BuilderPath Builder -- evaluates to the path to a given builder
| PackageKey String -- looks up "PACKAGE_KEY" in package-data.mk
| PackageDeps String -- looks up "DEPS" in package-data.mk
| PackageDepKeys String -- looks up "DEP_KEYS" in package-data.mk
| BootPkgConstraints -- evaluates to boot package constraints
| Complex String Settings -- joins a prefix with settings: "CFLAGS=..."
| Path String Settings -- as above but joins settings elements with </>
type Settings = BuildExpression Args
type Ways = BuildExpression Way
= 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
| ConfigStaged String -- as above, but stage is appended to the key
| BuilderPath Builder -- evaluates to the path to a given builder
| PackageData String -- looks up value a given key in package-data.mk
| BootPkgConstraints -- evaluates to boot package constraints
| Pair Combine Args Args -- combine two Args using a given append method
| Fold Combine Settings -- fold settings using a given combine method
-- Assume original settings structure: (a `op1` b `op2` c ...)
data Combine = Concat -- Concatenate all: a ++ b ++ c ...
| ConcatPath -- </>-concatenate all: a </> b </> c ...
type Ways = BuildExpression Way
type Settings = BuildExpression Args
type Packages = BuildExpression Package
type FilePaths = BuildExpression FilePath
-- A single argument
arg :: String -> Settings
arg s = Vertex $ Plain [s]
arg = return . Plain
-- A set of arguments (unordered)
args :: [String] -> Settings
args = mconcat . map arg
args = msum . map arg
-- An (ordered) list of arguments
argsOrdered :: [String] -> Settings
argsOrdered = Vertex . Plain
argsOrdered = mproduct . map arg
-- An (ordered) list of pair of arguments: [prefix, arg1, prefix, arg2, ...]
argPairs :: String -> [String] -> Settings
argPairs prefix = Vertex . Pairs prefix
argBuildPath :: Settings
argBuildPath = return BuildPath
argBuildDist :: Settings
argBuildPath = Vertex $ BuildPath
argBuildDir :: Settings
argBuildDir = return BuildDir
argBuildPath :: Settings
argBuildDist = Vertex $ BuildDist
argInput :: Settings
argInput = return Input
argOutput :: Settings
argOutput = return Output
argConfig :: String -> Settings
argConfig = Vertex . Config
argConfig = return . Config
argConfigStaged :: String -> Settings
argConfigStaged = return . ConfigStaged
argBuilderPath :: Builder -> Settings
argBuilderPath = Vertex . BuilderPath
argBuilderPath = return . BuilderPath
-- evaluates to the path to a given builder, taking current stage into account
argStagedBuilderPath :: (Stage -> Builder) -> Settings
argStagedBuilderPath f =
mconcat $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
-- Accessing key value pairs from package-data.mk files
argPackageKey :: Settings
argPackageKey = return $ PackageData "PACKAGE_KEY"
argPackageDeps :: Settings
argPackageDeps = return $ PackageData "DEPS"
argPackageKey :: String -> Settings
argPackageKey = Vertex . PackageKey
argPackageDepKeys :: Settings
argPackageDepKeys = return $ PackageData "DEP_KEYS"
argPackageDeps :: String -> Settings
argPackageDeps = Vertex . PackageDeps
argSrcDirs :: Settings
argSrcDirs = return $ PackageData "HS_SRC_DIRS"
argPackageDepKeys :: String -> Settings
argPackageDepKeys = Vertex . PackageDepKeys
argIncludeDirs :: Settings
argIncludeDirs = return $ PackageData "INCLUDE_DIRS"
argDepIncludeDirs :: Settings
argDepIncludeDirs = return $ PackageData "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
argBootPkgConstraints :: Settings
argBootPkgConstraints = Vertex $ BootPkgConstraints
argBootPkgConstraints = return BootPkgConstraints
-- A concatenation of arguments: arg1 ++ arg2 ++ ...
argConcat :: Settings -> Settings
argConcat = return . Fold Concat
-- A </>-concatenation of arguments: arg1 </> arg2 </> ...
argConcatPath :: Settings -> Settings
argConcatPath = return . Fold ConcatPath
argComplex :: String -> Settings -> Settings
argComplex prefix = Vertex . Complex prefix
-- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
argPairs :: String -> Settings -> Settings
argPairs prefix settings = settings >>= (arg prefix |>) . return
argPath :: String -> Settings -> Settings
argPath prefix = Vertex . Path prefix
-- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
argPrefix :: String -> Settings -> Settings
argPrefix prefix = fmap (Pair Concat $ Plain prefix)
-- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
argPaths :: String -> Settings -> Settings
argPaths prefix = fmap (Pair ConcatPath $ Plain prefix)
-- Partially evaluate Settings using a truth-teller (compute a 'projection')
project :: (BuildVariable -> Maybe Bool) -> Settings -> Settings
project _ Epsilon = Epsilon
project t (Vertex v) = case v of
Complex l r -> argComplex l (project t r)
Path l r -> argPath l (project t r)
_ -> Vertex v
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)
-- Removes a given argument list from settings
remove :: [String] -> Settings -> Settings
remove _ Epsilon = Epsilon
remove as v @ (Vertex (Plain bs))
| as == bs = Epsilon
| otherwise = v
remove _ v @ (Vertex _) = v
remove as (Overlay l r) = Overlay (remove as l) (remove as r)
remove as (Sequence l r) = Sequence (remove as l) (remove as r)
remove as (Condition x r) = Condition x (remove as r)
-- Partial evaluation of settings
setPackage :: Package -> Settings -> Settings
......
......@@ -5,7 +5,7 @@ module Expression.Build (
BuildPredicate (..),
BuildExpression (..),
evaluate, tellTruth,
singleton, fence, linearise,
linearise, msum, mproduct, fromList, fromOrderedList,
packages, package, matchPackage,
builders, builder, matchBuilder, matchBuilderFamily,
stages, stage, notStage, matchStage,
......@@ -13,15 +13,15 @@ module Expression.Build (
files, file, matchFile,
configValues, config, configYes, configNo, configNonEmpty, matchConfig,
supportsPackageKey, targetPlatforms, targetPlatform,
targetOss, targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
platformSupportsSharedLibs, crossCompiling
targetOss, targetOs, targetArchs, dynamicGhcPrograms, ghcWithInterpreter,
platformSupportsSharedLibs, crossCompiling,
gccIsClang, gccLt46, windowsHost
) where
import Data.Monoid
import Control.Applicative
import Base
import Ways
import Package.Base (Package)
import Package (Package)
import Oracles.Builder
import Expression.PG
......@@ -55,18 +55,6 @@ alternatives f = foldr (||) false . map (variable . f)
type BuildExpression v = PG BuildPredicate v
singleton :: v -> BuildExpression v
singleton = Vertex
-- Monoid instance for combining arguments when order does not matter.
instance Monoid (BuildExpression v) where
mempty = Epsilon
mappend = Overlay
-- Insert a fence between two build expressions (for positional arguments)
fence :: BuildExpression v -> BuildExpression v -> BuildExpression v
fence = Sequence
-- 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.
......@@ -209,6 +197,9 @@ 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"
......@@ -236,3 +227,12 @@ ghcWithInterpreter =
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"]
......@@ -2,9 +2,14 @@
module Expression.PG (
module Expression.Predicate,
PG (..), (?), (??), whenExists
PG (..), (|>), (?), (??), whenExists,
msum, mproduct,
fromList, fromOrderedList
) where
import Data.Functor
import Control.Monad
import Control.Applicative
import Expression.Predicate
-- A generic Parameterised Graph datatype
......@@ -16,15 +21,53 @@ data PG p v = Epsilon
| Sequence (PG p v) (PG p v)
| Condition p (PG p v)
instance Functor (PG p) where
fmap = liftM
instance Applicative (PG p) where
pure = return
(<*>) = ap
instance Monad (PG p) where
return = Vertex
Epsilon >>= _ = Epsilon
Vertex v >>= f = f v
Overlay l r >>= f = Overlay (l >>= f) (r >>= f)
Sequence l r >>= f = Sequence (l >>= f) (r >>= f)
Condition l r >>= f = Condition l (r >>= f)
instance MonadPlus (PG p) where
mzero = Epsilon
mplus = Overlay
instance Alternative (PG p) where
empty = Epsilon
(<|>) = Overlay
(|>) :: PG p v -> PG p v -> PG p v
(|>) = Sequence
mproduct :: [PG p v] -> PG p v
mproduct = foldr (|>) Epsilon
fromList :: [v] -> PG p v
fromList = msum . map return
fromOrderedList :: [v] -> PG p v
fromOrderedList = mproduct . map return
infixl 7 |>
(?) :: p -> PG p v -> PG p v
(?) = Condition
infixl 7 ?
infixl 8 ?
(??) :: Predicate p => p -> (PG p v, PG p v) -> PG p v
(??) p (t, f) = Overlay (p ? t) (not p ? f)
infixl 7 ??
infixl 8 ??
-- Given a vertex and a PG return a predicate, which tells when the vertex
-- exists in the PG.
......
......@@ -2,9 +2,10 @@ import Base
import Config
import Oracles
import Package
import Targets
main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do
oracleRules
autoconfRules
oracleRules
autoconfRules
configureRules
packageRules
--packageRules
module Package (packageRules) where
module Package (Package, library, setCabal) where
import Package.Base
import Package.Data
import Package.Compile
import Package.Library
import Package.Dependencies
import Targets
import Base
import Util
-- Rule buildPackageX is defined in module Package.X
buildPackage :: Package -> TodoItem -> Rules ()
buildPackage = buildPackageData
<> buildPackageDependencies
<> buildPackageCompile
<> buildPackageLibrary
-- 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"
}
packageRules :: Rules ()
packageRules = do
-- TODO: control targets from command line arguments
instance Eq Package where
(==) = (==) `on` pkgName
-- The package list (targetPackages) is defined in Targets.hs
forM_ targetPackages $ \pkg @ (Package name path _ todo) -> do
forM_ todo $ \todoItem @ (stage, dist, settings) -> do
libraryPackage :: String -> String -> Package
libraryPackage name cabalName =
Package
name
(unifyPath $ "libraries" </> name)
cabalName
-- 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
library :: String -> Package
library name = libraryPackage name (name <.> "cabal")
-- Build rules for the package
buildPackage pkg todoItem
setCabal :: Package -> FilePath -> Package
setCabal pkg cabalName = pkg { pkgCabal = cabalName }
......@@ -4,9 +4,9 @@ module Package.Base (
module Ways,
module Util,
module Oracles,
Package (..), Settings (..), TodoItem (..),
defaultSettings, library, customise, updateSettings,
commonCcArgs, commonLdArgs, commonCppArgs, commonCcWarninigArgs,
-- Package (..), Settings (..), TodoItem (..),
-- defaultSettings, library, customise, updateSettings,
-- commonCcArgs, commonLdArgs, commonCppArgs, commonCcWarninigArgs,
pathArgs, packageArgs,
includeGccArgs, includeGhcArgs, pkgHsSources,
pkgDepHsObjects, pkgLibHsObjects, pkgCObjects,
......@@ -20,137 +20,45 @@ import Base
import Ways
import Util
import Oracles
import Settings
import qualified System.Directory as S
data Settings = Settings
{
customConfArgs :: Args, -- custom args for configure
customCcArgs :: Args, -- custom args for Gcc
customLdArgs :: Args, -- custom args for Ld
customCppArgs :: Args, -- custom args for C preprocessor
customDllArgs :: Args, -- custom dll args
registerPackage :: Bool, -- do we need to call ghc-pkg update?
ways :: Action [Way], -- ways to build
buildWhen :: Condition -- skip the package if need be, e.g.
} -- don't build unix on Windows
defaultSettings :: Stage -> Settings
defaultSettings stage = Settings
{
customConfArgs = mempty,
customCcArgs = mempty,
customLdArgs = mempty, -- currently not used
customCppArgs = mempty, -- currently not used
customDllArgs = mempty, -- only for compiler
registerPackage = True,
ways = defaultWays stage,
buildWhen = return True
}
-- Stage is the stage of the GHC that we use to build the package
-- FilePath is the directory to put the build results (relative to pkgPath)
-- The typical structure of that directory is:
-- * build/ : contains compiled object code
-- * doc/ : produced by haddock
-- * package-data.mk : contains output of ghc-cabal applied to pkgCabal.cabal
-- Settings may be different for different combinations of Stage & FilePath
-- TODO: the above may be incorrect, settings seem to *only* depend on the
-- stage. In fact Stage seem to define FilePath and Settings, therefore we
-- can drop the TodoItem and replace it by [Stage] and two functions
-- * distDirectory :: Package -> Stage -> FilePath
-- * settings :: Package -> Stage -> Settings
type TodoItem = (Stage, FilePath, Settings)
-- pkgPath is the path to the source code relative to the root
data Package = Package
{
pkgName :: String, -- For example: "deepseq"
pkgPath :: FilePath, -- "libraries/deepseq"
pkgCabal :: FilePath, -- "deepseq"
pkgTodo :: [TodoItem] -- [(Stage1, "dist-install", defaultSettings)]
}
instance Eq Package where
(==) = (==) `on` pkgName
updateSettings :: (Settings -> Settings) -> Package -> Package
updateSettings update (Package name path cabal todo) =
Package name path cabal (map updateTodo todo)
where
updateTodo (stage, filePath, settings) = (stage, filePath, update settings)
customise :: Package -> (Package -> Package) -> Package
customise = flip ($)
libraryPackage :: String -> String -> [Stage] -> (Stage -> Settings) -> Package
libraryPackage name cabalName stages settings =
Package
name
(unifyPath $ "libraries" </> name)
cabalName
[ (stage
, if stage == Stage0 then "dist-boot" else "dist-install"
, settings stage)
| stage <- stages ]
library :: String -> [Stage] -> Package
library name stages = libraryPackage name name stages defaultSettings
commonCcArgs :: Args
commonCcArgs = when Validating $ args ["-Werror", "-Wall"]
commonLdArgs :: Args
commonLdArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
commonCppArgs :: Args
commonCppArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
commonCcWarninigArgs :: Args
commonCcWarninigArgs = when Validating $
args [ when GccIsClang $ arg "-Wno-unknown-pragmas"
, when (not GccIsClang && not GccLt46) $ arg "-Wno-error=inline"
, when (GccIsClang && not GccLt46 && windowsHost) $
arg "-Werror=unused-but-set-variable" ]
pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
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]
]
includeGccArgs :: FilePath -> FilePath -> Args
includeGccArgs path dist =
let pathDist = path </> dist
autogen = pathDist </> "build/autogen"
in args [ arg $ "-I" ++ unifyPath autogen
, pathArgs "-I" path $ IncludeDirs pathDist
, pathArgs "-I" path $ DepIncludeDirs pathDist ]
--pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
--pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
prefixedPath :: String -> [Settings] -> Settings
prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
--includeGccArgs :: FilePath -> FilePath -> Args
--includeGccArgs path dist =
-- let pathDist = path </> dist
-- autogen = pathDist </> "build/autogen"
-- in args [ arg $ "-I" ++ unifyPath autogen
-- , pathArgs "-I" path $ IncludeDirs pathDist
-- , pathArgs "-I" path $ DepIncludeDirs pathDist ]
includeGccSettings :: Settings
includeGccSettings = mconcat
[ prefixedPath "-I" [argBuildPath, argBuildDir, arg "build", arg "autogen"]
, argPrefix "-I" $ argPaths ...
, prefixedPath "-I" [argBuildPath, argIncludeDirs ] -- wrong
, prefixedPath "-I" [argBuildPath, argDepIncludeDirs ]]
includeGhcSettings :: Settings
includeGhcSettings =
let buildDir = argBuildPath `fence` argSrcDirs
in arg "-i" `fence`
mconcat
[ argPathList "-i" [argBuildPath, argSrcDirs]
, argPath "-i" buildDir
, argPath "-I" buildDir
, argPathList "-i" [buildDir, arg "autogen"]
, argPathList "-I" [buildDir, arg "autogen"]
, argPathList "-I" [argBuildPath, argIncludeDirs]
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, argPathList "-optP" [buildDir, arg "autogen/cabal_macros.h"] ]
includeGhcArgs :: FilePath -> FilePath -> Args
includeGhcArgs path dist =
let pathDist = path </> dist
buildDir = unifyPath $ pathDist </> "build"
in args [ arg "-i"
, pathArgs "-i" path $ SrcDirs pathDist
, concatArgs ["-i", "-I"]
[buildDir, unifyPath $ buildDir </> "autogen"]
, pathArgs "-I" path $ IncludeDirs pathDist
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, concatArgs ["-optP"]
[unifyPath $ buildDir </> "autogen/cabal_macros.h"]
]
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
pkgHsSources path dist = do
......
module Package (Package, library, setCabal, packageRules) where
--import Package.Base