Refactor builder path manipulation

hadrian.cabal

@@ -35,7 +35,7 @@ executable hadrian
                        , Oracles.LookupInPath
                        , Oracles.ModuleFiles
                        , Oracles.PackageData
-                       , Oracles.WindowsPath
+                       , Oracles.Path
                        , Package
                        , Predicate
                        , Rules

src/Builder.hs

 {-# LANGUAGE DeriveGeneric, LambdaCase #-}
 module Builder (
-    CcMode (..), GhcMode (..), Builder (..), builderPath, getBuilderPath,
-    builderEnvironment, specified, trackedArgument, needBuilder
+    CcMode (..), GhcMode (..), Builder (..), trackedArgument, isOptional
     ) where
 
-import Control.Monad.Trans.Reader
 import Data.Char
 import GHC.Generics
 
 import Base
-import Context
-import GHC
-import Oracles.Config
-import Oracles.LookupInPath
-import Oracles.WindowsPath
 import Stage
 
 -- | A compiler can typically be used in different modes:
@@ -58,30 +51,6 @@ data Builder = Alex
              | Unlit
              deriving (Eq, Generic, Show)
 
--- | 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 stage     -> if stage > Stage0 then context Stage0 ghcPkg else Nothing
-    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
-
-isInternal :: Builder -> Bool
-isInternal = isJust . builderProvenance
-
 -- 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
@@ -92,57 +61,6 @@ isOptional = \case
     Objdump  -> True
     _        -> False
 
--- | Determine the location of a 'Builder'.
-builderPath :: Builder -> Action FilePath
-builderPath builder = case programPath =<< builderProvenance builder of
-    Just path -> return path
-    Nothing   -> case builder of
-        Alex          -> fromKey "alex"
-        Ar            -> fromKey "ar"
-        Cc  _  Stage0 -> fromKey "system-cc"
-        Cc  _  _      -> fromKey "cc"
-        -- We can't ask configure for the path to configure!
-        Configure _   -> return "bash 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 $ "Cannot determine builderPath for " ++ show builder
-  where
-    fromKey key = do
-        let unpack = fromMaybe . error $ "Cannot find path to builder "
-                ++ quote key ++ " in system.config file. Did you skip configure?"
-        path <- unpack <$> askConfig key
-        if null path
-        then do
-            unless (isOptional builder) . error $ "Non optional builder "
-                ++ quote key ++ " is not specified in system.config file."
-            return "" -- TODO: Use a safe interface.
-        else fixAbsolutePathOnWindows =<< lookupInPath path
-
-getBuilderPath :: Builder -> ReaderT a Action FilePath
-getBuilderPath = lift . builderPath
-
--- | Write a Builder's path into a given environment variable.
-builderEnvironment :: String -> Builder -> Action CmdOption
-builderEnvironment variable builder = do
-    needBuilder builder
-    path <- builderPath builder
-    return $ AddEnv variable path
-
--- | Was the path to a given 'Builder' specified in configuration files?
-specified :: Builder -> Action Bool
-specified = fmap (not . null) . builderPath
-
 -- | Some arguments do not affect build results and therefore do not need to be
 -- tracked by the build system. A notable example is "-jN" that controls Make's
 -- parallelism. Given a 'Builder' and an argument, this function should return
@@ -154,14 +72,6 @@ trackedArgument _        = const True
 threadArg :: String -> Bool
 threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
 
--- | Make sure a Builder exists on the given path and rebuild it if out of date.
-needBuilder :: Builder -> Action ()
-needBuilder = \case
-    Configure dir -> need [dir -/- "configure"]
-    builder       -> when (isInternal builder) $ do
-        path <- builderPath builder
-        need [path]
-
 instance Binary Builder
 instance Hashable Builder
 instance NFData Builder

src/GHC.hs

-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 module GHC (
     array, base, binary, bytestring, cabal, checkApiAnnotations, compiler,
@@ -9,10 +9,10 @@ module GHC (
     parallel, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
     terminfo, time, touchy, transformers, unlit, unix, win32, xhtml,
 
-    defaultKnownPackages, stageDirectory, programPath
+    defaultKnownPackages, builderProvenance
     ) where
 
-import Base
+import Builder
 import Context
 import Package
 import Stage
@@ -91,46 +91,23 @@ xhtml               = library  "xhtml"
 ghcSplit :: FilePath
 ghcSplit = "inplace/lib/bin/ghc-split"
 
--- | Relative path to the directory containing build artefacts of a given 'Stage'.
-stageDirectory :: Stage -> FilePath
-stageDirectory = stageString
-
--- TODO: Create a separate rule for copying executables to inplace/bin
--- TODO: move to buildRootPath, see #113
--- | The 'FilePath' to a program executable in a given 'Context'.
-programPath :: Context -> Maybe FilePath
-programPath Context {..} = lookup (stage, package) exes
+-- | 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 stage     -> if stage > Stage0 then context Stage0 ghcPkg else Nothing
+    Haddock          -> context Stage2 haddock
+    Hpc              -> context Stage1 hpcBin
+    Hsc2Hs           -> context Stage0 hsc2hs
+    Unlit            -> context Stage0 unlit
+    _                -> Nothing
   where
-    exes = [ inplace2 checkApiAnnotations
-           , install1 compareSizes
-           , inplace0 deriveConstants
-           , inplace0 dllSplit
-           , inplace0 genapply
-           , inplace0 genprimopcode
-           , inplace0 ghc             `setFile` "ghc-stage1"
-           , inplace1 ghc             `setFile` "ghc-stage2"
-           , install0 ghcCabal
-           , inplace1 ghcCabal
-           , inplace0 ghcPkg
-           , install1 ghcPkg
-           , inplace2 ghcTags
-           , inplace2 haddock
-           , inplace0 hp2ps
-           , inplace1 hpcBin          `setFile` "hpc"
-           , inplace0 hsc2hs
-           , install1 hsc2hs
-           , install1 iservBin
-           , inplace0 mkUserGuidePart
-           , inplace1 runGhc          `setFile` "runhaskell"
-           , inplace0 touchy          `setDir`  "inplace/lib/bin"
-           , inplace0 unlit           `setDir`  "inplace/lib/bin" ]
-    inplace  pkg = programInplacePath -/- pkgNameString pkg <.> exe
-    inplace0 pkg = ((Stage0, pkg), inplace pkg)
-    inplace1 pkg = ((Stage1, pkg), inplace pkg)
-    inplace2 pkg = ((Stage2, pkg), inplace pkg)
-    install stage pkg = pkgPath package -/- stageDirectory stage -/- "build/tmp"
-                                        -/- pkgNameString pkg <.> exe
-    install0 pkg = ((Stage0, pkg), install Stage0 pkg)
-    install1 pkg = ((Stage1, pkg), install Stage1 pkg)
-    setFile ((stage, pkg), x) y = ((stage, pkg), takeDirectory x -/- y <.> exe)
-    setDir  ((stage, pkg), x) y = ((stage, pkg), y -/- takeFileName x)
+    context s p = Just $ vanillaContext s p

src/Oracles/WindowsPath.hs

-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Oracles.WindowsPath (
-    fixAbsolutePathOnWindows, topDirectory, getTopDirectory, windowsPathOracle
-    ) where
-
--- TODO: Rename to Oracles.Path.
-
-import Control.Monad.Trans.Reader
-import Data.Char
-
-import Base
-import Oracles.Config.Setting
-
-newtype WindowsPath = WindowsPath FilePath
-    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-
--- | Path to the GHC source tree.
-topDirectory :: Action FilePath
-topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
-
-getTopDirectory :: ReaderT a Action FilePath
-getTopDirectory = lift topDirectory
-
--- | Fix an absolute path on Windows:
--- * "/c/" => "C:/"
--- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
-fixAbsolutePathOnWindows :: FilePath -> Action FilePath
-fixAbsolutePathOnWindows path = do
-    windows <- windowsHost
-    if windows
-    then do
-        let (dir, file) = splitFileName path
-        winDir <- askOracle $ WindowsPath dir
-        return $ winDir -/- file
-    else
-        return path
-
--- | Compute path mapping on Windows. This is slow and requires caching.
-windowsPathOracle :: Rules ()
-windowsPathOracle = void $
-    addOracle $ \(WindowsPath path) -> do
-        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
-        let windowsPath = unifyPath $ dropWhileEnd isSpace out
-        putLoud $ "Windows path mapping: " ++ path ++ " => " ++ windowsPath
-        return windowsPath

src/Rules/Actions.hs

@@ -2,7 +2,8 @@ module Rules.Actions (
     build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
     removeFile, copyDirectory, copyDirectoryContent, createDirectory,
     moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
-    makeExecutable, renderProgram, renderLibrary, Match(..)
+    makeExecutable, renderProgram, renderLibrary, Match(..), builderEnvironment,
+    needBuilder
     ) where
 
 import qualified System.Directory.Extra as IO
@@ -13,11 +14,13 @@ import Base
 import CmdLineFlag
 import Context
 import Expression
+import GHC
 import Oracles.ArgsHash
 import Oracles.DirectoryContent
-import Oracles.WindowsPath
+import Oracles.Path
 import Settings
 import Settings.Builders.Ar
+import Settings.Paths
 import Target
 import UserSettings
 
@@ -164,6 +167,23 @@ applyPatch dir patch = do
     putBuild $ "| Apply patch " ++ file
     quietly $ cmd Shell cmdEcho [Cwd dir] [path, "-p0 <", patch]
 
+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 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
+    needBuilder builder
+    path <- builderPath builder
+    return $ AddEnv variable path
+
 runBuilder :: Builder -> [String] -> Action ()
 runBuilder = runBuilderWith []
 

src/Rules/Documentation.hs

@@ -33,7 +33,7 @@ buildPackageDocumentation context@Context {..} =
 
             -- HsColour sources
             -- TODO: what is the output of GhcCabalHsColour?
-            whenM (specified HsColour) $ do
+            whenM (isSpecified HsColour) $ do
                 pkgConf <- pkgConfFile context
                 need [ cabalFile, pkgConf ] -- TODO: check if need pkgConf
                 build $ Target context GhcCabalHsColour [cabalFile] []

src/Rules/Generators/ConfigHs.hs

@@ -8,6 +8,7 @@ import Oracles.Config.Flag
 import Oracles.Config.Setting
 import Rules.Generators.Common
 import Settings
+import Settings.Paths
 import UserSettings
 
 generateConfigHs :: Expr String

src/Rules/Generators/GhcSplit.hs

@@ -4,6 +4,7 @@ import Base
 import Expression
 import Oracles.Config.Setting
 import Rules.Generators.Common
+import Settings.Paths
 
 ghcSplitSource :: FilePath
 ghcSplitSource = "driver/split/ghc-split.prl"

src/Rules/Oracles.hs

@@ -8,7 +8,7 @@ import qualified Oracles.DirectoryContent
 import qualified Oracles.LookupInPath
 import qualified Oracles.ModuleFiles
 import qualified Oracles.PackageData
-import qualified Oracles.WindowsPath
+import qualified Oracles.Path
 
 oracleRules :: Rules ()
 oracleRules = do
@@ -19,4 +19,4 @@ oracleRules = do
     Oracles.LookupInPath.lookupInPathOracle
     Oracles.ModuleFiles.moduleFilesOracle
     Oracles.PackageData.packageDataOracle
-    Oracles.WindowsPath.windowsPathOracle
+    Oracles.Path.windowsPathOracle

src/Rules/Program.hs

@@ -18,11 +18,6 @@ import Settings.Paths
 import Target
 import UserSettings
 
--- TODO: Move to buildRootPath, see #113.
--- | Directory for wrapped binaries.
-programInplaceLibPath :: FilePath
-programInplaceLibPath = "inplace/lib/bin"
-
 -- | Wrapper is an expression depending on the 'FilePath' to the wrapped binary.
 type Wrapper = FilePath -> Expr String
 

src/Rules/Test.hs

@@ -7,9 +7,10 @@ import Flavour
 import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
-import Oracles.WindowsPath
+import Oracles.Path
 import Rules.Actions
 import Settings
+import Settings.Paths
 import Target
 
 -- TODO: clean up after testing

src/Rules/Wrappers/Ghc.hs

@@ -2,7 +2,7 @@ module Rules.Wrappers.Ghc (ghcWrapper) where
 
 import Base
 import Expression
-import Oracles.WindowsPath
+import Oracles.Path
 
 ghcWrapper :: FilePath -> Expr String
 ghcWrapper program = do

src/Rules/Wrappers/GhcPkg.hs

@@ -2,7 +2,7 @@ module Rules.Wrappers.GhcPkg (ghcPkgWrapper) where
 
 import Base
 import Expression
-import Oracles.WindowsPath
+import Oracles.Path
 import Settings.Paths
 
 ghcPkgWrapper :: FilePath -> Expr String

src/Settings/Builders/Common.hs

@@ -5,7 +5,7 @@ module Settings.Builders.Common (
     module Oracles.Config.Flag,
     module Oracles.Config.Setting,
     module Oracles.PackageData,
-    module Oracles.WindowsPath,
+    module Oracles.Path,
     module Predicate,
     module Settings,
     module Settings.Paths,
@@ -20,7 +20,7 @@ import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
 import Oracles.PackageData
-import Oracles.WindowsPath
+import Oracles.Path
 import Predicate
 import Settings
 import Settings.Paths

src/Settings/Builders/DeriveConstants.hs

@@ -18,8 +18,8 @@ deriveConstantsBuilderArgs = builder DeriveConstants ? do
         , arg "--gcc-program", arg =<< getBuilderPath (Cc CompileC Stage1)
         , append $ concatMap (\a -> ["--gcc-flag", a]) cFlags
         , arg "--nm-program", arg =<< getBuilderPath Nm
-        , specified Objdump ? mconcat [ arg "--objdump-program"
-                                      , arg =<< getBuilderPath Objdump ]
+        , isSpecified Objdump ? mconcat [ arg "--objdump-program"
+                                        , arg =<< getBuilderPath Objdump ]
         , arg "--target-os", argSetting TargetOs ]
 
 includeCcArgs :: Args

src/Settings/Builders/GhcCabal.hs

@@ -4,6 +4,7 @@ module Settings.Builders.GhcCabal (
 
 import Context
 import Flavour
+import Rules.Actions
 import Settings.Builders.Common
 
 ghcCabalBuilderArgs :: Args
@@ -98,7 +99,7 @@ withBuilderKey b = case b of
 
 -- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args
-with b = specified b ? do
+with b = isSpecified b ? do
     top  <- getTopDirectory
     path <- getBuilderPath b
     lift $ needBuilder b

src/Settings/Builders/Haddock.hs

@@ -39,10 +39,9 @@ haddockBuilderArgs = builder Haddock ? do
                    , Just depPkg <- [findKnownPackage $ PackageName depName]
                    , depPkg /= rts ]
         , append [ "--optghc=" ++ opt | opt <- ghcOpts ]
-        , specified HsColour ?
-          arg "--source-module=src/%{MODULE/./-}.html"
-        , specified HsColour ?
-          arg "--source-entity=src/%{MODULE/./-}.html\\#%{NAME}"
+        , isSpecified HsColour ?
+          append [ "--source-module=src/%{MODULE/./-}.html"
+                 , "--source-entity=src/%{MODULE/./-}.html\\#%{NAME}" ]
         , append =<< getInputs
         , arg "+RTS"
         , arg $ "-t" ++ path -/- "haddock.t"

src/Settings/Packages/Rts.hs

@@ -6,7 +6,7 @@ import Base
 import GHC
 import Oracles.Config.Flag
 import Oracles.Config.Setting
-import Oracles.WindowsPath
+import Oracles.Path
 import Predicate
 import Settings
 import Settings.Paths

src/Settings/Paths.hs

@@ -3,7 +3,8 @@ module Settings.Paths (
     pkgLibraryFile0, pkgGhciLibraryFile, gmpBuildPath, gmpObjects, gmpLibraryH,
     gmpBuildInfoPath, generatedPath, libffiBuildPath, shakeFilesPath, pkgConfFile,
     packageDbDirectory, packageDbStamp, bootPackageConstraints, packageDependencies,
-    objectPath
+    objectPath, builderPath, getBuilderPath, isSpecified, programPath,
+    programInplaceLibPath
     ) where
 
 import Base
@@ -11,6 +12,7 @@ import Context
 import Expression
 import GHC
 import Oracles.PackageData
+import Oracles.Path
 import UserSettings
 
 -- | Path to the directory containing the Shake database and other auxiliary
@@ -31,6 +33,15 @@ packageDependencies = shakeFilesPath -/- "package-dependencies"
 generatedPath :: FilePath
 generatedPath = buildRootPath -/- "generated"
 
+-- | Relative path to the directory containing build artefacts of a given 'Stage'.
+stageDirectory :: Stage -> FilePath
+stageDirectory = stageString
+
+-- TODO: Move to buildRootPath, see #113.
+-- | Directory for wrapped binaries.
+programInplaceLibPath :: FilePath
+programInplaceLibPath = "inplace/lib/bin"
+
 -- | Path to the directory containing build artefacts of a given 'Context'.
 buildPath :: Context -> FilePath
 buildPath Context {..} = buildRootPath -/- stageDirectory stage -/- pkgPath package
@@ -127,3 +138,54 @@ objectPath context@Context {..} src
   where
     extension = drop 1 $ takeExtension src
     obj       = src -<.> osuf way
+
+-- | Determine the location of a 'Builder'.
+builderPath :: Builder -> Action FilePath
+builderPath builder = case programPath =<< builderProvenance builder of
+    Just path -> return path
+    Nothing   -> systemBuilderPath builder
+
+getBuilderPath :: Builder -> ReaderT a Action FilePath
+getBuilderPath = lift . builderPath
+
+-- | Was the path to a given 'Builder' specified in configuration files?
+isSpecified :: Builder -> Action Bool
+isSpecified = fmap (not . null) . builderPath
+
+-- | The 'FilePath' to a program executable in a given 'Context'.
+programPath :: Context -> Maybe FilePath
+programPath Context {..} = lookup (stage, package) exes
+  where
+    exes = [ inplace2 checkApiAnnotations
+           , install1 compareSizes
+           , inplace0 deriveConstants
+           , inplace0 dllSplit
+           , inplace0 genapply
+           , inplace0 genprimopcode
+           , inplace0 ghc             `setFile` "ghc-stage1"
+           , inplace1 ghc             `setFile` "ghc-stage2"
+           , install0 ghcCabal
+           , inplace1 ghcCabal
+           , inplace0 ghcPkg
+           , install1 ghcPkg
+           , inplace2 ghcTags
+           , inplace2 haddock
+           , inplace0 hp2ps
+           , inplace1 hpcBin          `setFile` "hpc"
+           , inplace0 hsc2hs
+           , install1 hsc2hs
+           , install1 iservBin
+           , inplace0 mkUserGuidePart
+           , inplace1 runGhc          `setFile` "runhaskell"
+           , inplace0 touchy          `setDir`  programInplaceLibPath
+           , inplace0 unlit           `setDir`  programInplaceLibPath ]
+    inplace  pkg = programInplacePath -/- pkgNameString pkg <.> exe
+    inplace0 pkg = ((Stage0, pkg), inplace pkg)
+    inplace1 pkg = ((Stage1, pkg), inplace pkg)
+    inplace2 pkg = ((Stage2, pkg), inplace pkg)
+    install stage pkg = pkgPath package -/- stageDirectory stage -/- "build/tmp"
+                                        -/- pkgNameString pkg <.> exe
+    install0 pkg = ((Stage0, pkg), install Stage0 pkg)
+    install1 pkg = ((Stage1, pkg), install Stage1 pkg)
+    setFile ((stage, pkg), x) y = ((stage, pkg), takeDirectory x -/- y <.> exe)
+    setDir  ((stage, pkg), x) y = ((stage, pkg), y -/- takeFileName x)