Predicates.hs 1.78 KB
Newer Older
1
module Predicates (
2
    stage, package, builder, stagedBuilder, file, way,
3
    stage0, stage1, stage2, notStage, notStage0,
4
    registerPackage, splitObjects
5 6
    ) where

7
import Expression
8
import GHC
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import Oracles
10

11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
-- 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

32 33 34 35 36 37 38 39 40 41
-- Derived predicates
stage0 :: Predicate
stage0 = stage Stage0

stage1 :: Predicate
stage1 = stage Stage1

stage2 :: Predicate
stage2 = stage Stage2

42 43 44 45 46 47
notStage :: Stage -> Predicate
notStage = notP . stage

notStage0 :: Predicate
notStage0 = notP stage0

48 49 50 51
-- TODO: Actually, we don't register compiler in some circumstances -- fix.
registerPackage :: Predicate
registerPackage = return True

52 53
splitObjects :: Predicate
splitObjects = do
54 55 56 57 58 59 60 61 62
    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