Commit 48e8b6f2 authored by Andrey Mokhov's avatar Andrey Mokhov

Factor out generic build infrastructure

See #347
parent 81fecb8b
......@@ -26,6 +26,8 @@ executable hadrian
, Expression
, Flavour
, GHC
, Hadrian.Expression
, Hadrian.Target
, Oracles.ArgsHash
, Oracles.Config
, Oracles.Config.Flag
......
{-# LANGUAGE DeriveFunctor, FlexibleInstances, LambdaCase #-}
module Expression (
-- * Expressions
Expr, expr, exprIO,
-- ** Operators
append, arg, remove,
Expr, Predicate, Args, Ways, Packages,
-- ** Construction and modification
expr, exprIO, append, arg, remove, (?),
-- ** Evaluation
interpret, interpretInContext,
-- ** Predicates
Predicate, (?), applyPredicate,
-- ** Common expressions
Args, Ways, Packages,
-- ** Context and Target
Context, vanillaContext, stageContext, Target, dummyTarget,
Context, vanillaContext, stageContext, Target,
-- * Convenient accessors
getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
......@@ -26,11 +24,11 @@ module Expression (
module Way
) where
import Control.Monad.Trans.Reader
import Control.Monad.Trans
import Data.Semigroup
import Base
import qualified Hadrian.Expression as H
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Builder
import Context
import Package
......@@ -44,38 +42,13 @@ import Oracles.Path
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
newtype Expr a = Expr (ReaderT Target Action a) deriving Functor
expr :: Action a -> Expr a
expr = Expr . lift
exprIO :: IO a -> Expr a
exprIO = Expr . liftIO
instance Semigroup a => Semigroup (Expr a) where
Expr x <> Expr y = Expr $ (<>) <$> x <*> y
-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance (Semigroup a, Monoid a) => Monoid (Expr a) where
mempty = pure mempty
mappend = (<>)
instance Applicative Expr where
pure = Expr . pure
(<*>) = ap
instance Monad Expr where
return = pure
Expr e >>= f = Expr $ do
re <- e
let Expr rf = f re
rf
type Expr a = H.Expr Context Builder a
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
type Predicate = Expr Bool
type Args = Expr [String]
type Predicate = H.Predicate Context Builder
type Args = H.Args Context Builder
type Packages = Expr [Package]
type Ways = Expr [Way]
......@@ -85,88 +58,17 @@ type Ways = Expr [Way]
append :: a -> Expr a
append = pure
-- | Remove given elements from a list expression.
remove :: Eq a => [a] -> Expr [a] -> Expr [a]
remove xs e = filter (`notElem` xs) <$> e
-- | Apply a predicate to an expression.
applyPredicate :: (Monoid a, Semigroup a) => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
bool <- predicate
if bool then expr else mempty
-- | Add a single argument to 'Args'.
arg :: String -> Args
arg = append . return
-- | A convenient operator for predicate application.
class PredicateLike a where
(?) :: (Monoid m, Semigroup m) => a -> Expr m -> Expr m
infixr 3 ?
instance PredicateLike Predicate where
(?) = applyPredicate
instance PredicateLike Bool where
(?) = applyPredicate . Expr . return
instance PredicateLike (Action Bool) where
(?) = applyPredicate . expr
-- | Interpret a given expression according to the given 'Target'.
interpret :: Target -> Expr a -> Action a
interpret target (Expr e) = runReaderT e target
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext :: Context -> Expr a -> Action a
interpretInContext = interpret . dummyTarget
-- | Get the current build 'Context'.
getContext :: Expr Context
getContext = Expr $ asks context
-- | Get the 'Stage' of the current 'Context'.
getStage :: Expr Stage
getStage = Expr $ stage <$> asks context
getStage = stage <$> getContext
-- | Get the 'Package' of the current 'Context'.
getPackage :: Expr Package
getPackage = Expr $ package <$> asks context
getPackage = package <$> getContext
-- | Get the 'Way' of the current 'Context'.
getWay :: Expr Way
getWay = Expr $ way <$> asks context
-- | Get the 'Builder' for the current 'Target'.
getBuilder :: Expr Builder
getBuilder = Expr $ asks builder
-- | Get the input files of the current 'Target'.
getInputs :: Expr [FilePath]
getInputs = Expr $ asks inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput :: Expr FilePath
getInput = Expr $ do
target <- ask
getSingleton ("Exactly one input file expected in " ++ show target) <$> asks inputs
-- | Get the files produced by the current 'Target'.
getOutputs :: Expr [FilePath]
getOutputs = Expr $ asks outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput :: Expr FilePath
getOutput = Expr $ do
target <- ask
getSingleton ("Exactly one output file expected in " ++ show target) <$> asks outputs
-- | Extract a value from a singleton list, or raise an error if the list does
-- not contain exactly one value.
getSingleton :: String -> [a] -> a
getSingleton _ [res] = res
getSingleton msg _ = error msg
getWay = way <$> getContext
getSetting :: Setting -> Expr String
getSetting = expr . setting
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Hadrian.Expression (
-- * Expressions
Expr, Predicate, Args,
-- ** Construction and modification
expr, exprIO, arg, remove, (?),
-- ** Evaluation
interpret, interpretInContext,
-- * Convenient accessors
getContext, getBuilder, getOutputs, getInputs, getInput, getOutput, getSingleton
) where
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Data.Semigroup
import Development.Shake
import Hadrian.Target
-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
newtype Expr c b a = Expr (ReaderT (Target c b) Action a)
deriving (Applicative, Functor, Monad)
instance Semigroup a => Semigroup (Expr c b a) where
Expr x <> Expr y = Expr $ (<>) <$> x <*> y
-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where
mempty = pure mempty
mappend = (<>)
-- | Expressions that compute a Boolean value.
type Predicate c b = Expr c b Bool
-- | Expressions that compute lists of arguments to be passed to builders.
type Args c b = Expr c b [String]
-- | Lift actions independent from the current build 'Target' into the 'Expr'
-- monad.
expr :: Action a -> Expr c b a
expr = Expr . lift
-- | Lift IO computations independent from the current build 'Target' into the
-- 'Expr' monad.
exprIO :: IO a -> Expr c b a
exprIO = Expr . liftIO
-- | Remove given elements from a list expression.
remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a]
remove xs e = filter (`notElem` xs) <$> e
-- | Add a single argument to 'Args'.
arg :: String -> Args c b
arg = pure . pure
-- | Values that can be converted to a 'Predicate'.
class ToPredicate p c b where
toPredicate :: p -> Predicate c b
infixr 3 ?
-- | Apply a predicate to an expression.
(?) :: (Monoid a, Semigroup a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a
p ? e = do
bool <- toPredicate p
if bool then e else mempty
instance ToPredicate (Predicate c b) c b where
toPredicate = id
instance ToPredicate Bool c b where
toPredicate = pure
instance ToPredicate (Action Bool) c b where
toPredicate = expr
-- | Interpret a given expression according to the given 'Target'.
interpret :: Target c b -> Expr c b a -> Action a
interpret target (Expr e) = runReaderT e target
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext :: c -> Expr c b a -> Action a
interpretInContext c = interpret $ target c
(error "contextOnlyTarget: builder not set")
(error "contextOnlyTarget: inputs not set" )
(error "contextOnlyTarget: outputs not set")
-- | Get the current build 'Context'.
getContext :: Expr c b c
getContext = Expr $ asks context
-- | Get the 'Builder' for the current 'Target'.
getBuilder :: Expr c b b
getBuilder = Expr $ asks builder
-- | Get the input files of the current 'Target'.
getInputs :: Expr c b [FilePath]
getInputs = Expr $ asks inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput :: (Show b, Show c) => Expr c b FilePath
getInput = Expr $ do
target <- ask
getSingleton ("Exactly one input file expected in " ++ show target) <$> asks inputs
-- | Get the files produced by the current 'Target'.
getOutputs :: Expr c b [FilePath]
getOutputs = Expr $ asks outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput :: (Show b, Show c) => Expr c b FilePath
getOutput = Expr $ do
target <- ask
getSingleton ("Exactly one output file expected in " ++ show target) <$> asks outputs
-- | Extract a value from a singleton list, or raise an error if the list does
-- not contain exactly one value.
getSingleton :: String -> [a] -> a
getSingleton _ [res] = res
getSingleton msg _ = error msg
{-# LANGUAGE DeriveGeneric #-}
module Hadrian.Target (Target, target, context, builder, inputs, outputs) where
import GHC.Generics
import Base
-- | Each invocation of a builder is fully described by a 'Target', which
-- comprises a build context (type variable @c@), a builder (type variable @b@),
-- a list of input files and a list of output files. For example:
--
-- @
-- preludeTarget = Target (GHC.Context) (GHC.Builder)
-- { context = Context Stage1 base profiling
-- , builder = Ghc Stage1
-- , inputs = ["libraries/base/Prelude.hs"]
-- , outputs = ["build/stage1/libraries/base/Prelude.p_o"] }
-- @
data Target c b = Target
{ context :: c -- ^ Current build context
, builder :: b -- ^ Builder to be invoked
, inputs :: [FilePath] -- ^ Input files for the builder
, outputs :: [FilePath] -- ^ Files to be produced
} deriving (Eq, Generic, Show)
target :: c -> b -> [FilePath] -> [FilePath] -> Target c b
target = Target
instance (Binary c, Binary b) => Binary (Target c b)
instance (Hashable c, Hashable b) => Hashable (Target c b)
instance (NFData c, NFData b) => NFData (Target c b)
......@@ -21,10 +21,10 @@ newtype ArgsHashKey = ArgsHashKey Target
-- argument list constructors are assumed not to examine target sources, but
-- only append them to argument lists where appropriate.
checkArgsHash :: Target -> Action ()
checkArgsHash target = do
let hashed = [ show . hash $ inputs target ]
_ <- askOracle . ArgsHashKey $ target { inputs = hashed } :: Action Int
return ()
checkArgsHash t = do
let hashedInputs = [ show $ hash (inputs t) ]
hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
void (askOracle $ ArgsHashKey hashedTarget :: Action Int)
-- | Oracle for storing per-target argument list hashes.
argsHashOracle :: Rules ()
......
......@@ -19,13 +19,13 @@ compilePackage rs context@Context {..} = do
let src = obj2src context obj
need [src]
needDependencies context src $ obj <.> "d"
build $ Target context (compiler stage) [src] [obj]
build $ target context (compiler stage) [src] [obj]
compileHs = \[obj, _hi] -> do
(src, deps) <- fileDependencies context obj
need $ src : deps
when (isLibrary package) $ need =<< return <$> pkgConfFile context
needLibrary =<< contextDependencies context
buildWithResources rs $ Target context (Ghc CompileHs stage) [src] [obj]
buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
priority 2.0 $ do
nonHs "c" %> compile (Ghc CompileCWithGhc) (obj2src "c" isGeneratedCFile )
......@@ -43,7 +43,7 @@ needDependencies :: Context -> FilePath -> FilePath -> Action ()
needDependencies context@Context {..} src depFile = discover
where
discover = do
build $ Target context (Cc FindCDependencies stage) [src] [depFile]
build $ target context (Cc FindCDependencies stage) [src] [depFile]
deps <- parseFile depFile
-- Generated dependencies, if not yet built, will not be found and hence
-- will be referred to simply by their file names.
......
......@@ -29,7 +29,7 @@ configureRules = do
let srcs = map (<.> "in") outs
context = vanillaContext Stage0 compiler
need srcs
build $ Target context (Configure ".") srcs outs
build $ target context (Configure ".") srcs outs
["configure", configH <.> "in"] &%> \_ -> do
if cmdSkipConfigure
......
......@@ -33,7 +33,7 @@ buildPackageData context@Context {..} = do
need =<< mapM pkgConfFile =<< contextDependencies context
need [cabalFile]
build $ Target context GhcCabal [cabalFile] [mk, setupConfig]
build $ target context GhcCabal [cabalFile] [mk, setupConfig]
postProcessPackageData context mk
pkgInplaceConfig context %> \conf -> do
......@@ -41,7 +41,7 @@ buildPackageData context@Context {..} = do
if package == rts
then do
need [rtsConfIn]
build $ Target context HsCpp [rtsConfIn] [conf]
build $ target context HsCpp [rtsConfIn] [conf]
fixFile conf $ unlines
. map
( replace "\"\"" ""
......
......@@ -21,7 +21,7 @@ buildPackageDependencies rs context@Context {..} =
if srcs == []
then writeFileChanged mk ""
else buildWithResources rs $
Target context (Ghc FindHsDependencies stage) srcs [mk]
target context (Ghc FindHsDependencies stage) srcs [mk]
removeFile $ mk <.> "bak"
mkDeps <- readFile' mk
writeFileChanged deps . unlines
......
......@@ -33,7 +33,7 @@ buildPackageDocumentation context@Context {..} =
-- Build Haddock documentation
-- TODO: pass the correct way from Rules via Context
let haddockWay = if dynamicGhcPrograms flavour then dynamic else vanilla
build $ Target (context {way = haddockWay}) Haddock srcs [file]
build $ target (context {way = haddockWay}) Haddock srcs [file]
when (package == haddock) $ haddockHtmlLib %> \_ -> do
let dir = takeDirectory haddockHtmlLib
......
......@@ -109,7 +109,7 @@ generatePackageCode context@(Context stage pkg _) =
let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
(src, builder) <- unpack <$> findGenerator context file
need [src]
build $ Target context builder [src] [file]
build $ target context builder [src] [file]
let boot = src -<.> "hs-boot"
whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
......@@ -121,7 +121,7 @@ generatePackageCode context@(Context stage pkg _) =
when (pkg == compiler) $ do
primopsTxt stage %> \file -> do
need $ [platformH stage, primopsSource] ++ includesDependencies
build $ Target context HsCpp [primopsSource] [file]
build $ target context HsCpp [primopsSource] [file]
platformH stage %> go generateGhcBootPlatformH
......@@ -131,10 +131,10 @@ generatePackageCode context@(Context stage pkg _) =
, "GHC/PrimopWrappers.hs"
, "*.hs-incl" ] |%> \file -> do
need [primopsTxt stage]
build $ Target context GenPrimopCode [primopsTxt stage] [file]
build $ target context GenPrimopCode [primopsTxt stage] [file]
when (pkg == rts) $ path -/- "cmm/AutoApply.cmm" %> \file ->
build $ Target context GenApply [] [file]
build $ target context GenApply [] [file]
copyRules :: Rules ()
copyRules = do
......@@ -161,7 +161,7 @@ generateRules = do
-- TODO: simplify, get rid of fake rts context
generatedPath ++ "//*" %> \file -> do
withTempDir $ \dir -> build $
Target rtsContext DeriveConstants [] [file, dir]
target rtsContext DeriveConstants [] [file, dir]
where
file <~ gen = file %> \out -> generate out emptyTarget gen
......
......@@ -43,13 +43,13 @@ gmpRules = do
putBuild "| No GMP library/framework detected; in tree GMP will be built"
need [gmpLibrary]
createDirectory gmpObjects
build $ Target gmpContext (Ar Stage1) [gmpLibrary] [gmpObjects]
build $ target gmpContext (Ar Stage1) [gmpLibrary] [gmpObjects]
copyFile (gmpBuildPath -/- "gmp.h") header
copyFile (gmpBuildPath -/- "gmp.h") gmpLibraryInTreeH
-- Build in-tree GMP library
gmpLibrary %> \lib -> do
build $ Target gmpContext (Make gmpBuildPath) [gmpMakefile] [lib]
build $ target gmpContext (Make gmpBuildPath) [gmpMakefile] [lib]
putSuccess "| Successfully built custom library 'gmp'"
-- In-tree GMP header is built in the gmpLibraryH rule
......@@ -64,7 +64,7 @@ gmpRules = do
env <- configureEnvironment
need [mk <.> "in"]
buildWithCmdOptions env $
Target gmpContext (Configure gmpBuildPath) [mk <.> "in"] [mk]
target gmpContext (Configure gmpBuildPath) [mk <.> "in"] [mk]
-- Extract in-tree GMP sources and apply patches
gmpMakefile <.> "in" %> \_ -> do
......@@ -79,7 +79,7 @@ gmpRules = do
withTempDir $ \dir -> do
let tmp = unifyPath dir
need [tarball]
build $ Target gmpContext Tar [tarball] [tmp]
build $ target gmpContext Tar [tarball] [tmp]
let patch = gmpBase -/- "gmpsrc.patch"
patchName = takeFileName patch
......
......@@ -135,7 +135,7 @@ installPackageConf :: Action ()
installPackageConf = do
let context = vanillaContext Stage0 rts
liftIO $ IO.createDirectoryIfMissing True (takeDirectory pkgConfInstallPath)
build $ Target context HsCpp [ pkgPath rts -/- "package.conf.in" ]
build $ target context HsCpp [ pkgPath rts -/- "package.conf.in" ]
[ pkgConfInstallPath <.> "raw" ]
Stdout content <- cmd "grep" [ "-v", "^#pragma GCC"
, pkgConfInstallPath <.> "raw" ]
......@@ -206,7 +206,7 @@ installPackages = do
installDistDir (installDistDir -/- "build")
whenM (isSpecified HsColour) $
build $ Target context GhcCabalHsColour [cabalFile] []
build $ target context GhcCabalHsColour [cabalFile] []
pref <- setting InstallPrefix
unit $ cmd ghcCabalInplace [ "copy"
......@@ -282,7 +282,7 @@ installLibsTo libs dir = do
installData [out] dir
let context = vanillaContext Stage0 $ topLevel (PackageName "")
-- TODO: Get rid of meaningless context for certain builder like ranlib
build $ Target context Ranlib [out] [out]
build $ target context Ranlib [out] [out]
_ -> installData [lib] dir
-- ref: includes/ghc.mk
......
......@@ -49,7 +49,7 @@ libffiRules = do
copyFile (ffiIncludeDir -/- file) (rtsBuildPath -/- file)
putSuccess $ "| Successfully copied system FFI library header files"
else do
build $ Target libffiContext (Make libffiBuildPath) [] []
build $ target libffiContext (Make libffiBuildPath) [] []
hs <- getDirectoryFiles "" [libffiBuildPath -/- "inst/lib/*/include/*"]
forM_ hs $ \header ->
......@@ -72,7 +72,7 @@ libffiRules = do
removeDirectory (buildRootPath -/- libname)
-- TODO: Simplify.
actionFinally (do
build $ Target libffiContext Tar [tarball] [buildRootPath]
build $ target libffiContext Tar [tarball] [buildRootPath]
moveDirectory (buildRootPath -/- libname) libffiBuildPath) $
removeFiles buildRootPath [libname <//> "*"]
......@@ -86,4 +86,4 @@ libffiRules = do
env <- configureEnvironment
buildWithCmdOptions env $
Target libffiContext (Configure libffiBuildPath) [mk <.> "in"] [mk]
target libffiContext (Configure libffiBuildPath) [mk <.> "in"] [mk]
......@@ -50,7 +50,7 @@ buildDynamicLib context@Context{..} = do
deps <- contextDependencies context
need =<< mapM pkgLibraryFile deps
objs <- libraryObjects context
build $ Target context (Ghc LinkHs stage) objs [so]
build $ target context (Ghc LinkHs stage) objs [so]
buildPackageLibrary :: Context -> Rules ()
buildPackageLibrary context@Context {..} = do
......@@ -61,8 +61,8 @@ buildPackageLibrary context@Context {..} = do
asuf <- libsuf way
let isLib0 = ("//*-0" ++ asuf) ?== a
removeFile a
if isLib0 then build $ Target context (Ar stage) [] [a] -- TODO: Scan for dlls
else build $ Target context (Ar stage) objs [a]
if isLib0 then build $ target context (Ar stage) [] [a] -- TODO: Scan for dlls
else build $ target context (Ar stage) objs [a]
synopsis <- interpretInContext context $ getPkgData Synopsis
unless isLib0 . putSuccess $ renderLibrary
......@@ -75,7 +75,7 @@ buildPackageGhciLibrary context@Context {..} = priority 2 $ do
matchVersionedFilePath libPrefix (waySuffix way <.> "o") ?> \obj -> do
objs <- allObjects context
need objs
build $ Target context Ld objs [obj]
build $ target context Ld objs [obj]
allObjects :: Context -> Action [FilePath]
allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
......
......@@ -104,7 +104,7 @@ buildBinary rs context@Context {..} bin = do
++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
++ [ path -/- "Paths_haddock.o" | package == haddock ]
need binDeps
buildWithResources rs $ Target context (Ghc LinkHs stage) binDeps [bin]
buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
synopsis <- interpretInContext context $ getPkgData Synopsis
putSuccess $ renderProgram
(quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
......
......@@ -19,11 +19,11 @@ registerPackage rs context@Context {..} = when (stage <= Stage1) $ do
matchVersionedFilePath (dir -/- pkgNameString package) "conf" ?> \conf -> do
need [confIn]
buildWithResources rs $
Target context (GhcPkg Update stage) [confIn] [conf]
target context (GhcPkg Update stage) [confIn] [conf]
when (package == ghc) $ packageDbStamp stage %> \stamp -> do
removeDirectory dir
buildWithResources rs $
Target (vanillaContext stage ghc) (GhcPkg Init stage) [] [dir]
target (vanillaContext stage ghc) (GhcPkg Init stage) [] [dir]
writeFileLines stamp []
putSuccess $ "| Successfully initialised " ++ dir
......@@ -24,7 +24,7 @@ testRules = do