summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hadrian/src/Rules.hs19
-rw-r--r--hadrian/src/Rules/Dependencies.hs39
-rw-r--r--hadrian/src/Rules/Documentation.hs49
-rw-r--r--hadrian/src/Rules/Program.hs111
-rw-r--r--hadrian/src/Rules/Register.hs90
-rw-r--r--hadrian/src/Settings/Default.hs9
6 files changed, 213 insertions, 104 deletions
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index 0e55087b7d..69a151c206 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -95,15 +95,12 @@ packageRules = do
writePackageDb = [(packageDb, maxConcurrentReaders)]
Rules.Compile.compilePackage readPackageDb
+ Rules.Dependencies.buildPackageDependencies readPackageDb
+ Rules.Documentation.buildPackageDocumentation
+ Rules.Program.buildProgramRules readPackageDb
+ Rules.Register.configurePackageRules
- Rules.Program.buildProgram readPackageDb
-
- forM_ [Stage0 .. ] $ \stage ->
- -- we create a dummy context, that has the correct state, but contains
- -- @dummyPackage@ as a... dummy package. The package isn't accessed but the record
- -- need to be set properly. @undefined@ is not an option as it ends up
- -- being forced.
- Rules.Register.registerPackage writePackageDb (Context stage dummyPackage vanilla)
+ forM_ [Stage0, Stage1] (Rules.Register.registerPackageRules writePackageDb)
-- TODO: Can we get rid of this enumeration of contexts? Since we iterate
-- over it to generate all 4 types of rules below, all the time, we
@@ -111,11 +108,7 @@ packageRules = do
-- Rules.Compile and Rules.Library could save us some time there.
let vanillaContexts = liftM2 vanillaContext allStages knownPackages
- forM_ vanillaContexts $ mconcat
- [ Rules.Register.configurePackage
- , Rules.Dependencies.buildPackageDependencies readPackageDb
- , Rules.Documentation.buildPackageDocumentation
- , Rules.Generate.generatePackageCode ]
+ forM_ vanillaContexts Rules.Generate.generatePackageCode
buildRules :: Rules ()
buildRules = do
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
index 9589d12aa0..8b09a82b56 100644
--- a/hadrian/src/Rules/Dependencies.hs
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -6,25 +6,33 @@ import Data.Function
import Base
import Context
import Expression
+import Hadrian.BuildPath
import Oracles.ModuleFiles
import Rules.Generate
+import Settings.Default
import Target
import Utilities
-buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
-buildPackageDependencies rs context@Context {..} = do
+import qualified Text.Parsec as Parsec
+
+buildPackageDependencies :: [(Resource, Int)] -> Rules ()
+buildPackageDependencies rs = do
root <- buildRootRules
- root -/- contextDir context -/- ".dependencies.mk" %> \mk -> do
+ root -/- "**/.dependencies.mk" %> \mk -> do
+ depfile <- getDepMkFile root mk
+ context <- depMkFileContext depfile
srcs <- hsSources context
need srcs
orderOnly =<< interpretInContext context generatedDependencies
if null srcs
then writeFileChanged mk ""
else buildWithResources rs $
- target context (Ghc FindHsDependencies stage) srcs [mk]
+ target context
+ (Ghc FindHsDependencies $ Context.stage context)
+ srcs [mk]
removeFile $ mk <.> "bak"
- root -/- contextDir context -/- ".dependencies" %> \deps -> do
+ root -/- "**/.dependencies" %> \deps -> do
mkDeps <- readFile' (deps <.> "mk")
writeFileChanged deps . unlines
. map (\(src, deps) -> unwords $ src : deps)
@@ -33,3 +41,24 @@ buildPackageDependencies rs context@Context {..} = do
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst)
$ parseMakefile mkDeps
+
+
+data DepMkFile = DepMkFile Stage FilePath
+ deriving (Eq, Show)
+
+parseDepMkFile :: FilePath -> Parsec.Parsec String () DepMkFile
+parseDepMkFile root = do
+ _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+ stage <- parseStage
+ _ <- Parsec.char '/'
+ pkgPath <- Parsec.manyTill Parsec.anyChar
+ (Parsec.try $ Parsec.string "/.dependencies.mk")
+ return (DepMkFile stage pkgPath)
+
+getDepMkFile :: FilePath -> FilePath -> Action DepMkFile
+getDepMkFile root = parsePath (parseDepMkFile root) "<dependencies file>"
+
+depMkFileContext :: DepMkFile -> Action Context
+depMkFileContext (DepMkFile stage pkgpath) = do
+ pkg <- getPackageByPath pkgpath
+ return (Context stage pkg vanilla)
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
index 963bc4c5a0..f1a7454fbb 100644
--- a/hadrian/src/Rules/Documentation.hs
+++ b/hadrian/src/Rules/Documentation.hs
@@ -6,6 +6,7 @@ module Rules.Documentation (
haddockDependencies
) where
+import Hadrian.BuildPath
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
@@ -21,6 +22,7 @@ import Target
import Utilities
import Data.List (union)
+import qualified Text.Parsec as Parsec
docRoot :: FilePath
docRoot = "docs"
@@ -138,26 +140,28 @@ allHaddocks :: Action [FilePath]
allHaddocks = do
pkgs <- stagePackages Stage1
sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg
- | pkg <- pkgs, isLibrary pkg ]
+ | pkg <- pkgs, isLibrary pkg, pkgName pkg /= "rts" ]
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'docRoot' subdirectory. Pedantically tracking all
-- built files in the Shake database seems fragile and unnecessary.
-buildPackageDocumentation :: Context -> Rules ()
-buildPackageDocumentation context@Context {..} = when (stage == Stage1 && package /= rts) $ do
+buildPackageDocumentation :: Rules ()
+buildPackageDocumentation = do
root <- buildRootRules
-- Per-package haddocks
- root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt" %> \file -> do
+ root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do
+ ctx <- getPkgDocTarget root file >>= pkgDocContext
need [root -/- haddockHtmlLib]
-- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files.
- syn <- pkgSynopsis package
- desc <- pkgDescription package
+ syn <- pkgSynopsis (Context.package ctx)
+ desc <- pkgDescription (Context.package ctx)
let prologue = if null desc then syn else desc
liftIO $ writeFile file prologue
- root -/- htmlRoot -/- "libraries" -/- pkgName package -/- pkgName package <.> "haddock" %> \file -> do
- need [root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt"]
+ root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do
+ context <- getPkgDocTarget root file >>= pkgDocContext
+ need [ takeDirectory file -/- "haddock-prologue.txt"]
haddocks <- haddockDependencies context
-- `ghc-prim` has a source file for 'GHC.Prim' which is generated just
@@ -176,6 +180,35 @@ buildPackageDocumentation context@Context {..} = when (stage == Stage1 && packag
let haddockWay = if dynamicPrograms then dynamic else vanilla
build $ target (context {way = haddockWay}) (Haddock BuildPackage) srcs [file]
+data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName
+ deriving (Eq, Show)
+
+pkgDocContext :: PkgDocTarget -> Action Context
+pkgDocContext target = case findPackageByName pkgname of
+ Nothing -> error $ "pkgDocContext: couldn't find package " ++ pkgname
+ Just p -> return (Context Stage1 p vanilla)
+
+ where pkgname = case target of
+ DotHaddock n -> n
+ HaddockPrologue n -> n
+
+parsePkgDocTarget :: FilePath -> Parsec.Parsec String () PkgDocTarget
+parsePkgDocTarget root = do
+ _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+ _ <- Parsec.string (htmlRoot ++ "/")
+ _ <- Parsec.string "libraries/"
+ pkgname <- Parsec.manyTill Parsec.anyChar (Parsec.char '/')
+ Parsec.choice
+ [ Parsec.try (Parsec.string "haddock-prologue.txt")
+ *> pure (HaddockPrologue pkgname)
+ , Parsec.string (pkgname <.> "haddock")
+ *> pure (DotHaddock pkgname)
+ ]
+
+getPkgDocTarget :: FilePath -> FilePath -> Action PkgDocTarget
+getPkgDocTarget root path =
+ parsePath (parsePkgDocTarget root) "<doc target>" path
+
-------------------------------------- PDF -------------------------------------
-- | Build all PDF documentation
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index aeed0268f8..316cc44fb5 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -1,4 +1,4 @@
-module Rules.Program (buildProgram) where
+module Rules.Program (buildProgramRules) where
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
@@ -15,62 +15,71 @@ import Target
import Utilities
-- | TODO: Drop code duplication
-buildProgram :: [(Resource, Int)] -> Rules ()
-buildProgram rs = do
+buildProgramRules :: [(Resource, Int)] -> Rules ()
+buildProgramRules rs = do
root <- buildRootRules
forM_ [Stage0 ..] $ \stage ->
[ root -/- stageString stage -/- "bin" -/- "*"
, root -/- stageString stage -/- "lib/bin" -/- "*" ] |%> \bin -> do
- -- This is quite inefficient, but we can't access 'programName' from
- -- 'Rules', because it is an 'Action' depending on an oracle.
- sPackages <- filter isProgram <$> stagePackages stage
- tPackages <- testsuitePackages
- -- TODO: Shall we use Stage2 for testsuite packages instead?
- let allPackages = sPackages
- ++ if stage == Stage1 then tPackages else []
- nameToCtxList <- fmap concat . forM allPackages $ \pkg -> do
- -- the iserv pkg results in three different programs at
- -- the moment, ghc-iserv (built the vanilla way),
- -- ghc-iserv-prof (built the profiling way), and
- -- ghc-iserv-dyn (built the dynamic way).
- -- The testsuite requires all to be present, so we
- -- make sure that we cover these
- -- "prof-build-under-other-name" cases.
- -- iserv gets its names from Packages.hs:programName
- let allCtxs = [ vanillaContext stage pkg
- , Context stage pkg profiling
- , Context stage pkg dynamic
- ]
- forM allCtxs $ \ctx -> do
- name <- programName ctx
- return (name <.> exe, ctx)
+ programContexts <- getProgramContexts stage
+ case lookupProgramContext bin programContexts of
+ Nothing -> error $ "Unknown program " ++ show bin
+ Just ctx -> buildProgram bin ctx rs
- case lookup (takeFileName bin) nameToCtxList of
- Nothing -> error $ "Unknown program " ++ show bin
- Just ctx@(Context {..}) -> do
- -- Custom dependencies: this should be modeled better in the
- -- Cabal file somehow.
- -- TODO: Is this still needed? See 'runtimeDependencies'.
- when (package == hsc2hs) $ do
- -- 'Hsc2hs' needs the @template-hsc.h@ file.
- template <- templateHscPath stage
- need [template]
- when (package == ghc) $ do
- -- GHC depends on @settings@, @platformConstants@,
- -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
- -- @llvm-passes@.
- need =<< ghcDeps stage
+getProgramContexts :: Stage -> Action [(FilePath, Context)]
+getProgramContexts stage = do
+ -- This is quite inefficient, but we can't access 'programName' from
+ -- 'Rules', because it is an 'Action' depending on an oracle.
+ sPackages <- filter isProgram <$> stagePackages stage
+ tPackages <- testsuitePackages
+ -- TODO: Shall we use Stage2 for testsuite packages instead?
+ let allPackages = sPackages
+ ++ if stage == Stage1 then tPackages else []
+ fmap concat . forM allPackages $ \pkg -> do
+ -- the iserv pkg results in three different programs at
+ -- the moment, ghc-iserv (built the vanilla way),
+ -- ghc-iserv-prof (built the profiling way), and
+ -- ghc-iserv-dyn (built the dynamic way).
+ -- The testsuite requires all to be present, so we
+ -- make sure that we cover these
+ -- "prof-build-under-other-name" cases.
+ -- iserv gets its names from Packages.hs:programName
+ let allCtxs = [ vanillaContext stage pkg
+ , Context stage pkg profiling
+ , Context stage pkg dynamic
+ ]
+ forM allCtxs $ \ctx -> do
+ name <- programName ctx
+ return (name <.> exe, ctx)
- cross <- flag CrossCompiling
- -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
- case (cross, stage) of
- (True, s) | s > Stage0 -> do
- srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
- copyFile (srcDir -/- takeFileName bin) bin
- (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
- srcDir <- stageLibPath Stage0 <&> (-/- "bin")
- copyFile (srcDir -/- takeFileName bin) bin
- _ -> buildBinary rs bin ctx
+lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context
+lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs
+
+buildProgram :: FilePath -> Context -> [(Resource, Int)] -> Action ()
+buildProgram bin ctx@(Context{..}) rs = do
+ -- Custom dependencies: this should be modeled better in the
+ -- Cabal file somehow.
+ -- TODO: Is this still needed? See 'runtimeDependencies'.
+ when (package == hsc2hs) $ do
+ -- 'Hsc2hs' needs the @template-hsc.h@ file.
+ template <- templateHscPath stage
+ need [template]
+ when (package == ghc) $ do
+ -- GHC depends on @settings@, @platformConstants@,
+ -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
+ -- @llvm-passes@.
+ need =<< ghcDeps stage
+
+ cross <- flag CrossCompiling
+ -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
+ case (cross, stage) of
+ (True, s) | s > Stage0 -> do
+ srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
+ copyFile (srcDir -/- takeFileName bin) bin
+ (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
+ srcDir <- stageLibPath Stage0 <&> (-/- "bin")
+ copyFile (srcDir -/- takeFileName bin) bin
+ _ -> buildBinary rs bin ctx
buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
buildBinary rs bin context@Context {..} = do
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index 62023d72e4..b513c37097 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -1,54 +1,75 @@
-module Rules.Register (configurePackage, registerPackage) where
-
-import Distribution.ParseUtils
-import Distribution.Version (Version)
-import qualified Distribution.Compat.ReadP as Parse
-import qualified Hadrian.Haskell.Cabal.Parse as Cabal
-import Hadrian.Expression
-import qualified System.Directory as IO
+module Rules.Register (configurePackageRules, registerPackageRules) where
import Base
import Context
+import Hadrian.BuildPath
+import Hadrian.Expression
import Packages
import Settings
+import Settings.Default
import Target
import Utilities
-parseCabalName :: String -> Maybe (String, Version)
-parseCabalName = readPToMaybe parse
- where
- parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
+import Distribution.ParseUtils
+import Distribution.Version (Version)
+
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Hadrian.Haskell.Cabal.Parse as Cabal
+import qualified System.Directory as IO
+import qualified Text.Parsec as Parsec
+
+-- * Configuring
-- | Configure a package and build its @setup-config@ file.
-configurePackage :: Context -> Rules ()
-configurePackage context@Context {..} = do
+configurePackageRules :: Rules ()
+configurePackageRules = do
root <- buildRootRules
- root -/- contextDir context -/- "setup-config" %> \_ ->
- Cabal.configurePackage context
+ root -/- "**/setup-config" %> \path ->
+ parsePath (parseSetupConfig root) "<setup config path parser>" path
+ >>= configurePackage
+
+parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
+parseSetupConfig root = do
+ _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+ stage <- parseStage
+ _ <- Parsec.char '/'
+ pkgPath <- Parsec.manyTill Parsec.anyChar
+ (Parsec.try $ Parsec.string "/setup-config")
+ return (stage, pkgPath)
+
+configurePackage :: (Stage, FilePath) -> Action ()
+configurePackage (stage, pkgpath) = do
+ pkg <- getPackageByPath pkgpath
+ Cabal.configurePackage (Context stage pkg vanilla)
+
+-- * Registering
-- | Register a package and initialise the corresponding package database if
-- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
-registerPackage :: [(Resource, Int)] -> Context -> Rules ()
-registerPackage rs context@Context {..} = when (stage < Stage2) $ do
+registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
+registerPackageRules rs stage = do
root <- buildRootRules
-- Initialise the package database.
root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
writeFileLines stamp []
- -- TODO: Add proper error handling for partial functions.
-- Register a package.
root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
- settings <- libPath context <&> (-/- "settings")
- platformConstants <- libPath context <&> (-/- "platformConstants")
+ let libpath = takeDirectory (takeDirectory conf)
+ settings = libpath -/- "settings"
+ platformConstants = libpath -/- "platformConstants"
+
need [settings, platformConstants]
- let Just pkgName | takeBaseName conf == "rts" = Just "rts"
- | otherwise = fst <$> parseCabalName (takeBaseName conf)
- let Just pkg = findPackageByName pkgName
+
+ pkgName <- getPackageNameFromConfFile conf
+ pkg <- getPackageByName pkgName
isBoot <- (pkg `notElem`) <$> stagePackages Stage0
+
+ let ctx = Context stage pkg vanilla
case stage of
- Stage0 | isBoot -> copyConf rs (context { package = pkg }) conf
- _ -> buildConf rs (context { package = pkg }) conf
+ Stage0 | isBoot -> copyConf rs ctx conf
+ _ -> buildConf rs ctx conf
buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildConf _ context@Context {..} _conf = do
@@ -101,3 +122,20 @@ copyConf rs context@Context {..} conf = do
where
stdOutToPkgIds :: String -> [String]
stdOutToPkgIds = drop 1 . concatMap words . lines
+
+getPackageNameFromConfFile :: FilePath -> Action String
+getPackageNameFromConfFile conf
+ | takeBaseName conf == "rts" = return "rts"
+ | otherwise = case parseCabalName (takeBaseName conf) of
+ Nothing -> error $ "getPackageNameFromConfFile: couldn't parse " ++ conf
+ Just (name, _) -> return name
+
+parseCabalName :: String -> Maybe (String, Version)
+parseCabalName = readPToMaybe parse
+ where
+ parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
+
+getPackageByName :: String -> Action Package
+getPackageByName n = case findPackageByName n of
+ Nothing -> error $ "getPackageByName: couldn't find " ++ n
+ Just p -> return p
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 031bd45ace..b0e269ce1b 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -1,6 +1,6 @@
module Settings.Default (
-- * Packages that are build by default and for the testsuite
- defaultPackages, testsuitePackages,
+ defaultPackages, testsuitePackages, getPackageByPath,
-- * Default build ways
defaultLibraryWays, defaultRtsWays,
@@ -141,6 +141,13 @@ testsuitePackages = do
, unlit ] ++
[ timeout | win ]
+getPackageByPath :: FilePath -> Action Package
+getPackageByPath pkgpath = do
+ case filter (\p -> pkgPath p == pkgpath) knownPackages of
+ (p:_) -> return p
+ _ -> error $
+ "getPackageByPath: couldn't find a package with path: " ++ pkgpath
+
-- | Default build ways for library packages:
-- * We always build 'vanilla' way.
-- * We build 'profiling' way when stage > Stage0.
View Lorry Controller Status