Refactor GHC/user packages, move builder-specific functions into Builder
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 28 Aug 2017 00:56:06 +0000 (01:56 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 28 Aug 2017 00:56:06 +0000 (01:56 +0100)
See #403

15 files changed:
src/Base.hs
src/Builder.hs
src/Expression.hs
src/GHC.hs
src/Oracles/ModuleFiles.hs
src/Rules.hs
src/Rules/Documentation.hs
src/Rules/Perl.hs
src/Rules/SourceDist.hs
src/Settings.hs
src/Settings/Builders/Ghc.hs
src/Settings/Builders/GhcCabal.hs
src/Target.hs
src/UserSettings.hs
src/Utilities.hs

index a27a658..942b272 100644 (file)
@@ -14,7 +14,6 @@ module Base (
     module Development.Shake.Util,
 
     -- * Basic data types
-    module Builder,
     module Hadrian.Package,
     module Stage,
     module Way,
@@ -39,7 +38,6 @@ import Development.Shake.Util
 import Hadrian.Utilities
 import Hadrian.Package
 
-import Builder
 import Stage
 import Way
 
index 6c1d63a..822629b 100644 (file)
@@ -1,11 +1,18 @@
 module Builder (
-    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
+    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
+    builderProvenance, systemBuilderPath, builderPath, getBuilderPath,
+    isSpecified, needBuilder,
     ) where
 
 import Development.Shake.Classes
 import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Oracles.Path
+import Hadrian.Oracles.TextFile
 
-import Stage
+import Base
+import Context
+import GHC
 
 -- | C compiler can be used in two different modes:
 -- * Compile or preprocess a source file.
@@ -72,6 +79,36 @@ instance Binary   Builder
 instance Hashable Builder
 instance NFData   Builder
 
+-- | Some builders are built by this very build system, in which case
+-- 'builderProvenance' returns the corresponding build 'Context' (which includes
+-- 'Stage' and GHC 'Package').
+builderProvenance :: Builder -> Maybe Context
+builderProvenance = \case
+    DeriveConstants  -> context Stage0 deriveConstants
+    GenApply         -> context Stage0 genapply
+    GenPrimopCode    -> context Stage0 genprimopcode
+    Ghc _ Stage0     -> Nothing
+    Ghc _ stage      -> context (pred stage) ghc
+    GhcCabal         -> context Stage0 ghcCabal
+    GhcCabalHsColour -> builderProvenance $ GhcCabal
+    GhcPkg _ Stage0  -> Nothing
+    GhcPkg _ _       -> context Stage0 ghcPkg
+    Haddock          -> context Stage2 haddock
+    Hpc              -> context Stage1 hpcBin
+    Hsc2Hs           -> context Stage0 hsc2hs
+    Unlit            -> context Stage0 unlit
+    _                -> Nothing
+  where
+    context s p = Just $ vanillaContext s p
+
+-- | Make sure a 'Builder' exists and rebuild it if out of date.
+needBuilder :: Builder -> Action ()
+needBuilder (Configure dir) = need [dir -/- "configure"]
+needBuilder (Make      dir) = need [dir -/- "Makefile"]
+needBuilder builder         = when (isJust $ builderProvenance builder) $ do
+    path <- builderPath builder
+    need [path]
+
 -- TODO: Some builders are required only on certain platforms. For example,
 -- Objdump is only required on OpenBSD and AIX, as mentioned in #211. Add
 -- support for platform-specific optional builders as soon as we can reliably
@@ -81,3 +118,53 @@ isOptional = \case
     HsColour -> True
     Objdump  -> True
     _        -> False
+
+-- | Determine the location of a system 'Builder'.
+systemBuilderPath :: Builder -> Action FilePath
+systemBuilderPath builder = case builder of
+    Alex            -> fromKey "alex"
+    Ar Stage0       -> fromKey "system-ar"
+    Ar _            -> fromKey "ar"
+    Cc  _  Stage0   -> fromKey "system-cc"
+    Cc  _  _        -> fromKey "cc"
+    -- We can't ask configure for the path to configure!
+    Configure _     -> return "sh configure"
+    Ghc _  Stage0   -> fromKey "system-ghc"
+    GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
+    Happy           -> fromKey "happy"
+    HsColour        -> fromKey "hscolour"
+    HsCpp           -> fromKey "hs-cpp"
+    Ld              -> fromKey "ld"
+    Make _          -> fromKey "make"
+    Nm              -> fromKey "nm"
+    Objdump         -> fromKey "objdump"
+    Patch           -> fromKey "patch"
+    Perl            -> fromKey "perl"
+    Ranlib          -> fromKey "ranlib"
+    Tar             -> fromKey "tar"
+    _               -> error $ "No entry for " ++ show builder ++ inCfg
+  where
+    inCfg = " in " ++ quote configFile ++ " file."
+    fromKey key = do
+        let unpack = fromMaybe . error $ "Cannot find path to builder "
+                ++ quote key ++ inCfg ++ " Did you skip configure?"
+        path <- unpack <$> lookupValue configFile key
+        if null path
+        then do
+            unless (isOptional builder) . error $ "Non optional builder "
+                ++ quote key ++ " is not specified" ++ inCfg
+            return "" -- TODO: Use a safe interface.
+        else fixAbsolutePathOnWindows =<< lookupInPath path
+
+-- | Determine the location of a 'Builder'.
+builderPath :: Builder -> Action FilePath
+builderPath builder = case builderProvenance builder of
+    Nothing      -> systemBuilderPath builder
+    Just context -> programPath context
+
+-- | Was the path to a given system 'Builder' specified in configuration files?
+isSpecified :: Builder -> Action Bool
+isSpecified = fmap (not . null) . systemBuilderPath
+
+getBuilderPath :: Builder -> Expr c Builder FilePath
+getBuilderPath = expr . builderPath
index 5daaa21..1018591 100644 (file)
@@ -20,13 +20,15 @@ module Expression (
     getPackage, getBuilder, getOutputs, getInputs, getWay, getInput, getOutput,
 
     -- * Re-exports
-    module Base
+    module Base,
+    module Builder
     ) where
 
 import qualified Hadrian.Expression as H
 import Hadrian.Expression hiding (Expr, Predicate, Args)
 
 import Base
+import Builder
 import Context (Context, vanillaContext, stageContext, getBuildPath, getStage, getPackage, getWay)
 import Oracles.PackageData
 import Target hiding (builder, inputs, outputs)
index 8b7fdb8..d36de56 100644 (file)
@@ -8,18 +8,15 @@ module GHC (
     hpc, hpcBin, integerGmp, integerSimple, iservBin, libffi, mtl, parsec,
     parallel, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
     terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
-    defaultKnownPackages, defaultPackages,
+    ghcPackages, isGhcPackage, defaultPackages,
 
     -- * Package information
-    builderProvenance, programName, nonCabalContext, nonHsMainPackage, autogenPath,
+    programName, nonCabalContext, nonHsMainPackage, autogenPath,
 
     -- * Miscellaneous
-    systemBuilderPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
+    programPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
     ) where
 
-import Hadrian.Oracles.Path
-import Hadrian.Oracles.TextFile
-
 import Base
 import CommandLine
 import Context
@@ -27,11 +24,11 @@ import Oracles.Setting
 
 -- | These are all GHC packages we know about. Build rules will be generated for
 -- all of them. However, not all of these packages will be built. For example,
--- package 'win32' is built only on Windows. "Settings.Default" defines default
--- conditions for building each package, which can be overridden in
--- @hadrian/src/UserSettings.hs@.
-defaultKnownPackages :: [Package]
-defaultKnownPackages =
+-- package 'win32' is built only on Windows. 'defaultPackages' defines default
+-- conditions for building each package. Users can add their own packages and
+-- modify build default build conditions in "UserSettings".
+ghcPackages :: [Package]
+ghcPackages =
     [ array, base, binary, bytestring, cabal, checkApiAnnotations, compareSizes
     , compiler, containers, deepseq, deriveConstants, directory, dllSplit
     , filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCabal
@@ -41,6 +38,10 @@ defaultKnownPackages =
     , templateHaskell, terminfo, text, time, touchy, transformers, unlit, unix
     , win32, xhtml ]
 
+-- TODO: Optimise by switching to sets of packages.
+isGhcPackage :: Package -> Bool
+isGhcPackage = (`elem` ghcPackages)
+
 -- | Package definitions, see 'Package'.
 array               = hsLib  "array"
 base                = hsLib  "base"
@@ -202,65 +203,6 @@ stage2Packages = do
     doc <- cmdBuildHaddock
     return [ haddock | doc ]
 
--- | Some builders are built by this very build system, in which case
--- 'builderProvenance' returns the corresponding build 'Context' (which includes
--- 'Stage' and GHC 'Package').
-builderProvenance :: Builder -> Maybe Context
-builderProvenance = \case
-    DeriveConstants  -> context Stage0 deriveConstants
-    GenApply         -> context Stage0 genapply
-    GenPrimopCode    -> context Stage0 genprimopcode
-    Ghc _ Stage0     -> Nothing
-    Ghc _ stage      -> context (pred stage) ghc
-    GhcCabal         -> context Stage0 ghcCabal
-    GhcCabalHsColour -> builderProvenance $ GhcCabal
-    GhcPkg _ Stage0  -> Nothing
-    GhcPkg _ _       -> context Stage0 ghcPkg
-    Haddock          -> context Stage2 haddock
-    Hpc              -> context Stage1 hpcBin
-    Hsc2Hs           -> context Stage0 hsc2hs
-    Unlit            -> context Stage0 unlit
-    _                -> Nothing
-  where
-    context s p = Just $ vanillaContext s p
-
--- | Determine the location of a system 'Builder'.
-systemBuilderPath :: Builder -> Action FilePath
-systemBuilderPath builder = case builder of
-    Alex            -> fromKey "alex"
-    Ar Stage0       -> fromKey "system-ar"
-    Ar _            -> fromKey "ar"
-    Cc  _  Stage0   -> fromKey "system-cc"
-    Cc  _  _        -> fromKey "cc"
-    -- We can't ask configure for the path to configure!
-    Configure _     -> return "sh configure"
-    Ghc _  Stage0   -> fromKey "system-ghc"
-    GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
-    Happy           -> fromKey "happy"
-    HsColour        -> fromKey "hscolour"
-    HsCpp           -> fromKey "hs-cpp"
-    Ld              -> fromKey "ld"
-    Make _          -> fromKey "make"
-    Nm              -> fromKey "nm"
-    Objdump         -> fromKey "objdump"
-    Patch           -> fromKey "patch"
-    Perl            -> fromKey "perl"
-    Ranlib          -> fromKey "ranlib"
-    Tar             -> fromKey "tar"
-    _               -> error $ "No entry for " ++ show builder ++ inCfg
-  where
-    inCfg = " in " ++ quote configFile ++ " file."
-    fromKey key = do
-        let unpack = fromMaybe . error $ "Cannot find path to builder "
-                ++ quote key ++ inCfg ++ " Did you skip configure?"
-        path <- unpack <$> lookupValue configFile key
-        if null path
-        then do
-            unless (isOptional builder) . error $ "Non optional builder "
-                ++ quote key ++ " is not specified" ++ inCfg
-            return "" -- TODO: Use a safe interface.
-        else fixAbsolutePathOnWindows =<< lookupInPath path
-
 -- | Given a 'Context', compute the name of the program that is built in it
 -- assuming that the corresponding package's type is 'Program'. For example, GHC
 -- built in 'Stage0' is called @ghc-stage1@. If the given package is a
@@ -273,6 +215,21 @@ programName Context {..}
     | package == iservBin = "ghc-iserv"
     | otherwise           = pkgName package
 
+isInstallContext :: Context -> Action Bool
+isInstallContext Context {..}
+    | not (isGhcPackage package) = return False
+    | otherwise = do
+        stages <- filterM (fmap (package `elem`) . defaultPackages) [Stage0 ..]
+        return (null stages || package == ghc || stage == maximum stages)
+
+-- | The 'FilePath' to a program executable in a given 'Context'.
+programPath :: Context -> Action FilePath
+programPath context@Context {..} = do
+    path    <- buildPath context
+    install <- isInstallContext context
+    let contextPath = if install then inplaceInstallPath package else path
+    return $ contextPath -/- programName context <.> exe
+
 -- | Some contexts are special: their packages do not have @.cabal@ metadata or
 -- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
 -- yet (this is the case with the 'ghcCabal' package in 'Stage0').
index 5bf970a..9a54a2a 100644 (file)
@@ -6,6 +6,7 @@ module Oracles.ModuleFiles (
 import qualified Data.HashMap.Strict as Map
 
 import Base
+import Builder
 import Context
 import GHC
 import Oracles.PackageData
index 3131105..1f0437b 100644 (file)
@@ -72,8 +72,10 @@ packageTargets includeGhciLib stage pkg = do
             return $ [ setup   | nonCabalContext context ]
                   ++ [ haddock | docs && stage == Stage1 ]
                   ++ libs ++ more
-        else -- The only target of a program package is the executable.
-            fmap maybeToList . programPath =<< programContext stage pkg
+        else do -- The only target of a program package is the executable.
+            prgContext <- programContext stage pkg
+            prgPath    <- programPath prgContext
+            return [prgPath]
 
 packageRules :: Rules ()
 packageRules = do
index 6104a37..e30985e 100644 (file)
@@ -18,7 +18,7 @@ haddockDependencies context = do
     path     <- buildPath context
     depNames <- pkgDataList $ DepNames path
     sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
-             | Just depPkg <- map findKnownPackage depNames, depPkg /= rts ]
+             | Just depPkg <- map findPackageByName depNames, depPkg /= rts ]
 
 -- 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
index a05c6a6..6455277 100644 (file)
@@ -1,8 +1,10 @@
 module Rules.Perl (perlScriptRules) where
 
 import Base
+import Builder
 import Utilities
 
+-- TODO: Do we need this build rule?
 -- | Build Perl scripts, such as @ghc-split@, from their literate Perl sources.
 perlScriptRules :: Rules ()
 perlScriptRules = do
index f259442..259eb42 100644 (file)
@@ -3,6 +3,7 @@ module Rules.SourceDist (sourceDistRules) where
 import Hadrian.Oracles.DirectoryContents
 
 import Base
+import Builder
 import Oracles.Setting
 import Rules.Clean
 import Utilities
index 8056851..291af54 100644 (file)
@@ -1,8 +1,7 @@
 module Settings (
     getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
-    findKnownPackage, getPkgData, getPkgDataList, isLibrary, stagePackages,
-    builderPath, getBuilderPath, isSpecified, latestBuildStage, programPath,
-    programContext, integerLibraryName, getDestDir, stage1Only, buildDll0
+    findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
+    latestBuildStage, programContext, integerLibraryName, getDestDir, stage1Only
     ) where
 
 import Context
@@ -57,28 +56,12 @@ programContext stage pkg = do
 -- TODO: switch to Set Package as the order of packages should not matter?
 -- Otherwise we have to keep remembering to sort packages from time to time.
 knownPackages :: [Package]
-knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
+knownPackages = sort $ ghcPackages ++ userPackages
 
 -- TODO: Speed up? Switch to Set?
 -- Note: this is slow but we keep it simple as there are just ~50 packages
-findKnownPackage :: PackageName -> Maybe Package
-findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
-
--- | Determine the location of a 'Builder'.
-builderPath :: Builder -> Action FilePath
-builderPath builder = case builderProvenance builder of
-    Nothing      -> systemBuilderPath builder
-    Just context -> do
-        maybePath <- programPath context
-        let msg = error $ show builder ++ " is never built by Hadrian."
-        return $ fromMaybe msg maybePath
-
-getBuilderPath :: Builder -> Expr FilePath
-getBuilderPath = expr . builderPath
-
--- | Was the path to a given 'Builder' specified in configuration files?
-isSpecified :: Builder -> Action Bool
-isSpecified = fmap (not . null) . builderPath
+findPackageByName :: PackageName -> Maybe Package
+findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
 
 -- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
 -- Nothing if the package is never built.
@@ -87,16 +70,6 @@ latestBuildStage pkg = do
     stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
     return $ if null stages then Nothing else Just $ maximum stages
 
--- | The 'FilePath' to a program executable in a given 'Context'.
-programPath :: Context -> Action (Maybe FilePath)
-programPath context@Context {..} = do
-    maybeLatest <- latestBuildStage package
-    path        <- buildPath context
-    return $ do
-        install <- (\l -> l == stage || package == ghc) <$> maybeLatest
-        let installPath = if install then inplaceInstallPath package else path
-        return $ installPath -/- programName context <.> exe
-
 -- TODO: Set this from command line
 -- | Stage1Only flag.
 stage1Only :: Bool
index 50bdd6e..a186e08 100644 (file)
@@ -20,9 +20,9 @@ ghcBuilderArgs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
             , arg "-o", arg =<< getOutput ]
 
 needTouchy :: Expr ()
