Make PG and BuildPredicate abstract.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 27 Apr 2015 01:36:01 +0000 (02:36 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 27 Apr 2015 01:36:01 +0000 (02:36 +0100)
12 files changed:
src/Expression/BuildExpression.hs
src/Expression/BuildPredicate.hs
src/Expression/Derived.hs
src/Expression/PG.hs
src/Expression/Predicate.hs
src/Expression/Project.hs
src/Expression/Resolve.hs
src/Expression/Settings.hs
src/Expression/Simplify.hs
src/Rules/Data.hs
src/Settings.hs
src/Targets.hs

index 53200d4..f8f5d8f 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+
 module Expression.BuildExpression (
     BuildExpression,
     Ways, Packages, TargetDirs,
@@ -11,7 +13,9 @@ module Expression.BuildExpression (
 import Base
 import Ways
 import Package (Package)
+import Oracles.Builder
 import Expression.PG
+import Expression.Project
 import Expression.BuildPredicate
 
 type BuildExpression v = PG BuildPredicate v
@@ -19,3 +23,33 @@ type BuildExpression v = PG BuildPredicate v
 type Ways       = BuildExpression Way
 type Packages   = BuildExpression Package
 type TargetDirs = BuildExpression TargetDir
+
+-- Projecting a build expression requires examining all predicates and vertices
+instance (Project Package v, Project Package BuildPredicate)
+    => Project Package (BuildExpression v) where
+    project p = bimap (project p) (project p)
+
+instance (Project Builder v, Project Builder BuildPredicate)
+    => Project Builder (BuildExpression v) where
+    project b = bimap (project b) (project b)
+
+instance (Project (Stage -> Builder) v,
+    Project (Stage -> Builder) BuildPredicate)
+    => Project (Stage -> Builder) (BuildExpression v) where
+    project s2b = bimap (project s2b) (project s2b)
+
+instance (Project Stage v, Project Stage BuildPredicate)
+    => Project Stage (BuildExpression v) where
+    project s = bimap (project s) (project s)
+
+instance (Project TargetDir v, Project TargetDir BuildPredicate)
+    => Project TargetDir (BuildExpression v) where
+    project d = bimap (project d) (project d)
+
+instance (Project Way v, Project Way BuildPredicate)
+    => Project Way (BuildExpression v) where
+    project w = bimap (project w) (project w)
+
+instance (Project FilePath v, Project FilePath BuildPredicate)
+    => Project FilePath (BuildExpression v) where
+    project f = bimap (project f) (project f)
index ecc40c4..1b88f3f 100644 (file)
@@ -1,14 +1,16 @@
 {-# LANGUAGE NoImplicitPrelude, TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
 
 module Expression.BuildPredicate (
     BuildVariable (..),
-    BuildPredicate (..)
+    BuildPredicate, rewrite
     ) where
 
 import Base
 import Ways
 import Oracles.Builder
 import Package (Package)
+import Expression.Project
 import Expression.Predicate
 
 -- Build variables that can be used in build predicates
@@ -29,6 +31,21 @@ data BuildPredicate
     | Or  BuildPredicate BuildPredicate -- Disjunction
     deriving Eq -- TODO: create a proper Eq instance (use BDDs?)
 
+-- A (fold like) rewrite of a PG according to given instructions
+rewrite :: (Bool                             -> r) -- how to rewrite Booleans
+        -> (BuildVariable                    -> r) -- how to rewrite variables
+        -> (BuildPredicate                   -> r) -- how to rewrite Not's
+        -> (BuildPredicate -> BuildPredicate -> r) -- how to rewrite And's
+        -> (BuildPredicate -> BuildPredicate -> r) -- how to rewrite Or's
+        -> BuildPredicate                          -- BuildPredicate to rewrite
+        -> r                                       -- result
+rewrite fb fv fn fa fo p = case p of
+    Evaluated   b -> fb b
+    Unevaluated v -> fv v
+    Not         q -> fn   q
+    And       p q -> fa p q
+    Or        p q -> fo p q
+
 instance Predicate BuildPredicate where
     type Variable BuildPredicate = BuildVariable
     variable = Unevaluated
@@ -49,3 +66,48 @@ instance Show BuildPredicate where
         showParen (d > 1) $ showsPrec 1 p . showString " /\\ " . showsPrec 1 q
 
     showsPrec d (Not p) = showChar '!' . showsPrec 2 p
+
+eval :: (BuildVariable -> BuildPredicate) -> BuildPredicate -> BuildPredicate
+eval f = rewrite Evaluated f (Not . eval f) fa fo
+  where
+    fa p q = And (eval f p) (eval f q)
+    fo p q = Or  (eval f p) (eval f q)
+
+instance Project Package BuildPredicate where
+    project p = eval f
+      where
+        f (PackageVariable p') = Evaluated $ p == p'
+        f var                  = Unevaluated var
+
+instance Project Builder BuildPredicate where
+    project b = eval f
+      where
+        f (BuilderVariable b') = Evaluated $ b == b'
+        f var                  = Unevaluated var
+
+instance Project (Stage -> Builder) BuildPredicate where
+    project s2b = eval f
+      where
+        f (BuilderVariable b) = Evaluated $ b `elem` map s2b [Stage0 ..]
+        f var                 = Unevaluated var
+
+instance Project Way BuildPredicate where
+    project w = eval f
+      where
+        f (WayVariable w') = Evaluated $ w == w'
+        f var              = Unevaluated var
+
+instance Project Stage BuildPredicate where
+    project s = eval f
+      where
+        f (StageVariable s') = Evaluated $ s == s'
+        f var                = Unevaluated var
+
+instance Project FilePath BuildPredicate where
+    project f = eval g
+      where
+        g (FileVariable f') = Evaluated $ f == f'
+        g var               = Unevaluated var
+
+-- TargetDirs do not appear in build predicates
+instance Project TargetDir BuildPredicate where
index 2418e3d..e90d438 100644 (file)
@@ -34,7 +34,7 @@ import Expression.BuildPredicate
 import Expression.BuildExpression
 
 -- Auxiliary function for multiway disjunction
-alternatives :: Predicate a => (b -> Variable a) -> [b] -> a
+alternatives :: (a -> BuildVariable) -> [a] -> BuildPredicate
 alternatives f = foldr (||) false . map (variable . f)
 
 -- Basic GHC build predicates
@@ -69,7 +69,7 @@ stage :: Stage -> BuildPredicate
 stage s = stages [s]
 
 notStage :: Stage -> BuildPredicate
-notStage = not . Unevaluated . StageVariable
+notStage = not . variable . StageVariable
 
 way :: Way -> BuildPredicate
 way w = ways [w]
index 7241915..6b7ba42 100644 (file)
@@ -1,19 +1,21 @@
 {-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
 
 module Expression.PG (
+    PG,
+    module Control.Monad,
+    module Control.Applicative,
     module Expression.Predicate,
-    PG (..),
-    bimap, (|>), (?), (??), whenExists, support,
-    msum, mproduct,
+    rewrite, bimap, (|>), (?), (??),
+    mproduct,
+    support, whenExists,
     fromList, fromOrderedList
     ) where
 
-import Data.Functor
 import Control.Monad
 import Control.Applicative
 import Expression.Predicate
 
--- A generic Parameterised Graph datatype
+-- A basic Parameterised Graph datatype
 -- * p is the type of predicates
 -- * v is the type of vertices
 data PG p v = Epsilon
@@ -23,29 +25,57 @@ data PG p v = Epsilon
             | Condition p (PG p v)
             deriving Eq -- TODO: create a proper Eq instance
 
+(|>) :: PG p v -> PG p v -> PG p v
+(|>) = Sequence
+
+(?) :: p -> PG p v -> PG p v
+(?) = Condition
+
+(??) :: Predicate p => p -> (PG p v, PG p v) -> PG p v
+(??) p (t, f) = Overlay (p ? t) (not p ? f)
+
+infixl 7 |>
+infixr 8 ?
+infixr 8 ??
+
+-- A (fold like) rewrite of a PG according to given instructions
+rewrite ::                      r  -- how to rewrite epsilon
+        -> (v                -> r) -- how to rewrite vertices
+        -> (PG p v -> PG p v -> r) -- how to rewrite overlays
+        -> (PG p v -> PG p v -> r) -- how to rewrite sequences
+        -> (p      -> PG p v -> r) -- how to rewrite conditions
+        -> PG p v                  -- PG to rewrite
+        -> r                       -- result
+rewrite fe fv fo fs fc pg = case pg of
+    Epsilon       -> fe            -- Epsilon is preserved
+    Vertex      v -> fv v
+    Overlay   l r -> fo l r
+    Sequence  l r -> fs l r
+    Condition l r -> fc l r
+
+instance Monad (PG p) where
+    return   = Vertex
+    pg >>= f = rewrite Epsilon f fo fs fc pg
+      where
+        fo l r = Overlay   (l >>= f) (r >>= f)
+        fs l r = Sequence  (l >>= f) (r >>= f)
+        fc l r = Condition l         (r >>= f)
+
 instance Functor (PG p) where
     fmap = liftM
 
 bimap :: (p -> q) -> (v -> w) -> PG p v -> PG q w
-bimap _ _ Epsilon = Epsilon
-bimap f g (Vertex      v) = Vertex    (g v)
-bimap f g (Overlay   l r) = Overlay   (bimap f g l) (bimap f g r)
-bimap f g (Sequence  l r) = Sequence  (bimap f g l) (bimap f g r)
-bimap f g (Condition l r) = Condition (f l)         (bimap f g r)
+bimap f g = rewrite Epsilon fv fo fs fc
+  where
+    fv v   = Vertex    (g v        )
+    fo l r = Overlay   (bimap f g l) (bimap f g r)
+    fs l r = Sequence  (bimap f g l) (bimap f g r)
+    fc l r = Condition (f l        ) (bimap f g r)
 
 instance Applicative (PG p) where
     pure = return
     (<*>) = ap
 
-instance Monad (PG p) where
-    return = Vertex
-
-    Epsilon       >>= _ = Epsilon
-    Vertex    v   >>= f = f v
-    Overlay   l r >>= f = Overlay   (l >>= f) (r >>= f)
-    Sequence  l r >>= f = Sequence  (l >>= f) (r >>= f)
-    Condition l r >>= f = Condition l         (r >>= f)
-
 instance MonadPlus (PG p) where
     mzero = Epsilon
     mplus = Overlay
@@ -54,9 +84,6 @@ instance Alternative (PG p) where
     empty = Epsilon
     (<|>) = Overlay
 
-(|>) :: PG p v -> PG p v -> PG p v
-(|>) = Sequence
-
 mproduct :: [PG p v] -> PG p v
 mproduct = foldr (|>) Epsilon
 
@@ -66,17 +93,21 @@ fromList = msum . map return
 fromOrderedList :: [v] -> PG p v
 fromOrderedList = mproduct . map return
 
-infixl 7 |>
-
-(?) :: p -> PG p v -> PG p v
-(?) = Condition
-
-infixl 8 ?
-
-(??) :: Predicate p => p -> (PG p v, PG p v) -> PG p v
-(??) p (t, f) = Overlay (p ? t) (not p ? f)
+-- Returns sorted list of all vertices that appear in a PG
+support :: Ord v => PG p v -> [v]
+support = rewrite [] fv fos fos fc
+  where
+    fv    v = [v]
+    fos l r = support l `union` support r
+    fc  _ r = support r
 
-infixl 8 ??
+union :: Ord v => [v] -> [v] -> [v]
+union ls     []     = ls
+union []     rs     = rs
+union (l:ls) (r:rs) = case compare l r of
+    LT -> l : union ls (r:rs)
+    EQ -> l : union ls rs
+    GT -> r : union (l:ls) rs
 
 -- Given a vertex and a PG return a predicate, which tells when the vertex
 -- exists in the PG.
@@ -87,21 +118,6 @@ whenExists a (Overlay   l r) = whenExists a l || whenExists a r
 whenExists a (Sequence  l r) = whenExists a l || whenExists a r
 whenExists a (Condition x r) = x              && whenExists a r
 
-support :: Ord v => PG p v -> [v]
-support Epsilon         = []
-support (Vertex      v) = [v]
-support (Overlay   l r) = support l `union` support r
-support (Sequence  l r) = support l `union` support r
-support (Condition _ r) = support r
-
-union :: Ord v => [v] -> [v] -> [v]
-union ls     []     = ls
-union []     rs     = rs
-union (l:ls) (r:rs) = case compare l r of
-    LT -> l : union ls (r:rs)
-    EQ -> l : union ls rs
-    GT -> r : union (l:ls) rs
-
 instance (Show p, Show v) => Show (PG p v) where
     showsPrec _ Epsilon       = showString "()"
     showsPrec _ (Vertex v)    = shows v
index 082736e..3f823fa 100644 (file)
@@ -2,12 +2,13 @@
 
 module Expression.Predicate (
     module Prelude,
-    Predicate (..)
+    Predicate (..), fromBool
     ) where
 
 import qualified Prelude
 import Prelude hiding (not, (&&), (||))
 
+-- Minimal complete definition: 'true' or 'false', 'not', '&&' or '||'.
 class Predicate a where
     type Variable a
     variable    :: Variable a -> a
@@ -15,11 +16,24 @@ class Predicate a where
     not         :: a -> a
     (&&), (||)  :: a -> a -> a
 
+    -- Default implementations
+    true   = not false
+    false  = not true
+    x && y = not (not x || not y)
+    x || y = not (not x && not y)
+
+fromBool :: Predicate a => Bool -> a
+fromBool bool = if bool then true else false
+
+infixr 3 &&
+infixr 2 ||
+
 instance Predicate Bool where
-    type Variable Bool = Bool
-    variable = id
+    type Variable Bool = ()
+    variable = const True
     true     = True
     false    = False
     not      = Prelude.not
     (&&)     = (Prelude.&&)
     (||)     = (Prelude.||)
+
index e41bc9e..1652176 100644 (file)
@@ -1,17 +1,12 @@
-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
 
 module Expression.Project (
     Project (..)
     ) where
 
 import Base hiding (Args)
-import Package
 import Ways
-import Oracles.Builder
-import Expression.PG
-import Expression.Settings
-import Expression.BuildPredicate
-import Expression.BuildExpression
+import Package
 
 -- Projecting (partially evaluating) values of type b by setting the
 -- parameters of type a
@@ -19,114 +14,11 @@ class Project a b where
     project :: a -> b -> b
     project = const id
 
--- Project a build predicate recursively through Not, And and Or
-pmap :: Project a BuildPredicate => a -> BuildPredicate -> BuildPredicate
-pmap a (Not p  ) = Not (project a p)
-pmap a (And p q) = And (project a p) (project a q)
-pmap a (Or  p q) = Or  (project a p) (project a q)
-pmap _ p         = p
-
-instance Project Package BuildPredicate where
-    project pkg (Unevaluated (PackageVariable pkg')) = Evaluated $ pkg == pkg'
-    project pkg p = pmap pkg p
-
-instance Project Builder BuildPredicate where
-    project b (Unevaluated (BuilderVariable b')) = Evaluated $ b == b'
-    project b p = pmap b p
-
-instance Project (Stage -> Builder) BuildPredicate where
-    project s2b (Unevaluated (BuilderVariable b)) =
-        Evaluated $ b `elem` map s2b [Stage0 ..]
-    project s2b p = pmap s2b p
-
-instance Project Way BuildPredicate where
-    project w (Unevaluated (WayVariable w')) = Evaluated $ w == w'
-    project w p = pmap w p
-
-instance Project Stage BuildPredicate where
-    project s (Unevaluated (StageVariable s')) = Evaluated $ s == s'
-    project s p = pmap s p
-
-instance Project FilePath BuildPredicate where
-    project f (Unevaluated (FileVariable p)) = Evaluated $ p ?== f
-    project f p = pmap f p
-
--- TargetDirs do not appear in build predicates
-instance Project TargetDir BuildPredicate where
-
 -- Nothing to project in expressions containing FilePaths, Packages or Ways
 instance Project a TargetDir where
 instance Project a Package where
 instance Project a Way where
 
--- Projecting on Way, Stage, Builder, FilePath and staged Builder is trivial:
--- only (Fold Combine Settings) and (EnvironmentParameter PackageConstraints)
--- can be affected (more specifically, the predicates contained in them).
--- This is handled with 'amap'.
-amap :: (Project a Settings, Project a Packages) => a -> Args -> Args
-amap p (Fold combine settings) = Fold combine (project p settings)
-amap p (EnvironmentParameter (PackageConstraints ps)) =
-    EnvironmentParameter $ PackageConstraints $ project p ps
-amap _ a = a
-
-instance Project Way Args where
-    project = amap
-
-instance Project Stage Args where
-    project = amap
-
-instance Project Builder Args where
-    project = amap
-
-instance Project FilePath Args where
-    project = amap
-
-instance Project (Stage -> Builder) Args where
-    project = amap
-
--- Projecting on Package and TargetDir is more interesting.
-instance Project Package Args where
-    project p (BuildParameter PackagePath) = Plain $ pkgPath p
-    project p (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
-        EnvironmentParameter $ pd { pdPackagePath = Just $ pkgPath p }
-    project p a = amap p a
-
-instance Project TargetDir Args where
-    project (TargetDir d) (BuildParameter BuildDir) = Plain d
-    project (TargetDir d) (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
-        EnvironmentParameter $ pd { pdBuildDir = Just d }
-    project d a = amap d a
-
--- Projecting a build expression requires examining all predicates and vertices
-instance (Project Package v, Project Package BuildPredicate)
-    => Project Package (BuildExpression v) where
-    project p = bimap (project p) (project p)
-
-instance (Project Builder v, Project Builder BuildPredicate)
-    => Project Builder (BuildExpression v) where
-    project b = bimap (project b) (project b)
-
-instance (Project (Stage -> Builder) v,
-    Project (Stage -> Builder) BuildPredicate)
-    => Project (Stage -> Builder) (BuildExpression v) where
-    project s2b = bimap (project s2b) (project s2b)
-
-instance (Project Stage v, Project Stage BuildPredicate)
-    => Project Stage (BuildExpression v) where
-    project s = bimap (project s) (project s)
-
-instance (Project TargetDir v, Project TargetDir BuildPredicate)
-    => Project TargetDir (BuildExpression v) where
-    project d = bimap (project d) (project d)
-
-instance (Project Way v, Project Way BuildPredicate)
-    => Project Way (BuildExpression v) where
-    project w = bimap (project w) (project w)
-
-instance (Project FilePath v, Project FilePath BuildPredicate)
-    => Project FilePath (BuildExpression v) where
-    project f = bimap (project f) (project f)
-
 -- Composing projections
 instance (Project a z, Project b z) => Project (a, b) z where
     project (p, q) = project p . project q
index af56f5c..df63cd7 100644 (file)
@@ -15,8 +15,9 @@ import Oracles.PackageData
 import Expression.PG
 import Expression.Derived
 import Expression.Settings
-import Expression.BuildPredicate
 import Expression.BuildExpression
+import qualified Expression.BuildPredicate as BP
+import           Expression.BuildPredicate hiding (rewrite)
 
 -- Resolve unevaluated variables by calling the associated oracles
 class Resolve a where
@@ -80,46 +81,20 @@ instance Resolve Args where
     resolve a = return a
 
 instance Resolve BuildPredicate where
-    resolve p @ (Evaluated _) = return p
+    resolve = BP.rewrite (return . fromBool) fv (fmap not . resolve) fa fo
+      where
+        fv (ConfigVariable key value) = do
+            lookup <- askConfig key
+            return $ fromBool (lookup == value)
+        fv v = return $ variable v
 
-    resolve (Unevaluated (ConfigVariable key value)) = do
-        lookup <- askConfig key
-        return $ Evaluated $ lookup == value
-
-    resolve p @ (Unevaluated _) = return p
-
-    resolve (Not p) = do
-        p' <- resolve p
-        return $ Not p'
-
-    resolve (And p q) = do
-        p' <- resolve p
-        q' <- resolve q
-        return $ And p' q'
-
-    resolve (Or p q) = do
-        p' <- resolve p
-        q' <- resolve q
-        return $ Or p' q'
+        fa p q = (&&) <$> resolve p <*> resolve q
+        fo p q = (||) <$> resolve p <*> resolve q
 
+-- TODO: implement with a bimap
 instance Resolve v => Resolve (BuildExpression v) where
-    resolve Epsilon = return Epsilon
-
-    resolve (Vertex v) = do
-        v' <- resolve v
-        return $ Vertex v'
-
-    resolve (Overlay l r) = do
-            l' <- resolve l
-            r' <- resolve r
-            return $ Overlay l' r'
-
-    resolve (Sequence l r) = do
-            l' <- resolve l
-            r' <- resolve r
-            return $ Sequence l' r'
-
-    resolve (Condition l r) = do
-            l' <- resolve l
-            r' <- resolve r
-            return $ Condition l' r'
+    resolve = rewrite (return empty) (fmap return . resolve) fo fs fc
+      where
+        fo l r = (<|>) <$> resolve l <*> resolve r
+        fs l r = ( |>) <$> resolve l <*> resolve r
+        fc l r = ( ? ) <$> resolve l <*> resolve r
index 64527d7..416aa00 100644 (file)
@@ -1,4 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
 
 module Expression.Settings (
     Args (..), BuildParameter (..), EnvironmentParameter (..),
@@ -6,8 +7,11 @@ module Expression.Settings (
     Settings
     ) where
 
+import Ways
 import Base hiding (Args)
+import Package
 import Oracles.Builder
+import Expression.Project
 import Expression.Predicate
 import Expression.BuildExpression
 
@@ -53,3 +57,41 @@ data Combine = Id            -- Keep given settings as is
 data Arity = Single   -- expands to a single argument
            | Multiple -- expands to a list of arguments
            deriving (Show, Eq)
+
+-- Projecting on Way, Stage, Builder, FilePath and staged Builder is trivial:
+-- only (Fold Combine Settings) and (EnvironmentParameter PackageConstraints)
+-- can be affected (more specifically, the predicates contained in them).
+-- This is handled with 'amap'.
+amap :: (Project a Settings, Project a Packages) => a -> Args -> Args
+amap p (Fold combine settings) = Fold combine (project p settings)
+amap p (EnvironmentParameter (PackageConstraints ps)) =
+    EnvironmentParameter $ PackageConstraints $ project p ps
+amap _ a = a
+
+instance Project Way Args where
+    project = amap
+
+instance Project Stage Args where
+    project = amap
+
+instance Project Builder Args where
+    project = amap
+
+instance Project FilePath Args where
+    project = amap
+
+instance Project (Stage -> Builder) Args where
+    project = amap
+
+-- Projecting on Package and TargetDir is more interesting.
+instance Project Package Args where
+    project p (BuildParameter PackagePath) = Plain $ pkgPath p
+    project p (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
+        EnvironmentParameter $ pd { pdPackagePath = Just $ pkgPath p }
+    project p a = amap p a
+
+instance Project TargetDir Args where
+    project (TargetDir d) (BuildParameter BuildDir) = Plain d
+    project (TargetDir d) (EnvironmentParameter pd @ (PackageData _ _ _ _)) =
+        EnvironmentParameter $ pd { pdBuildDir = Just d }
+    project d a = amap d a
index bdbc734..438879c 100644 (file)
@@ -9,7 +9,8 @@ import Ways
 import Package
 import Expression.PG
 import Expression.Settings
-import Expression.BuildPredicate
+import qualified Expression.BuildPredicate as BP
+import           Expression.BuildPredicate hiding (rewrite)
 import Expression.BuildExpression
 
 -- Simplify expressions by constant propagation
@@ -20,14 +21,15 @@ class Simplify a where
 -- Linearise a build expression into a list. Returns Nothing if the given
 -- expression cannot be uniquely evaluated due to remaining variables.
 -- Overlay subexpressions are linearised in arbitrary order.
+-- TODO: topological sort
 linearise :: (Predicate p, Simplify (PG p v)) => PG p v -> Maybe [v]
 linearise = go . simplify
   where
-    go Epsilon         = Just []
-    go (Vertex v)      = Just [v]
-    go (Overlay   p q) = (++) <$> go p <*> go q -- TODO: union
-    go (Sequence  p q) = (++) <$> go p <*> go q
-    go (Condition _ _) = Nothing
+    go     = rewrite (Just []) fv fo fs fc
+    fv v   = Just [v]
+    fo l r = (++) <$> go l <*> go r -- TODO: merge
+    fs l r = (++) <$> go l <*> go r
+    fc _ _ = Nothing
 
 fromArgs :: Args -> BuildExpression (Maybe [String])
 fromArgs (Plain s) = return $ Just [s]
@@ -59,30 +61,31 @@ fromSettings settings = case linearise (settings >>= fromArgs) of
     concatMaybes (Nothing : _) = Nothing
 
 instance Simplify BuildPredicate where
-    simplify p @ (Evaluated _) = p
-    simplify p @ (Unevaluated _) = p
-    simplify (Not p) = case p' of
-        Evaluated bool -> Evaluated (not bool)
-        _              -> Not p'
-      where p' = simplify p
-    simplify (And p q)
-        | p' == false = false
-        | q' == false = false
-        | p' == true  = q'
-        | q' == true  = p'
-        | otherwise   = And p' q'
+    simplify = BP.rewrite fromBool variable simplifyN simplifyA simplifyO
       where
-        p' = simplify p
-        q' = simplify q
-    simplify (Or p q)
-        | p' == true  = true
-        | q' == true  = true
-        | p' == false = q'
-        | q' == false = p'
-        | otherwise   = Or p' q'
-      where
-        p' = simplify p
-        q' = simplify q
+        simplifyN p
+            | p' == true  = false
+            | p' == false = true
+            | otherwise   = not p'
+          where p' = simplify p
+        simplifyA p q
+            | p' == false = false
+            | q' == false = false
+            | p' == true  = q'
+            | q' == true  = p'
+            | otherwise   = p' && q'
+          where
+            p' = simplify p
+            q' = simplify q
+        simplifyO p q
+            | p' == true  = true
+            | q' == true  = true
+            | p' == false = q'
+            | q' == false = p'
+            | otherwise   = p' || q'
+          where
+            p' = simplify p
+            q' = simplify q
 
 -- Nothing to simplify here
 instance Simplify Way where
@@ -97,28 +100,28 @@ instance Simplify Args where
 
 instance (Simplify p, Simplify v, Predicate p, Eq p, Eq v) => Simplify (PG p v)
   where
-    simplify Epsilon = Epsilon
-    simplify (Vertex v) = Vertex $ simplify v
-    simplify (Overlay l r)
-        | l' == Epsilon = r'
-        | r' == Epsilon = l'
-        | l' == r'      = l'
-        | otherwise     = Overlay l' r'
-      where
-        l' = simplify l
-        r' = simplify r
-    simplify (Sequence l r)
-        | l' == Epsilon = r'
-        | r' == Epsilon = l'
-        | otherwise     = Sequence l' r'
-      where
-        l' = simplify l
-        r' = simplify r
-    simplify (Condition l r)
-        | l' == true    = r'
-        | l' == false   = Epsilon
-        | r' == Epsilon = Epsilon
-        | otherwise     = Condition l' r'
+    simplify = rewrite empty (return . simplify) simplifyO simplifyS simplifyC
       where
-        l' = simplify l
-        r' = simplify r
+        simplifyO l r
+            | l' == empty = r'
+            | r' == empty = l'
+            | l' == r'    = l'
+            | otherwise   = l' <|> r'
+          where
+            l' = simplify l
+            r' = simplify r
+        simplifyS l r
+            | l' == empty = r'
+            | r' == empty = l'
+            | otherwise   = l' |> r'
+          where
+            l' = simplify l
+            r' = simplify r
+        simplifyC l r
+            | l' == true  = r'
+            | l' == false = empty
+            | r' == empty = empty
+            | otherwise   = l' ? r'
+          where
+            l' = simplify l
+            r' = simplify r
index 2cb84bb..8ca5d89 100644 (file)
@@ -174,7 +174,7 @@ ccSettings = msum
         , arg "-Wall"
         , gccIsClang ??
           ( arg "-Wno-unknown-pragmas" <|>
-            not gccLt46 && windowsHost ? arg "-Werror=unused-but-set-variable"
+            not gccLt46 ? windowsHost ? arg "-Werror=unused-but-set-variable"
           , not gccLt46 ? arg "-Wno-error=inline" )]]
 
 ldSettings :: Settings
index c2f39e7..e000d72 100644 (file)
@@ -20,7 +20,7 @@ packageSettings = msum
     [ args ["-hide-all-packages", "-no-user-package-db", "-include-pkg-deps"]
     , stage Stage0 ?
       (arg "-package-db" |> argPath "libraries/bootstrapping.conf")
-    , supportsPackageKey && notStage Stage0 ??
+    , supportsPackageKey ? notStage Stage0 ??
       ( argPairs "-this-package-key" argPackageKey <|>
         argPairs "-package-key"      argPackageDepKeys
       , argPairs "-package-name"     argPackageKey <|>
index 9684e14..a7a3532 100644 (file)
@@ -23,7 +23,7 @@ targetPackages = msum
 packagesStage0 :: Packages
 packagesStage0 = msum
     [ fromList [ binPackageDb, binary, cabal, hoopl, hpc, transformers ]
-    , not windowsHost && not (targetOs "ios") ? return terminfo ]
+    , not windowsHost ? not (targetOs "ios") ? return terminfo ]
 
 packagesStage1 :: Packages
 packagesStage1 = msum
@@ -104,7 +104,7 @@ customConfigureSettings :: Settings
 customConfigureSettings = msum
     [ package base    ? arg ("--flags=" ++ integerLibraryName)
     , package ghcPrim ? arg "--flag=include-ghc-prim"
-    , package integerLibrary && windowsHost ?
+    , package integerLibrary ? windowsHost ?
         arg "--configure-option=--with-intree-gmp"
     ]