Commit 5dd20f0d authored by Andrey Mokhov's avatar Andrey Mokhov

Minor revision

parent e37a5f77
......@@ -7,7 +7,7 @@ module Expression (
-- ** Predicates
(?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
input, inputs, output, outputs, way, libraryPackage,
libraryPackage, way, input, inputs, output, outputs,
-- ** Evaluation
interpret, interpretInContext,
......@@ -17,7 +17,7 @@ module Expression (
-- * Convenient accessors
getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
getInput, getOutput, getSetting, getSettingList, getStagedSettingList, getFlag,
getInput, getOutput, getSetting, getSettingList, getStagedSettingList,
-- * Re-exports
module Data.Semigroup,
......@@ -40,7 +40,6 @@ import Stage
import Target hiding (builder, inputs, outputs)
import Way
import Oracles.Config.Flag
import Oracles.Config.Setting
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
......@@ -55,20 +54,18 @@ type Args = H.Args Context Builder
type Packages = Expr [Package]
type Ways = Expr [Way]
-- Basic operations on expressions:
-- | Get a configuration setting.
getSetting :: Setting -> Expr String
getSetting = expr . setting
getSettingList :: SettingList -> Expr [String]
-- | Get a list of configuration settings.
getSettingList :: SettingList -> Args
getSettingList = expr . settingList
getStagedSettingList :: (Stage -> SettingList) -> Expr [String]
-- | Get a list of configuration settings for the current stage.
getStagedSettingList :: (Stage -> SettingList) -> Args
getStagedSettingList f = getSettingList . f =<< getStage
getFlag :: Flag -> Predicate
getFlag = expr . flag
-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
stage s = (s ==) <$> getStage
......
......@@ -211,7 +211,7 @@ generateGhcPlatformH = do
targetArch <- getSetting TargetArch
targetOs <- getSetting TargetOs
targetVendor <- getSetting TargetVendor
ghcUnreg <- getFlag GhcUnregisterised
ghcUnreg <- expr $ flag GhcUnregisterised
return . unlines $
[ "#ifndef __GHCPLATFORM_H__"
, "#define __GHCPLATFORM_H__"
......@@ -275,7 +275,7 @@ generateConfigHs = do
cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
cLibFFI <- expr useLibFFIForAdjustors
rtsWays <- getRtsWays
cGhcRtsWithLibdw <- getFlag WithLibdw
cGhcRtsWithLibdw <- expr $ flag WithLibdw
let cGhcRTSWays = unwords $ map show rtsWays
return $ unlines
[ "{-# LANGUAGE CPP #-}"
......@@ -349,7 +349,7 @@ generateGhcAutoconfH = do
trackGenerateHs
configHContents <- expr $ map undefinePackage <$> readFileLines configH
tablesNextToCode <- expr ghcEnableTablesNextToCode
ghcUnreg <- getFlag GhcUnregisterised
ghcUnreg <- expr $ flag GhcUnregisterised
ccLlvmBackend <- getSetting CcLlvmBackend
ccClangBackend <- getSetting CcClangBackend
return . unlines $
......
module Settings (
getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
getContextDirectory, getBuildPath, stagePackages, builderPath,
findKnownPackage, getPkgData, getPkgDataList, isLibrary,
getBuildPath, stagePackages, builderPath,
getBuilderPath, isSpecified, latestBuildStage, programPath, programContext,
integerLibraryName, destDir, pkgConfInstallPath, stage1Only
) where
......@@ -25,27 +25,21 @@ import Settings.Flavours.Quickest
import Settings.Path
import UserSettings
getArgs :: Expr [String]
getArgs :: Args
getArgs = args flavour
getLibraryWays :: Expr [Way]
getLibraryWays :: Ways
getLibraryWays = libraryWays flavour
getRtsWays :: Expr [Way]
getRtsWays :: Ways
getRtsWays = rtsWays flavour
getPackages :: Expr [Package]
getPackages :: Packages
getPackages = packages flavour
stagePackages :: Stage -> Action [Package]
stagePackages stage = interpretInContext (stageContext stage) getPackages
getPackagePath :: Expr FilePath
getPackagePath = pkgPath <$> getPackage
getContextDirectory :: Expr FilePath
getContextDirectory = stageDirectory <$> getStage
getBuildPath :: Expr FilePath
getBuildPath = buildPath <$> getContext
......@@ -80,7 +74,7 @@ programContext stage pkg
knownPackages :: [Package]
knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
-- TODO: Speed up?
-- 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
......@@ -156,12 +150,12 @@ programPath context@Context {..} = do
pkgConfInstallPath :: FilePath
pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) -/- "package.conf.install"
-- | Stage1Only flag
-- TODO: Set this by cmdline flags
-- TODO: Set this from command line
-- | Stage1Only flag.
stage1Only :: Bool
stage1Only = defaultStage1Only
-- | Install's DESTDIR flag
-- TODO: Set this by cmdline flags
-- TODO: Set this from command line
-- | Install's DESTDIR setting.
destDir :: FilePath
destDir = defaultDestDir
module Settings.Builders.Ghc (
ghcBuilderArgs, ghcMBuilderArgs, haddockGhcArgs,
ghcCbuilderArgs
) where
ghcBuilderArgs, ghcMBuilderArgs, haddockGhcArgs, ghcCbuilderArgs
) where
import Flavour
import GHC
import Settings.Builders.Common
ghcBuilderArgs :: Args
......@@ -18,6 +16,11 @@ ghcBuilderArgs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
, getInputs
, arg "-o", arg =<< getOutput ]
needTouchy :: Expr ()
needTouchy = notStage0 ? do
maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
expr . whenJust maybePath $ \path -> need [path]
ghcCbuilderArgs :: Args
ghcCbuilderArgs =
builder (Ghc CompileCWithGhc) ? do
......@@ -58,11 +61,6 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
, pure [ "-optl-l" ++ lib | lib <- libs ++ gmpLibs ]
, pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
needTouchy :: Expr ()
needTouchy = notStage0 ? do
maybePath <- expr $ programPath (vanillaContext Stage0 touchy)
expr . whenJust maybePath $ \path -> need [path]
splitObjectsArgs :: Args
splitObjectsArgs = splitObjects flavour ? do
expr $ need [ghcSplitPath]
......@@ -116,10 +114,10 @@ wayGhcArgs = do
-- FIXME: Get rid of to-be-deprecated -this-package-key.
packageGhcArgs :: Args
packageGhcArgs = do
compId <- getPkgData ComponentId
compId <- getPkgData ComponentId
thisArg <- do
not0 <- notStage0
unit <- getFlag SupportsThisUnitId
unit <- expr $ flag SupportsThisUnitId
return $ if not0 || unit then "-this-unit-id " else "-this-package-key "
mconcat [ arg "-hide-all-packages"
, arg "-no-user-package-db"
......
......@@ -14,7 +14,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
context <- getContext
when (package context /= deriveConstants) $ expr (need inplaceLibCopyTargets)
mconcat [ arg "configure"
, arg =<< getPackagePath
, arg =<< pkgPath <$> getPackage
, arg $ top -/- buildPath context
, dll0Args
, withStaged $ Ghc CompileHs
......@@ -34,7 +34,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
ghcCabalHsColourBuilderArgs :: Args
ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
path <- getPackagePath
path <- pkgPath <$> getPackage
top <- expr topDirectory
context <- getContext
pure [ "hscolour", path, top -/- buildPath context ]
......
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