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

Add PartialTarget, handle GHC.Prim module in a special way.

parent 228da6fe
{-# LANGUAGE FlexibleInstances #-}
module Expression (
module Target,
module Data.Monoid,
module Control.Monad.Reader,
Expr, DiffExpr, fromDiffExpr,
......@@ -8,19 +7,18 @@ module Expression (
Args, Ways, Packages,
apply, append, appendM, remove,
appendSub, appendSubD, filterSub, removeSub,
interpret, interpretDiff,
interpret, interpretPartial, interpretWithStage, interpretDiff,
getStage, getPackage, getBuilder, getFiles, getFile,
getSources, getSource, getWay
) where
import Way
import Base
import Util
import Stage
import Builder
import Package
import Target (Target)
import Target hiding (Target(..))
import qualified Target
import Target (Target (..), PartialTarget (..), fromPartial)
import Data.List
import Data.Monoid
import Control.Monad.Reader hiding (liftIO)
......@@ -136,6 +134,13 @@ removeSub prefix xs = filterSub prefix (`notElem` xs)
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
interpretPartial :: PartialTarget -> Expr a -> Action a
interpretPartial = interpret . fromPartial
interpretWithStage :: Stage -> Expr a -> Action a
interpretWithStage s = interpretPartial $
PartialTarget s (error "interpretWithStage: package not set")
-- Extract an expression from a difference expression
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
......@@ -146,36 +151,40 @@ interpretDiff target = interpret target . fromDiffExpr
-- Convenient getters for target parameters
getStage :: Expr Stage
getStage = asks Target.stage
getStage = asks stage
getPackage :: Expr Package
getPackage = asks Target.package
getPackage = asks package
getBuilder :: Expr Builder
getBuilder = asks Target.builder
getBuilder = asks builder
getWay :: Expr Way
getWay = asks Target.way
getWay = asks way
getSources :: Expr [FilePath]
getSources = asks Target.sources
getSources = asks sources
-- Run getSources and check that the result contains a single file only
getSource :: Expr FilePath
getSource = do
target <- ask
srcs <- getSources
case srcs of
[src] -> return src
_ -> error $ "Exactly one source expected in target " ++ show target
getSingleton getSources $
"getSource: exactly one source expected in target " ++ show target
getFiles :: Expr [FilePath]
getFiles = asks Target.files
getFiles = asks files
-- Run getFiles and check that it contains a single file only
-- Run getFiles and check that the result contains a single file only
getFile :: Expr FilePath
getFile = do
target <- ask
files <- getFiles
case files of
getSingleton getFiles $
"getFile: exactly one file expected in target " ++ show target
getSingleton :: Expr [a] -> String -> Expr a
getSingleton expr msg = do
list <- expr
case list of
[res] -> return res
_ -> error $ "Exactly one file expected in target " ++ show target
_ -> lift $ putError msg
......@@ -23,7 +23,7 @@ newtype ArgsHashKey = ArgsHashKey Target
-- constructors are assumed not to examine target sources, but only append them
-- to argument lists where appropriate.
-- TODO: enforce the above assumption via type trickery?
checkArgsHash :: FullTarget -> Action ()
checkArgsHash :: Target -> Action ()
checkArgsHash target = do
_ <- askOracle . ArgsHashKey $ target { sources = ["src"] } :: Action Int
return ()
......
......@@ -6,6 +6,7 @@ import Way
import Base
import Util
import Stage
import Target (PartialTarget (..))
import Expression
import Oracles.PackageData
import Rules.Cabal
......@@ -23,18 +24,18 @@ import Settings.TargetDirectory
generateTargets :: Rules ()
generateTargets = action $ do
targets <- fmap concat . forM [Stage0 ..] $ \stage -> do
pkgs <- interpret (stageTarget stage) getPackages
pkgs <- interpretWithStage stage getPackages
fmap concat . forM pkgs $ \pkg -> do
let target = stagePackageTarget stage pkg
let target = PartialTarget stage pkg
buildPath = targetPath stage pkg -/- "build"
libName <- interpret target $ getPkgData LibName
needGhciLib <- interpret target $ getPkgData BuildGhciLib
needHaddock <- interpret target buildHaddock
libName <- interpretPartial target $ getPkgData LibName
needGhciLib <- interpretPartial target $ getPkgData BuildGhciLib
needHaddock <- interpretPartial target buildHaddock
let ghciLib = [ buildPath -/- "HS" ++ libName <.> "o"
| needGhciLib == "YES" && stage /= Stage0 ]
haddock = [ pkgHaddockFile pkg | needHaddock ]
ways <- interpret target getWays
ways <- interpretPartial target getWays
libs <- forM ways $ \way -> do
extension <- libsuf way
return $ buildPath -/- "libHS" ++ libName <.> extension
......@@ -47,6 +48,6 @@ generateTargets = action $ do
packageRules :: Rules ()
packageRules = do
resources <- resourceRules
forM_ [Stage0, Stage1] $ \stage -> do
forM_ knownPackages $ \pkg -> do
buildPackage resources (stagePackageTarget stage pkg)
forM_ [Stage0, Stage1] $ \stage ->
forM_ knownPackages $ \pkg ->
buildPackage resources $ PartialTarget stage pkg
module Rules.Actions (
build, buildWithResources
) where
module Rules.Actions (build, buildWithResources) where
import Base
import Util
import Target hiding (builder)
import qualified Target
import Builder
import Expression
import qualified Target
import Oracles.Setting
import Oracles.ArgsHash
import Settings.Args
......@@ -16,7 +15,7 @@ import Settings.Builders.Ar
-- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last
-- built (that is, track changes in the build system).
buildWithResources :: [(Resource, Int)] -> FullTarget -> Action ()
buildWithResources :: [(Resource, Int)] -> Target -> Action ()
buildWithResources rs target = do
let builder = Target.builder target
needBuilder laxDependencies builder
......@@ -39,7 +38,7 @@ buildWithResources rs target = do
unit . cmd [path] $ persistentArgs ++ argsChunk
-- Most targets are built without explicitly acquiring resources
build :: FullTarget -> Action ()
build :: Target -> Action ()
build = buildWithResources []
interestingInfo :: Builder -> [String] -> [String]
......
......@@ -16,7 +16,7 @@ cabalRules :: Rules ()
cabalRules = do
-- Cache boot package constraints (to be used in cabalArgs)
bootPackageConstraints %> \out -> do
pkgs <- interpret (stageTarget Stage0) getPackages
pkgs <- interpretWithStage Stage0 getPackages
constraints <- forM (sort pkgs) $ \pkg -> do
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
......@@ -28,7 +28,7 @@ cabalRules = do
-- Cache package dependencies
packageDependencies %> \out -> do
pkgs <- interpret (stageTarget Stage1) getPackages
pkgs <- interpretWithStage Stage1 getPackages
pkgDeps <- forM (sort pkgs) $ \pkg -> do
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
......
......@@ -4,18 +4,15 @@ import Way
import Base
import Util
import Builder
import Expression
import qualified Target
import Target (PartialTarget (..), fullTarget, fullTargetWithWay)
import Oracles.Dependencies
import Settings.TargetDirectory
import Rules.Actions
import Rules.Resources
compilePackage :: Resources -> StagePackageTarget -> Rules ()
compilePackage _ target = do
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
compilePackage :: Resources -> PartialTarget -> Rules ()
compilePackage _ target @ (PartialTarget stage package) = do
let path = targetPath stage package
buildPath = path -/- "build"
matchBuildResult buildPath "hi" ?> \hi ->
......
......@@ -2,11 +2,11 @@ module Rules.Data (buildPackageData) where
import Base
import Util
import Target (PartialTarget (..), fullTarget)
import Package
import Builder
import Switches (registerPackage)
import Expression
import qualified Target
import Oracles.PackageDeps
import Settings.Packages
import Settings.TargetDirectory
......@@ -17,11 +17,9 @@ import Control.Applicative
import Control.Monad.Extra
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: Resources -> StagePackageTarget -> Rules ()
buildPackageData rs target = do
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
buildPackageData :: Resources -> PartialTarget -> Rules ()
buildPackageData rs target @ (PartialTarget stage pkg) = do
let path = targetPath stage pkg
cabalFile = pkgCabalFile pkg
configure = pkgPath pkg -/- "configure"
......@@ -40,7 +38,7 @@ buildPackageData rs target = do
-- We configure packages in the order of their dependencies
deps <- packageDeps pkg
pkgs <- interpret target getPackages
pkgs <- interpretPartial target getPackages
let cmp p name = compare (pkgName p) name
depPkgs = intersectOrd cmp (sort pkgs) deps
need [ targetPath stage p -/- "package-data.mk" | p <- depPkgs ]
......@@ -50,7 +48,7 @@ buildPackageData rs target = do
fullTarget target GhcCabal [cabalFile] outs
-- TODO: find out of ghc-cabal can be concurrent with ghc-pkg
whenM (interpret target registerPackage) .
whenM (interpretPartial target registerPackage) .
buildWithResources [(ghcPkg rs, 1)] $
fullTarget target (GhcPkg stage) [cabalFile] outs
......
......@@ -5,18 +5,16 @@ import Util
import Builder
import Package
import Expression
import qualified Target
import Target (PartialTarget (..), fullTarget)
import Oracles.PackageData
import Settings.Util
import Settings.TargetDirectory
import Rules.Actions
import Rules.Resources
buildPackageDependencies :: Resources -> StagePackageTarget -> Rules ()
buildPackageDependencies _ target =
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
buildPackageDependencies :: Resources -> PartialTarget -> Rules ()
buildPackageDependencies _ target @ (PartialTarget stage pkg) =
let path = targetPath stage pkg
buildPath = path -/- "build"
dropBuild = (pkgPath pkg ++) . drop (length buildPath)
hDepFile = buildPath -/- ".hs-dependencies"
......@@ -27,7 +25,7 @@ buildPackageDependencies _ target =
build $ fullTarget target (GccM stage) [srcFile] [out]
hDepFile %> \file -> do
srcs <- interpret target getPackageSources
srcs <- interpretPartial target getPackageSources
need srcs
build $ fullTarget target (GhcM stage) srcs [file]
removeFile $ file <.> "bak"
......
......@@ -7,7 +7,7 @@ import Builder
import Package
import Expression
import Oracles.PackageData
import qualified Target
import Target (PartialTarget (..), fullTarget, fullTargetWithWay)
import Settings.TargetDirectory
import Rules.Actions
import Rules.Resources
......@@ -19,11 +19,9 @@ import Control.Monad.Extra
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
-- files in the Shake databases seems fragile and unnecesarry.
buildPackageDocumentation :: Resources -> StagePackageTarget -> Rules ()
buildPackageDocumentation _ target =
let stage = Target.stage target
pkg = Target.package target
cabalFile = pkgCabalFile pkg
buildPackageDocumentation :: Resources -> PartialTarget -> Rules ()
buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
let cabalFile = pkgCabalFile pkg
haddockFile = pkgHaddockFile pkg
in when (stage == Stage1) $ do
......@@ -31,8 +29,8 @@ buildPackageDocumentation _ target =
whenM (specified HsColour) $ do
need [cabalFile]
build $ fullTarget target GhcCabalHsColour [cabalFile] []
srcs <- interpret target getPackageSources
deps <- interpret target $ getPkgDataList DepNames
srcs <- interpretPartial target getPackageSources
deps <- interpretPartial target $ getPkgDataList DepNames
let haddocks = [ pkgHaddockFile depPkg
| Just depPkg <- map findKnownPackage deps ]
need $ srcs ++ haddocks
......
module Rules.Library (buildPackageLibrary) where
import Way
import Base
import Base hiding (splitPath)
import Util
import Target (PartialTarget (..), fullTarget)
import Builder
import Package
import Switches
import Switches (splitObjects)
import Expression
import qualified Target
import Oracles.PackageData
import Settings.Util
import Settings.TargetDirectory
......@@ -16,21 +16,18 @@ import Rules.Resources
import Data.List
import qualified System.Directory as IO
buildPackageLibrary :: Resources -> StagePackageTarget -> Rules ()
buildPackageLibrary _ target = do
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
buildPackageLibrary :: Resources -> PartialTarget -> Rules ()
buildPackageLibrary _ target @ (PartialTarget stage pkg) = do
let path = targetPath stage pkg
buildPath = path -/- "build"
-- TODO: handle dynamic libraries
matchBuildResult buildPath "a" ?> \a -> do
removeFile a
cSrcs <- interpret target $ getPkgDataList CSrcs
modules <- interpret target $ getPkgDataList Modules
cSrcs <- cSources target
hSrcs <- hSources target
let way = detectWay a
hSrcs = map (replaceEq '.' '/') modules
cObjs = [ buildPath -/- src -<.> osuf way | src <- cSrcs ]
hObjs = [ buildPath -/- src <.> osuf way | src <- hSrcs ]
......@@ -38,7 +35,7 @@ buildPackageLibrary _ target = do
-- explicitly as this would needlessly bloat the Shake database).
need $ cObjs ++ hObjs
split <- interpret target splitObjects
split <- interpretPartial target splitObjects
splitObjs <- if not split then return [] else
fmap concat $ forM hSrcs $ \src -> do
let splitPath = buildPath -/- src ++ "_" ++ osuf way ++ "_split"
......@@ -48,7 +45,7 @@ buildPackageLibrary _ target = do
build $ fullTarget target Ar (cObjs ++ hObjs ++ splitObjs) [a]
synopsis <- interpret target $ getPkgData Synopsis
synopsis <- interpretPartial target $ getPkgData Synopsis
putSuccess $ "/--------\n| Successfully built package library '"
++ pkgName pkg
++ "' (stage " ++ show stage ++ ", way "++ show way ++ ")."
......@@ -58,10 +55,18 @@ buildPackageLibrary _ target = do
-- TODO: this looks fragile as haskell objects can match this rule if their
-- names start with "HS" and they are on top of the module hierarchy.
priority 2 $ (buildPath -/- "HS*.o") %> \obj -> do
cSrcs <- interpret target $ getPkgDataList CSrcs
modules <- interpret target $ getPkgDataList Modules
let hSrcs = map (replaceEq '.' '/') modules
cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs ]
cSrcs <- cSources target
hSrcs <- hSources target
let cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs ]
hObjs = [ buildPath -/- src <.> "o" | src <- hSrcs ]
need $ cObjs ++ hObjs
build $ fullTarget target Ld (cObjs ++ hObjs) [obj]
cSources :: PartialTarget -> Action [FilePath]
cSources target = interpretPartial target $ getPkgDataList CSrcs
hSources :: PartialTarget -> Action [FilePath]
hSources target = do
modules <- interpretPartial target $ getPkgDataList Modules
-- GHC.Prim is special: we do not build it
return . map (replaceEq '.' '/') . filter (/= "GHC.Prim") $ modules
module Rules.Package (buildPackage) where
import Base
import Target
import Expression
import Rules.Data
import Rules.Compile
......@@ -9,7 +10,7 @@ import Rules.Resources
import Rules.Dependencies
import Rules.Documentation
buildPackage :: Resources -> StagePackageTarget -> Rules ()
buildPackage :: Resources -> PartialTarget -> Rules ()
buildPackage = mconcat
[ buildPackageData
, buildPackageDependencies
......
{-# LANGUAGE DeriveGeneric, FlexibleInstances #-}
module Target (
Target (..), StageTarget, StagePackageTarget, FullTarget,
stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay,
Target (..), PartialTarget (..),
fromPartial, fullTarget, fullTargetWithWay,
) where
import Way
......@@ -38,43 +38,28 @@ instance Monoid a => Monoid (ReaderT Target Action a) where
mempty = return mempty
mappend = liftM2 mappend
-- StageTarget is a partially constructed Target. Only stage is guaranteed to
-- be assigned.
type StageTarget = Target
-- PartialTarget is a partially constructed Target with fields Stage and
-- Package only. PartialTarget's are used for generating build rules.
data PartialTarget = PartialTarget Stage Package
stageTarget :: Stage -> StageTarget
stageTarget s = Target
{
stage = s,
package = error "stageTarget: package not set",
builder = error "stageTarget: builder not set",
way = vanilla,
sources = error "stageTarget: sources not set",
files = error "stageTarget: files not set"
}
-- StagePackageTarget is a partially constructed Target. Only stage and package
-- are guaranteed to be assigned.
type StagePackageTarget = Target
stagePackageTarget :: Stage -> Package -> StagePackageTarget
stagePackageTarget s p = Target
-- Convert PartialTarget to Target assuming that unknown fields won't be used.
fromPartial :: PartialTarget -> Target
fromPartial (PartialTarget s p) = Target
{
stage = s,
package = p,
builder = error "stagePackageTarget: builder not set",
way = vanilla,
sources = error "stagePackageTarget: sources not set",
files = error "stagePackageTarget: files not set"
builder = error "fromPartial: builder not set",
way = error "fromPartial: way not set",
sources = error "fromPartial: sources not set",
files = error "fromPartial: files not set"
}
-- FullTarget is a Target whose fields are all assigned
type FullTarget = Target
-- Most targets are built only one way, vanilla, hence we set it by default.
fullTarget :: StagePackageTarget -> Builder -> [FilePath] -> [FilePath] -> FullTarget
fullTarget target b srcs fs = target
fullTarget :: PartialTarget -> Builder -> [FilePath] -> [FilePath] -> Target
fullTarget (PartialTarget s p) b srcs fs = Target
{
stage = s,
package = p,
builder = b,
way = vanilla,
sources = srcs,
......@@ -82,16 +67,10 @@ fullTarget target b srcs fs = target
}
-- Use this function to be explicit about the build way.
fullTargetWithWay :: StagePackageTarget -> Builder -> Way -> [FilePath] -> [FilePath] -> FullTarget
fullTargetWithWay target b w srcs fs = target
{
builder = b,
way = w,
sources = srcs,
files = fs
}
fullTargetWithWay :: PartialTarget -> Builder -> Way -> [FilePath] -> [FilePath] -> Target
fullTargetWithWay pt b w srcs fs = (fullTarget pt b srcs fs) { way = w }
-- Instances for storing in the Shake database
instance Binary FullTarget
instance NFData FullTarget
instance Hashable FullTarget
instance Binary Target
instance NFData Target
instance Hashable Target
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