Commit a827aa58 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

New refactoring started: switching to a shallow embedding.

parent 353b02bd
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
module Control.Monad.Reader,
Ways,
Packages,
TargetDir,
Predicate,
Expression,
Environment (..),
interpret,
whenPredicate, (?), stage, notStage, package,
configKeyValue, configKeyValues,
configKeyYes, configKeyNo, configKeyNonEmpty
) where
import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
import Control.Monad.Reader
data Environment = Environment
{
getStage :: Stage,
getBuilder :: Builder,
getPackage :: Package
}
defaultEnvironment :: Environment
defaultEnvironment = Environment
{
getStage = error "Stage not set in the environment",
getBuilder = error "Builder not set in the environment",
getPackage = error "Package not set in the environment"
}
type Expression m a = ReaderT Environment m a
type Ways m = Expression m [Way]
type Packages m = Expression m [Package]
type Predicate m = Expression m Bool
type TargetDir m = Expression m FilePath
instance (Monad m, Monoid a) => Monoid (Expression m a) where
mempty = return mempty
mappend = liftM2 mappend
interpret :: (Monad m, Monoid a) => Expression m a -> Environment -> m a
interpret = runReaderT
whenPredicate :: (Monad m, Monoid a) => Predicate m -> Expression m a -> Expression m a
whenPredicate predicate expr = do
bool <- predicate
if bool then expr else return mempty
(?) :: (Monad m, Monoid a) => Predicate m -> Expression m a -> Expression m a
(?) = whenPredicate
infixr 8 ?
stage :: Monad m => Stage -> Predicate m
stage s = liftM (s ==) (asks getStage)
notStage :: Monad m => Stage -> Predicate m
notStage = liftM not . stage
package :: Monad m => Package -> Predicate m
package p = liftM (p ==) (asks getPackage)
configKeyValue :: String -> String -> Predicate Action
configKeyValue key value = liftM (value ==) (lift $ askConfig key)
-- checks if there is at least one match
configKeyValues :: String -> [String] -> Predicate Action
configKeyValues key values = liftM (flip elem $ values) (lift $ askConfig key)
configKeyYes :: String -> Predicate Action
configKeyYes key = configKeyValue key "YES"
configKeyNo :: String -> Predicate Action
configKeyNo key = configKeyValue key "NO"
configKeyNonEmpty :: String -> Predicate Action
configKeyNonEmpty key = configKeyValue key ""
module Expression.Base (
BuildPredicate,
module Expression.Derived,
module Expression.Project,
module Expression.Resolve,
module Expression.Simplify,
module Expression.Predicate,
module Expression.BuildExpression,
module Control.Applicative
) where
import Base
import Expression.Derived
import Expression.Predicate
import Expression.BuildPredicate
import Control.Monad
import Expression.BuildExpression
import Expression.Project
import Expression.Resolve
import Expression.Simplify
import Control.Applicative
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
module Expression.BuildExpression (
BuildExpression,
Ways, Packages, TargetDirs,
-- reexport from Expression.PG:
bimap, (|>), (?), (??), whenExists, support,
msum, mproduct,
fromList, fromOrderedList
) where
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
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, 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
data BuildVariable = PackageVariable Package
| BuilderVariable Builder
| StageVariable Stage
| WayVariable Way
| FileVariable FilePattern
| ConfigVariable String String -- from config files
deriving (Show, Eq)
-- A datatype for build predicates
data BuildPredicate
= Evaluated Bool -- Evaluated predicate
| Unevaluated BuildVariable -- To be evaluated later
| Not BuildPredicate -- Negation
| And BuildPredicate BuildPredicate -- Conjunction
| 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
true = Evaluated True
false = Evaluated False
not = Not
(&&) = And
(||) = Or
instance Show BuildPredicate where
showsPrec _ (Evaluated bool) = shows bool
showsPrec _ (Unevaluated var) = shows var
showsPrec d (Or p q) =
showParen (d > 0) $ shows p . showString " \\/ " . shows q
showsPrec d (And p q) =
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
{-# LANGUAGE NoImplicitPrelude #-}
module Expression.Derived (
Settings,
-- Constructing build predicates
packages, package,
builders, builder, stagedBuilder,
stages, stage, notStage,
ways, way, files, file,
configValues, config, configYes, configNo, configNonEmpty,
-- Primitive settings elements
arg, args, argPath, argsOrdered, argBuildPath, argBuildDir,
argInput, argOutput,
argConfig, argStagedConfig, argConfigList, argStagedConfigList,
argBuilderPath, argStagedBuilderPath,
argWithBuilder, argWithStagedBuilder,
argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
argIncludeDirs, argDepIncludeDirs,
argConcat, argConcatPath, argConcatSpace,
argPairs, argPrefix, argPrefixPath,
argPackageConstraints
) where
import Base hiding (Args, arg, args)
import Ways
import Util
import Package (Package)
import Oracles.Builder
import Expression.PG
import Expression.Settings
import Expression.BuildPredicate
import Expression.BuildExpression
-- Auxiliary function for multiway disjunction
alternatives :: (a -> BuildVariable) -> [a] -> BuildPredicate
alternatives f = foldr (||) false . map (variable . f)
-- Basic GHC build predicates
packages :: [Package] -> BuildPredicate
packages = alternatives PackageVariable
builders :: [Builder] -> BuildPredicate
builders = alternatives BuilderVariable
stages :: [Stage] -> BuildPredicate
stages = alternatives StageVariable
ways :: [Way] -> BuildPredicate
ways = alternatives WayVariable
files :: [FilePattern] -> BuildPredicate
files = alternatives FileVariable
configValues :: String -> [String] -> BuildPredicate
configValues key = alternatives (ConfigVariable key)
package :: Package -> BuildPredicate
package p = packages [p]
builder :: Builder -> BuildPredicate
builder b = builders [b]
stagedBuilder :: (Stage -> Builder) -> BuildPredicate
stagedBuilder s2b = builders $ map s2b [Stage0 ..]
stage :: Stage -> BuildPredicate
stage s = stages [s]
notStage :: Stage -> BuildPredicate
notStage = not . variable . StageVariable
way :: Way -> BuildPredicate
way w = ways [w]
file :: FilePattern -> BuildPredicate
file f = files [f]
config :: String -> String -> BuildPredicate
config key value = configValues key [value]
configYes :: String -> BuildPredicate
configYes key = configValues key ["YES"]
configNo :: String -> BuildPredicate
configNo key = configValues key ["NO" ]
configNonEmpty :: String -> BuildPredicate
configNonEmpty key = not $ configValues key [""]
-- A single argument
arg :: String -> Settings
arg = return . Plain
-- A single FilePath argument
argPath :: FilePath -> Settings
argPath = return . Plain . unifyPath
-- A set of arguments (unordered)
args :: [String] -> Settings
args = msum . map arg
-- An (ordered) list of arguments
argsOrdered :: [String] -> Settings
argsOrdered = mproduct . map arg
argBuildPath :: Settings
argBuildPath = return $ BuildParameter $ PackagePath
argBuildDir :: Settings
argBuildDir = return $ BuildParameter $ BuildDir
argInput :: Settings
argInput = return $ BuildParameter $ Input
argOutput :: Settings
argOutput = return $ BuildParameter $ Output
argConfig :: String -> Settings
argConfig = return . EnvironmentParameter . Config Single
argConfigList :: String -> Settings
argConfigList = return . EnvironmentParameter . Config Multiple
stagedKey :: Stage -> String -> String
stagedKey stage key = key ++ "-stage" ++ show stage
argStagedConfig :: String -> Settings
argStagedConfig key =
msum $ map (\s -> stage s ? argConfig (stagedKey s key)) [Stage0 ..]
argStagedConfigList :: String -> Settings
argStagedConfigList key =
msum $ map (\s -> stage s ? argConfigList (stagedKey s key)) [Stage0 ..]
-- evaluates to the path to a given builder
argBuilderPath :: Builder -> Settings
argBuilderPath = return . EnvironmentParameter . BuilderPath
-- as above but takes current stage into account
argStagedBuilderPath :: (Stage -> Builder) -> Settings
argStagedBuilderPath f =
msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
-- evaluates to 'with-builder=path/to/builder' for a given builder
argWithBuilder :: Builder -> Settings
argWithBuilder builder =
argPrefix (withBuilderKey builder) (argBuilderPath builder)
-- as above but takes current stage into account
argWithStagedBuilder :: (Stage -> Builder) -> Settings
argWithStagedBuilder f =
msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]
packageData :: Arity -> String -> Settings
packageData arity key =
return $ EnvironmentParameter $ PackageData arity key Nothing Nothing
-- Accessing key value pairs from package-data.mk files
argPackageKey :: Settings
argPackageKey = packageData Single "PACKAGE_KEY"
argPackageDeps :: Settings
argPackageDeps = packageData Multiple "DEPS"
argPackageDepKeys :: Settings
argPackageDepKeys = packageData Multiple "DEP_KEYS"
argSrcDirs :: Settings
argSrcDirs = packageData Multiple "HS_SRC_DIRS"
argIncludeDirs :: Settings
argIncludeDirs = packageData Multiple "INCLUDE_DIRS"
argDepIncludeDirs :: Settings
argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
argPackageConstraints :: Packages -> Settings
argPackageConstraints = return . EnvironmentParameter . PackageConstraints
-- Concatenate arguments: arg1 ++ arg2 ++ ...
argConcat :: Settings -> Settings
argConcat = return . Fold Concat
-- </>-concatenate arguments: arg1 </> arg2 </> ...
argConcatPath :: Settings -> Settings
argConcatPath = return . Fold ConcatPath
-- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
argConcatSpace :: Settings -> Settings
argConcatSpace = return . Fold ConcatSpace
-- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
argPairs :: String -> Settings -> Settings
argPairs prefix settings = settings >>= (arg prefix |>) . return
-- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
argPrefix :: String -> Settings -> Settings
argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
-- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
argPrefixPath :: String -> Settings -> Settings
argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression.PG (
PG,
module Control.Monad,
module Control.Applicative,
module Expression.Predicate,
rewrite, bimap, (|>), (?), (??),
mproduct,
support, whenExists,
fromList, fromOrderedList
) where
import Control.Monad
import Control.Applicative
import Expression.Predicate
-- A basic Parameterised Graph datatype
-- * p is the type of predicates
-- * v is the type of vertices
data PG p v = Epsilon
| Vertex v
| Overlay (PG p v) (PG p v)
| Sequence (PG p v) (PG p v)
| 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 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 MonadPlus (PG p) where
mzero = Epsilon
mplus = Overlay
instance Alternative (PG p) where
empty = Epsilon
(<|>) = Overlay
mproduct :: [PG p v] -> PG p v
mproduct = foldr (|>) Epsilon
fromList :: [v] -> PG p v
fromList = msum . map return
fromOrderedList :: [v] -> PG p v
fromOrderedList = mproduct . map return
-- 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
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.
whenExists :: (Predicate p, Eq v) => v -> PG p v -> p
whenExists _ Epsilon = false
whenExists a (Vertex b) = if a == b then true else false
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
instance (Show p, Show v) => Show (PG p v) where
showsPrec _ Epsilon = showString "()"
showsPrec _ (Vertex v) = shows v
showsPrec d (Overlay l r) =
showParen (d > 0) $ shows l . showChar ' ' . shows r
showsPrec d (Sequence l r) =
showParen (d > 1) $ showsPrec 1 l . showString " -> " . showsPrec 1 r
showsPrec d (Condition l r) =