Commit 353b02bd authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Make PG and BuildPredicate abstract.

parent 51028b8d
{-# 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)
{-# 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
......@@ -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]
......
{-# 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
......
......@@ -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.||)
{-# 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
......
......@@ -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
{-# 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