[commit: ghc] wip/nfs-locking: Move basic predicates to src/Switches.hs. (4d70a1e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/4d70a1e6a5f3ed5353fa9d6af2daf013d1dde318/ghc

>---------------------------------------------------------------

commit 4d70a1e6a5f3ed5353fa9d6af2daf013d1dde318
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Fri Aug 21 16:09:43 2015 +0100

    Move basic predicates to src/Switches.hs.


>---------------------------------------------------------------

4d70a1e6a5f3ed5353fa9d6af2daf013d1dde318
 src/Expression.hs | 40 ++++------------------------------------
 src/Switches.hs   | 46 +++++++++++++++++++++++++++++++++++-----------
 2 files changed, 39 insertions(+), 47 deletions(-)

diff --git a/src/Expression.hs b/src/Expression.hs
index 44be38f..d51f434c 100644
--- a/src/Expression.hs
+++ b/src/Expression.hs
@@ -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
diff --git a/src/Switches.hs b/src/Switches.hs
index 244c87f..c30a33f 100644
--- a/src/Switches.hs
+++ b/src/Switches.hs
@@ -1,15 +1,40 @@
 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