-needTouchy = notStage0 ? do
-    maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
-    expr . whenJust maybePath $ \path -> need [path]
+needTouchy = notStage0 ? windowsHost ? do
+    touchyPath <- expr $ programPath (vanillaContext Stage0 touchy)
+    expr $ need [touchyPath]
 
 ghcCbuilderArgs :: Args
 ghcCbuilderArgs =
index 0e7750e..4fd598b 100644 (file)
@@ -7,7 +7,6 @@ import Hadrian.Haskell.Cabal
 import Context
 import Flavour
 import Settings.Builders.Common hiding (package)
-import Utilities
 
 ghcCabalBuilderArgs :: Args
 ghcCabalBuilderArgs = builder GhcCabal ? do
@@ -118,11 +117,12 @@ withBuilderKey b = case b of
 
 -- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args
-with b = isSpecified b ? do
-    top  <- expr topDirectory
+with b = do
     path <- getBuilderPath b
-    expr $ needBuilder b
-    arg $ withBuilderKey b ++ unifyPath (top </> path)
+    if (null path) then mempty else do
+        top  <- expr topDirectory
+        expr $ needBuilder b
+        arg $ withBuilderKey b ++ unifyPath (top </> path)
 
 withStaged :: (Stage -> Builder) -> Args
 withStaged sb = with . sb =<< getStage
