Commit df8e5aa8 authored by Andrey Mokhov's avatar Andrey Mokhov

Factor out general functionality of path oracles to the library

See #347
parent 7ff841eb
......@@ -29,6 +29,7 @@ executable hadrian
, Hadrian.Expression
, Hadrian.Oracles.ArgsHash
, Hadrian.Oracles.DirectoryContents
, Hadrian.Oracles.Path
, Hadrian.Target
, Hadrian.Utilities
, Oracles.Config
......@@ -37,7 +38,6 @@ executable hadrian
, Oracles.Dependencies
, Oracles.ModuleFiles
, Oracles.PackageData
, Oracles.Path
, Package
, Predicate
, Rules
......
......@@ -69,10 +69,6 @@ replaceSeparators = replaceWhen isPathSeparator
replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
replaceWhen p to = map (\from -> if p from then to else from)
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a]
......
......@@ -14,7 +14,6 @@ module Expression (
-- * Convenient accessors
getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
getInput, getOutput, getSingleton, getSetting, getSettingList, getFlag,
getTopDirectory,
-- * Re-exports
module Data.Semigroup,
......@@ -38,7 +37,6 @@ import Way
import Oracles.Config.Flag
import Oracles.Config.Setting
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'.
......@@ -78,6 +76,3 @@ getSettingList = expr . settingList
getFlag :: Flag -> Predicate
getFlag = expr . flag
getTopDirectory :: Expr FilePath
getTopDirectory = expr topDirectory
......@@ -22,9 +22,6 @@ type TrackArgument c b = Target c b -> String -> Bool
trackAllArguments :: TrackArgument c b
trackAllArguments _ _ = True
newtype ArgsHashKey c b = ArgsHashKey (Target c b)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-- | Given a 'Target' this 'Action' determines the corresponding argument list
-- and computes its hash. The resulting value is tracked in a Shake oracle,
-- hence initiating rebuilds when the hash changes (a hash change indicates
......@@ -40,6 +37,9 @@ trackArgsHash t = do
hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
void (askOracle $ ArgsHashKey hashedTarget :: Action Int)
newtype ArgsHashKey c b = ArgsHashKey (Target c b)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-- | This oracle stores per-target argument list hashes in the Shake database,
-- allowing the user to track them between builds using 'trackArgsHash' queries.
argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
......
......@@ -11,9 +11,6 @@ import System.Directory.Extra
import Hadrian.Utilities
newtype DirectoryContents = DirectoryContents (Match, FilePath)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
deriving (Generic, Eq, Show, Typeable)
......@@ -37,6 +34,9 @@ matches (Or ms) f = any (`matches` f) ms
directoryContents :: Match -> FilePath -> Action [FilePath]
directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
newtype DirectoryContents = DirectoryContents (Match, FilePath)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
-- | This oracle answers 'directoryContents' queries and tracks the results.
directoryContentsOracle :: Rules ()
directoryContentsOracle = void $
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Oracles.Path (
topDirectory, systemBuilderPath, pathOracle, bashPath,
fixAbsolutePathOnWindows
module Hadrian.Oracles.Path (
lookupInPath, fixAbsolutePathOnWindows, pathOracle
) where
import Control.Monad
import Data.Maybe
import Data.Char
import Data.List.Extra
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import System.Directory
import System.Info.Extra
import Base
import Builder
import Oracles.Config
import Oracles.Config.Setting
import Stage
import Hadrian.Utilities
-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
-- | 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 system.config entry 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
-- | Lookup the path to the @bash@ interpreter.
bashPath :: Action FilePath
bashPath = lookupInPath "bash"
-- | Lookup an executable in @PATH@.
-- | Lookup a specified 'FilePath' in the system @PATH@.
lookupInPath :: FilePath -> Action FilePath
lookupInPath name
| name == takeFileName name = askOracle $ LookupInPath name
......@@ -68,8 +26,7 @@ lookupInPath name
-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
fixAbsolutePathOnWindows :: FilePath -> Action FilePath
fixAbsolutePathOnWindows path = do
windows <- windowsHost
if windows
if isWindows
then do
let (dir, file) = splitFileName path
winDir <- askOracle $ WindowsPath dir
......@@ -77,6 +34,7 @@ fixAbsolutePathOnWindows path = do
else
return path
newtype LookupInPath = LookupInPath String
deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
......
module Hadrian.Utilities (
-- * String manipulation
quote,
-- * FilePath manipulation
unifyPath, (-/-)
) where
import Development.Shake.FilePath
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
......
......@@ -6,7 +6,6 @@ import Expression
import GHC
import Oracles.Config.Setting
import Oracles.Dependencies
import Oracles.Path
import Rules.Generate
import Settings.Path
import Target
......
......@@ -12,13 +12,12 @@ import Settings.Path
import Util
import GHC
import Rules
import Rules.Wrappers (WrappedBinary(..), installWrappers)
import Rules.Libffi
import Rules.Generate
import Rules.Libffi
import Rules.Wrappers
import Settings.Packages.Rts
import Oracles.Config.Setting
import Oracles.Dependencies
import Oracles.Path
import qualified System.Directory as IO
......
......@@ -2,13 +2,13 @@ module Rules.Oracles (oracleRules) where
import qualified Hadrian.Oracles.ArgsHash
import qualified Hadrian.Oracles.DirectoryContents
import qualified Hadrian.Oracles.Path
import Base
import qualified Oracles.Config
import qualified Oracles.Dependencies
import qualified Oracles.ModuleFiles
import qualified Oracles.PackageData
import qualified Oracles.Path
import Target
import Settings
......@@ -16,8 +16,8 @@ oracleRules :: Rules ()
oracleRules = do
Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
Hadrian.Oracles.DirectoryContents.directoryContentsOracle
Hadrian.Oracles.Path.pathOracle
Oracles.Config.configOracle
Oracles.Dependencies.dependenciesOracles
Oracles.ModuleFiles.moduleFilesOracle
Oracles.PackageData.packageDataOracle
Oracles.Path.pathOracle
......@@ -10,11 +10,9 @@ import Oracles.Config.Setting
import Oracles.Dependencies
import Oracles.ModuleFiles
import Oracles.PackageData
import Oracles.Path (topDirectory)
import Rules.Wrappers (WrappedBinary(..), Wrapper, inplaceWrappers)
import Rules.Wrappers
import Settings
import Settings.Path (buildPath, inplaceLibBinPath, rtsContext, objectPath,
inplaceLibPath, inplaceBinPath, inplaceLibCopyTargets)
import Settings.Path
import Target
import UserSettings
import Util
......
......@@ -7,9 +7,8 @@ import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.Path
import Settings
import Settings.Path (inplaceLibCopyTargets)
import Settings.Path
import Target
import Util
......
......@@ -5,11 +5,11 @@ module Rules.Wrappers (
import Base
import Expression
import GHC
import Settings (getPackages, latestBuildStage)
import Settings.Install (installPackageDbDirectory)
import Settings.Path (buildPath, inplacePackageDbDirectory)
import Oracles.Path (bashPath)
import Oracles.Config.Setting (SettingList(..), settingList)
import Oracles.Config.Setting
import Settings
import Settings.Install
import Settings.Path
import Util
-- | Wrapper is an expression depending on the 'FilePath' to the
-- | library path and name of the wrapped binary.
......@@ -53,7 +53,7 @@ inplaceGhcPkgWrapper :: WrappedBinary -> Expr String
inplaceGhcPkgWrapper WrappedBinary{..} = do
expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
stage <- getStage
top <- getTopDirectory
top <- expr topDirectory
-- Use the package configuration for the next stage in the wrapper.
-- The wrapper is generated in StageN, but used in StageN+1.
let packageDb = top -/- inplacePackageDbDirectory (succ stage)
......@@ -67,7 +67,7 @@ installGhcPkgWrapper :: WrappedBinary -> Expr String
installGhcPkgWrapper WrappedBinary{..} = do
expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
stage <- getStage
top <- getTopDirectory
top <- expr topDirectory
-- Use the package configuration for the next stage in the wrapper.
-- The wrapper is generated in StageN, but used in StageN+1.
let packageDb = installPackageDbDirectory binaryLibPath top (succ stage)
......@@ -95,7 +95,7 @@ hpcWrapper WrappedBinary{..} = do
hsc2hsWrapper :: WrappedBinary -> Expr String
hsc2hsWrapper WrappedBinary{..} = do
top <- getTopDirectory
top <- expr topDirectory
expr $ need [ sourcePath -/- "Rules/Wrappers.hs" ]
contents <- expr $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper"
let executableName = binaryLibPath -/- "bin" -/- binaryName
......
......@@ -6,14 +6,16 @@ module Settings (
integerLibraryName, destDir, pkgConfInstallPath, stage1Only
) where
import Hadrian.Oracles.Path
import Base
import Context
import CmdLineFlag
import Expression
import Flavour
import GHC
import Oracles.Config
import Oracles.PackageData
import Oracles.Path
import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Development
import Settings.Flavours.Performance
......@@ -83,6 +85,42 @@ knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
findKnownPackage :: PackageName -> Maybe Package
findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
-- | 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 system.config entry 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
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case builderProvenance builder of
......
......@@ -5,7 +5,6 @@ module Settings.Builders.Common (
module Oracles.Config.Flag,
module Oracles.Config.Setting,
module Oracles.PackageData,
module Oracles.Path,
module Predicate,
module Settings,
module Settings.Path,
......@@ -20,7 +19,6 @@ import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.PackageData
import Oracles.Path
import Predicate
import Settings
import Settings.Path
......@@ -70,6 +68,6 @@ bootPackageDatabaseArgs = do
stage <- getStage
expr $ need [packageDbStamp stage]
stage0 ? do
path <- getTopDirectory
path <- expr topDirectory
prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=")
arg $ prefix ++ path -/- inplacePackageDbDirectory Stage0
......@@ -12,7 +12,7 @@ configureBuilderArgs = mconcat
, "--build=" ++ buildPlatform ]
, builder (Configure libffiBuildPath) ? do
top <- getTopDirectory
top <- expr topDirectory
targetPlatform <- getSetting TargetPlatform
append [ "--prefix=" ++ top -/- libffiBuildPath -/- "inst"
, "--libdir=" ++ top -/- libffiBuildPath -/- "inst/lib"
......
......@@ -10,7 +10,7 @@ import Util
ghcCabalBuilderArgs :: Args
ghcCabalBuilderArgs = builder GhcCabal ? do
verbosity <- expr getVerbosity
top <- getTopDirectory
top <- expr topDirectory
context <- getContext
when (package context /= deriveConstants) $ expr (need inplaceLibCopyTargets)
mconcat [ arg "configure"
......@@ -35,7 +35,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
ghcCabalHsColourBuilderArgs :: Args
ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
path <- getPackagePath
top <- getTopDirectory
top <- expr topDirectory
context <- getContext
append [ "hscolour", path, top -/- buildPath context ]
......@@ -61,7 +61,7 @@ libraryArgs = do
-- TODO: LD_OPTS?
configureArgs :: Args
configureArgs = do
top <- getTopDirectory
top <- expr topDirectory
let conf key expr = do
values <- unwords <$> expr
not (null values) ?
......@@ -108,7 +108,7 @@ 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 <- getTopDirectory
top <- expr topDirectory
path <- getBuilderPath b
expr $ needBuilder b
arg $ withBuilderKey b ++ unifyPath (top </> path)
......
......@@ -9,7 +9,7 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
gmpDir <- getSetting GmpIncludeDir
cFlags <- getCFlags
lFlags <- getLFlags
top <- getTopDirectory
top <- expr topDirectory
hArch <- getSetting HostArch
hOs <- getSetting HostOs
tArch <- getSetting TargetArch
......
......@@ -43,7 +43,7 @@ rtsPackageArgs = package rts ? do
ghcEnableTNC <- yesNo ghcEnableTablesNextToCode
way <- getWay
path <- getBuildPath
top <- getTopDirectory
top <- expr topDirectory
libffiName <- expr rtsLibffiLibraryName
ffiIncludeDir <- getSetting FfiIncludeDir
ffiLibraryDir <- getSetting FfiLibDir
......
......@@ -6,16 +6,17 @@ module Settings.Path (
pkgConfFile, packageDbStamp, bootPackageConstraints, packageDependencies,
objectPath, inplaceBinPath, inplaceLibBinPath, inplaceLibPath,
inplaceInstallPath, autogenPath, pkgInplaceConfig, ghcSplitPath, stripCmdPath,
pkgSetupConfigFile, inplaceLibCopyTargets, templateHscPath
pkgSetupConfigFile, inplaceLibCopyTargets, templateHscPath, topDirectory
) where
import Hadrian.Oracles.Path
import Base
import Context
import Expression
import GHC
import Oracles.PackageData
import Oracles.Config.Setting
import Oracles.Path
import UserSettings
-- | Path to the directory containing the Shake database and other auxiliary
......@@ -23,6 +24,10 @@ import UserSettings
shakeFilesPath :: FilePath
shakeFilesPath = buildRootPath -/- "hadrian"
-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
-- | Boot package versions extracted from @.cabal@ files.
bootPackageConstraints :: FilePath
bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
......
......@@ -4,7 +4,7 @@ module Util (
moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
makeExecutable, renderProgram, renderLibrary, builderEnvironment,
needBuilder, copyFileUntracked, installDirectory, installData, installScript,
installProgram, linkSymbolic
installProgram, linkSymbolic, bashPath
) where
import qualified System.Directory.Extra as IO
......@@ -13,15 +13,16 @@ import qualified Control.Exception.Base as IO
import Hadrian.Oracles.ArgsHash
import Hadrian.Oracles.DirectoryContents
import Hadrian.Oracles.Path
import Base
import CmdLineFlag
import Context
import Expression
import GHC
import Oracles.Path
import Oracles.Config.Setting
import Settings
import Settings.Path
import Settings.Builders.Ar
import Target
import UserSettings
......@@ -256,6 +257,10 @@ makeExecutable file = do
putBuild $ "| Make " ++ quote file ++ " executable."
quietly $ cmd "chmod +x " [file]
-- | Lookup the path to the @bash@ interpreter.
bashPath :: Action FilePath
bashPath = lookupInPath "bash"
-- | Print out information about the command being executed.
putInfo :: Target -> Action ()
putInfo t = putProgressInfo $ renderAction
......
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