Commit 4d70a1e6 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Move basic predicates to src/Switches.hs.

parent 7baa070b
......@@ -10,8 +10,7 @@ module Expression (
appendSub, appendSubD, filterSub, removeSub,
interpret, interpretDiff,
getStage, getPackage, getBuilder, getFiles, getFile,
getSources, getSource, getWay,
stage, package, builder, stagedBuilder, file, way
getSources, getSource, getWay
) where
import Way
......@@ -30,13 +29,6 @@ import Control.Monad.Reader hiding (liftIO)
-- parameters of the current build Target.
type Expr a = ReaderT Target Action a
-- If values of type a form a Monoid then so do computations of type Expr a:
-- * the empty computation returns the identity element of the underlying type
-- * two computations can be combined by combining their results
instance Monoid a => Monoid (Expr a) where
mempty = return mempty
mappend = liftM2 mappend
-- Diff a holds functions of type a -> a and is equipped with a Monoid instance.
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
-- The name comes from "difference lists".
......@@ -105,7 +97,7 @@ p ?? (t, f) = p ? t <> notP p ? f
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
appendM mx = lift mx >>= append
appendM = (append =<<) . lift
-- appendSub appends a list of sub-arguments to all arguments starting with a
-- given prefix. If there is no argument with such prefix then a new argument
......@@ -185,29 +177,5 @@ getFile = do
target <- ask
files <- getFiles
case files of
[file] -> return file
_ -> error $ "Exactly one file expected in target " ++ show target
-- Basic predicates (see Switches.hs for derived predicates)
stage :: Stage -> Predicate
stage s = liftM (s ==) getStage
package :: Package -> Predicate
package p = liftM (p ==) getPackage
-- For unstaged builders, e.g. GhcCabal
builder :: Builder -> Predicate
builder b = liftM (b ==) getBuilder
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = do
stage <- getStage
builder <- getBuilder
return $ builder == sb stage
file :: FilePattern -> Predicate
file f = liftM (any (f ?==)) getFiles
way :: Way -> Predicate
way w = liftM (w ==) getWay
[res] -> return res
_ -> error $ "Exactly one file expected in target " ++ show target
module Switches (
stage, package, builder, stagedBuilder, file, way,
stage0, stage1, stage2, notStage, notStage0,
registerPackage, splitObjects
) where
import Way
import Base
import Stage
import Package
import Builder
import Expression
import Settings.Util
import Settings.Default
import Oracles.Flag
import Oracles.Setting
-- Basic predicates (see Switches.hs for derived predicates)
stage :: Stage -> Predicate
stage s = liftM (s ==) getStage
package :: Package -> Predicate
package p = liftM (p ==) getPackage
-- For unstaged builders, e.g. GhcCabal
builder :: Builder -> Predicate
builder b = liftM (b ==) getBuilder
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = (builder . sb) =<< getStage
file :: FilePattern -> Predicate
file f = liftM (any (f ?==)) getFiles
way :: Way -> Predicate
way w = liftM (w ==) getWay
-- Derived predicates
stage0 :: Predicate
stage0 = stage Stage0
......@@ -32,13 +57,12 @@ registerPackage = return True
splitObjects :: Predicate
splitObjects = do
stage <- getStage -- We don't split bootstrap (stage 0) packages
package <- getPackage -- We don't split compiler
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 $ stage == Stage1 && package /= compiler && not broken
&& not ghcUnreg && goodArch && goodOs
goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
goodPkg <- notP $ package compiler -- We don't split compiler
broken <- lift $ flag SplitObjectsBroken
ghcUnreg <- lift $ flag GhcUnregisterised
goodArch <- lift $ targetArchs [ "i386", "x86_64", "powerpc", "sparc" ]
goodOs <- lift $ targetOss [ "mingw32", "cygwin32", "linux", "darwin"
, "solaris2", "freebsd", "dragonfly"
, "netbsd", "openbsd" ]
return $ goodStage && goodPkg && not broken && not ghcUnreg && goodArch && goodOs
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