index c3a117b..30c8d98 100644 (file)
@@ -1,5 +1,6 @@
 module Target (
-    Target, target, context, builder, inputs, outputs, trackArgument
+    Target, target, context, builder, inputs, outputs, trackArgument,
+    module Builder
     ) where
 
 import Data.Char
index 4a1db5b..17d13df 100644 (file)
@@ -3,7 +3,7 @@
 -- If you don't copy the file your changes will be tracked by git and you can
 -- accidentally commit them.
 module UserSettings (
-    userBuildRoot, userFlavours, userKnownPackages, verboseCommands,
+    userBuildRoot, userFlavours, userPackages, verboseCommands,
     buildProgressColour, successColour, defaultStage1Only
     ) where
 
@@ -23,11 +23,11 @@ userBuildRoot = BuildRoot "_build"
 userFlavours :: [Flavour]
 userFlavours = []
 
--- | Add user defined packages. Note, this only let's Hadrian know about the
+-- | Add user defined packages. Note, this only lets Hadrian know about the
 -- existence of a new package; to actually build it you need to create a new
 -- build flavour, modifying the list of packages that are built by default.
-userKnownPackages :: [Package]
-userKnownPackages = []
+userPackages :: [Package]
+userPackages = []
 
 -- | Set to 'True' to print full command lines during the build process. Note:
 -- this is a 'Predicate', hence you can enable verbose output only for certain
