Commit ff86f40e authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactoring for consistent interface (getters) for expressions.

parent d9d1dd9e
......@@ -9,6 +9,7 @@ module Expression (
apply, append, appendM, remove,
appendSub, appendSubD, filterSub, removeSub,
interpret, interpretExpr,
getStage, getPackage, getBuilder, getFiles, getWay,
stage, package, builder, file, way
) where
......@@ -16,7 +17,9 @@ import Way
import Stage
import Builder
import Package
import Target
import Target (Target)
import Target hiding (Target(..))
import qualified Target
import Oracles.Base
import Data.List
import Data.Monoid
......@@ -148,18 +151,34 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
-- Convenient getters for target parameters
getStage :: Expr Stage
getStage = asks Target.stage
getPackage :: Expr Package
getPackage = asks Target.package
getBuilder :: Expr Builder
getBuilder = asks Target.builder
getFiles :: Expr [FilePath]
getFiles = asks Target.files
getWay :: Expr Way
getWay = asks Target.way
-- Basic predicates (see Switches.hs for derived predicates)
stage :: Stage -> Predicate
stage s = liftM (s ==) (asks getStage)
stage s = liftM (s ==) getStage
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)
package p = liftM (p ==) getPackage
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)
builder b = liftM (b ==) getBuilder
file :: FilePattern -> Predicate
file f = liftM (any (f ?==)) (asks getFiles)
file f = liftM (any (f ?==)) getFiles
way :: Way -> Predicate
way w = liftM (w ==) (asks getWay)
way w = liftM (w ==) getWay
......@@ -5,6 +5,7 @@ module Rules.Actions (
import Util
import Builder
import Expression
import qualified Target
import Settings.Args
import Settings.Util
import Oracles.ArgsHash
......@@ -18,7 +19,7 @@ build target = do
argList <- interpret target args
-- The line below forces the rule to be rerun if the args hash has changed
argsHash <- askArgsHash target
run (getBuilder target) argList
run (Target.builder target) argList
buildWhen :: Predicate -> FullTarget -> Action ()
buildWhen predicate target = do
......
......@@ -9,6 +9,7 @@ import Package
import Builder
import Switches
import Expression
import qualified Target
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.TargetDirectory
......@@ -20,8 +21,8 @@ import Development.Shake
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: StagePackageTarget -> Rules ()
buildPackageData target =
let stage = getStage target
pkg = getPackage target
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
in
(path -/-) <$>
......
......@@ -21,8 +21,8 @@ import Control.Applicative
cabalArgs :: Args
cabalArgs = builder GhcCabal ? do
stage <- asks getStage
pkg <- asks getPackage
stage <- getStage
pkg <- getPackage
mconcat [ arg "configure"
, arg $ pkgPath pkg
, arg $ targetDirectory stage pkg
......@@ -43,7 +43,7 @@ cabalArgs = builder GhcCabal ? do
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs :: Args
libraryArgs = do
ways <- fromDiffExpr Settings.Ways.ways
ways <- getWays
ghcInterpreter <- lift $ ghcWithInterpreter
append [ if vanilla `elem` ways
then "--enable-library-vanilla"
......@@ -60,7 +60,7 @@ libraryArgs = do
configureArgs :: Args
configureArgs = do
stage <- asks getStage
stage <- getStage
let conf key = appendSubD $ "--configure-option=" ++ key
cFlags = mconcat [ ccArgs
, remove ["-Werror"]
......@@ -82,7 +82,7 @@ configureArgs = do
bootPackageDbArgs :: Args
bootPackageDbArgs = do
sourcePath <- lift . setting $ GhcSourcePath
sourcePath <- getSetting GhcSourcePath
arg $ "--package-db=" ++ sourcePath -/- "libraries/bootstrapping.conf"
-- This is a positional argument, hence:
......@@ -93,7 +93,7 @@ dllArgs = arg ""
packageConstraints :: Args
packageConstraints = do
pkgs <- fromDiffExpr packages
pkgs <- getPackages
constraints <- lift $ forM pkgs $ \pkg -> do
let cabal = pkgPath pkg -/- pkgCabal pkg
prefix = dropExtension (pkgCabal pkg) ++ " == "
......
......@@ -16,13 +16,13 @@ import Development.Shake
ghcMArgs :: Args
ghcMArgs = do
stage <- asks getStage
stage <- getStage
builder (GhcM stage) ? do
pkg <- asks getPackage
pkg <- getPackage
cppArgs <- getPkgDataList CppArgs
hsArgs <- getPkgDataList HsArgs
hsSrcs <- getHsSources
ways <- fromDiffExpr Settings.Ways.ways
ways <- getWays
let buildPath = targetPath stage pkg -/- "build"
mconcat
[ arg "-M"
......@@ -39,9 +39,9 @@ ghcMArgs = do
packageGhcArgs :: Args
packageGhcArgs = do
stage <- asks getStage
supportsPackageKey <- lift . flag $ SupportsPackageKey
pkgKey <- getPkgData PackageKey
stage <- getStage
supportsPackageKey <- getFlag SupportsPackageKey
pkgKey <- getPkgData PackageKey
pkgDepKeys <- getPkgDataList DepKeys
pkgDeps <- getPkgDataList Deps
mconcat
......@@ -57,8 +57,8 @@ packageGhcArgs = do
includeGhcArgs :: Args
includeGhcArgs = do
stage <- asks getStage
pkg <- asks getPackage
stage <- getStage
pkg <- getPackage
srcDirs <- getPkgDataList SrcDirs
includeDirs <- getPkgDataList IncludeDirs
let buildPath = targetPath stage pkg -/- "build"
......@@ -76,8 +76,8 @@ includeGhcArgs = do
getHsSources :: Expr [FilePath]
getHsSources = do
stage <- asks getStage
pkg <- asks getPackage
stage <- getStage
pkg <- getPackage
srcDirs <- getPkgDataList SrcDirs
let autogenPath = targetPath stage pkg -/- "build/autogen"
dirs = autogenPath : map (pkgPath pkg -/-) srcDirs
......
......@@ -12,8 +12,8 @@ import Settings.TargetDirectory
ghcPkgArgs :: Args
ghcPkgArgs = do
stage <- asks getStage
pkg <- asks getPackage
stage <- getStage
pkg <- getPackage
builder (GhcPkg stage) ? mconcat
[ arg "update"
, arg "--force"
......
module Settings.Packages (
module Settings.Default,
packages, knownPackages
packages, getPackages, knownPackages
) where
import Package
......@@ -14,6 +14,9 @@ import Settings.Default
packages :: Packages
packages = defaultPackages <> userPackages
getPackages :: Expr [Package]
getPackages = fromDiffExpr packages
-- These are the packages we build by default
defaultPackages :: Packages
defaultPackages = mconcat
......
......@@ -2,6 +2,7 @@ module Settings.Util (
-- Primitive settings elements
arg, argM,
argSetting, argSettingList,
getFlag, getSetting, getSettingList,
getPkgData, getPkgDataList,
appendCcArgs,
needBuilder
......@@ -16,6 +17,7 @@ module Settings.Util (
import Builder
import Expression
import Oracles.Base
import Oracles.Flag
import Oracles.Setting
import Oracles.PackageData
import Settings.User
......@@ -34,24 +36,31 @@ argSetting = argM . setting
argSettingList :: SettingList -> Args
argSettingList = appendM . settingList
getFlag :: Flag -> Expr Bool
getFlag = lift . flag
getSetting :: Setting -> Expr String
getSetting = lift . setting
getSettingList :: SettingList -> Expr [String]
getSettingList = lift . settingList
getPkgData :: (FilePath -> PackageData) -> Expr String
getPkgData key = do
stage <- asks getStage
pkg <- asks getPackage
let path = targetPath stage pkg
lift . pkgData . key $ path
stage <- getStage
pkg <- getPackage
lift . pkgData . key $ targetPath stage pkg
getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
getPkgDataList key = do
stage <- asks getStage
pkg <- asks getPackage
let path = targetPath stage pkg
lift . pkgDataList . key $ path
stage <- getStage
pkg <- getPackage
lift . pkgDataList . key $ targetPath stage pkg
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
stage <- asks getStage
stage <- getStage
mconcat [ builder (Gcc stage) ? append xs
, builder GhcCabal ? appendSub "--configure-option=CFLAGS" xs
, builder GhcCabal ? appendSub "--gcc-options" xs ]
......
module Settings.Ways (
ways
ways, getWays
) where
import Way
......@@ -13,6 +13,9 @@ import Settings.User
ways :: Ways
ways = defaultWays <> userWays
getWays :: Expr [Way]
getWays = fromDiffExpr ways
-- These are default ways
defaultWays :: Ways
defaultWays = mconcat
......
......@@ -4,9 +4,10 @@ module Switches (
) where
import Stage
import Expression
import Settings.Util
import Oracles.Flag
import Oracles.Setting
import Expression
-- Derived predicates
stage0 :: Predicate
......@@ -30,11 +31,11 @@ registerPackage = return True
splitObjects :: Predicate
splitObjects = do
stage <- asks getStage
notBroken <- notP . flag $ SplitObjectsBroken
notGhcUnreg <- notP . flag $ GhcUnregisterised
goodArch <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
goodOs <- lift $ targetOss [ "mingw32", "cygwin32", "linux"
, "darwin", "solaris2", "freebsd"
, "dragonfly", "netbsd", "openbsd"]
return $ notBroken && notGhcUnreg && stage == Stage1 && goodArch && goodOs
stage <- getStage -- We don't split bootstrap (stage 0) packages
broken <- getFlag SplitObjectsBroken
ghcUnreg <- getFlag GhcUnregisterised
goodArch <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
goodOs <- lift $ targetOss [ "mingw32", "cygwin32", "linux"
, "darwin", "solaris2", "freebsd"
, "dragonfly", "netbsd", "openbsd"]
return $ not broken && not ghcUnreg && stage == Stage1 && goodArch && goodOs
{-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
module Target (
Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
stageTarget, stagePackageTarget, fullTarget, fullTargetWithWay
stageTarget, stagePackageTarget, fullTarget, fullTarwithWay
) where
import Way
......@@ -16,39 +16,40 @@ import Development.Shake.Classes
-- be built and the Way they are to be built.
data Target = Target
{
getStage :: Stage,
getPackage :: Package,
getFiles :: [FilePath],
getBuilder :: Builder,
getWay :: Way
stage :: Stage,
package :: Package,
files :: [FilePath],
builder :: Builder,
way :: Way
}
deriving (Eq, Generic)
-- StageTarget is a Target whose field getStage is already assigned
-- StageTarget is a partially constructed Target. Only stage is guaranteed to
-- be assigned.
type StageTarget = Target
stageTarget :: Stage -> StageTarget
stageTarget stage = Target
stageTarget s = Target
{
getStage = stage,
getPackage = error "stageTarget: Package not set",
getFiles = error "stageTarget: Files not set",
getBuilder = error "stageTarget: Builder not set",
getWay = vanilla -- most targets are built only one way (vanilla)
stage = s,
package = error "stageTarget: Package not set",
files = error "stageTarget: Files not set",
builder = error "stageTarget: Builder not set",
way = vanilla
}
-- StagePackageTarget is a Target whose fields getStage and getPackage are
-- already assigned
-- StagePackageTarget is a partially constructed Target. Only stage and package
-- are guaranteed to be assigned.
type StagePackageTarget = Target
stagePackageTarget :: Stage -> Package -> StagePackageTarget
stagePackageTarget stage package = Target
stagePackageTarget s p = Target
{
getStage = stage,
getPackage = package,
getFiles = error "stagePackageTarget: Files not set",
getBuilder = error "stagePackageTarget: Builder not set",
getWay = vanilla
stage = s,
package = p,
files = error "stagePackageTarget: Files not set",
builder = error "stagePackageTarget: Builder not set",
way = vanilla
}
-- FullTarget is a Target whose fields are all assigned
......@@ -56,29 +57,29 @@ type FullTarget = Target
-- Most targets are built only one way, vanilla, hence we set it by default.
fullTarget :: StagePackageTarget -> [FilePath] -> Builder -> FullTarget
fullTarget target files builder = target
fullTarget target fs b = target
{
getFiles = files,
getBuilder = builder,
getWay = vanilla
files = fs,
builder = b,
way = vanilla
}
-- Use this function to be explicit about build the way.
fullTargetWithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget
fullTargetWithWay target files builder way = target
-- Use this function to be explicit about the build way.
fullTarwithWay :: StagePackageTarget -> [FilePath] -> Builder -> Way -> FullTarget
fullTarwithWay target fs b w = target
{
getFiles = files,
getBuilder = builder,
getWay = way
files = fs,
builder = b,
way = w
}
-- Shows a (full) target as "package:file@stage (builder, way)"
instance Show FullTarget where
show target = show (getPackage target)
++ ":" ++ show (getFiles target)
++ "@" ++ show (getStage target)
++ " (" ++ show (getBuilder target)
++ ", " ++ show (getWay target) ++ ")"
show target = show (package target)
++ ":" ++ show (files target)
++ "@" ++ show (stage target)
++ " (" ++ show (builder target)
++ ", " ++ show (way target) ++ ")"
-- Instances for storing in the Shake database
instance Binary FullTarget
......
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