index 779f7b6..138dcdc 100644 (file)
@@ -1,6 +1,6 @@
 module Utilities (
     build, buildWithCmdOptions, buildWithResources, applyPatch, runBuilder,
-    runBuilderWith, builderEnvironment, needBuilder, needLibrary,
+    runBuilderWith, builderEnvironment, needLibrary,
     installDirectory, installData, installScript, installProgram, linkSymbolic,
     contextDependencies, stage1Dependencies, libraryTargets, topsortPackages
     ) where
@@ -153,17 +153,6 @@ linkSymbolic source target = do
         putProgressInfo =<< renderAction "Create symbolic link" source target
         quietly $ cmd lns source target
 
-isInternal :: Builder -> Bool
-isInternal = isJust . builderProvenance
-
--- | Make sure a 'Builder' exists and rebuild it if out of date.
-needBuilder :: Builder -> Action ()
-needBuilder (Configure dir) = need [dir -/- "configure"]
-needBuilder (Make      dir) = need [dir -/- "Makefile"]
-needBuilder builder         = when (isInternal builder) $ do
-    path <- builderPath builder
-    need [path]
-
 -- | Write a Builder's path into a given environment variable.
 builderEnvironment :: String -> Builder -> Action CmdOption
 builderEnvironment variable builder = do