Commit 93e218e5 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor argument expressions.

parent 71be3a82
{-# LANGUAGE FlexibleInstances #-}
module Expression (
Guard,
Settings,
module Expression.ArgList,
module Expression.Predicate,
opts, fence, (?),
packages, package, setPackage,
builders, builder, setBuilder,
stages, stage, notStage, setStage,
ways, way, setWay,
files, file, setFile,
keyValues, keyValue, keyYes, keyNo, setKeyValue,
packageKey, packageDeps, packageDepKeys
) where
import Base
import Ways
import Package.Base (Package)
import Oracles.Builder
import Expression.PG
import Expression.Predicate
import Expression.ArgList
data BuildParameter = WhenPackage Package
| WhenBuilder Builder
| WhenStage Stage
| WhenWay Way
| WhenFile FilePattern
| WhenKeyValue String String -- from config files
type Guard = Predicate BuildParameter
instance Monoid Guard where
mempty = Evaluated True
mappend = And
type Settings = PG Guard ArgList
opts :: [String] -> Settings
opts = mconcat . map (\s -> Vertex $ Plain [s])
fence :: Settings -> Settings -> Settings
fence = Sequence
(?) :: Guard -> Settings -> Settings
(?) = Condition
infixl 7 ?
alternatives :: (a -> BuildParameter) -> [a] -> Guard
alternatives p = multiOr . map (Parameter . p)
-- Basic GHC build guards
packages :: [Package] -> Guard
packages = alternatives WhenPackage
builders :: [Builder] -> Guard
builders = alternatives WhenBuilder
stages :: [Stage] -> Guard
stages = alternatives WhenStage
ways :: [Way] -> Guard
ways = alternatives WhenWay
files :: [FilePattern] -> Guard
files = alternatives WhenFile
keyValues :: String -> [String] -> Guard
keyValues key = alternatives (WhenKeyValue key)
package :: Package -> Guard
package p = packages [p]
builder :: Builder -> Guard
builder b = builders [b]
stage :: Stage -> Guard
stage s = stages [s]
notStage :: Stage -> Guard
notStage = Not . Parameter . WhenStage
way :: Way -> Guard
way w = ways [w]
file :: FilePattern -> Guard
file f = files [f]
keyValue :: String -> String -> Guard
keyValue key value = keyValues key [value]
keyYes, keyNo :: String -> Guard
keyYes key = keyValues key ["YES"]
keyNo key = keyValues key ["NO" ]
-- Partial evaluation of settings
setPackage :: Package -> Settings -> Settings
setPackage = project . matchPackage
setBuilder :: Builder -> Settings -> Settings
setBuilder = project . matchBuilder
setStage :: Stage -> Settings -> Settings
setStage = project . matchStage
setWay :: Way -> Settings -> Settings
setWay = project . matchWay
setFile :: FilePath -> Settings -> Settings
setFile = project . matchFile
setKeyValue :: String -> String -> Settings -> Settings
setKeyValue key = project . matchKeyValue key
-- Truth-tellers for partial evaluation
type Matcher = TruthTeller BuildParameter
matchPackage :: Package -> Matcher
matchPackage p (WhenPackage p') = Just $ p == p'
matchPackage _ _ = Nothing
matchBuilder :: Builder -> Matcher
matchBuilder b (WhenBuilder b') = Just $ b == b'
matchBuilder _ _ = Nothing
matchStage :: Stage -> Matcher
matchStage s (WhenStage s') = Just $ s == s'
matchStage _ _ = Nothing
matchWay :: Way -> Matcher
matchWay w (WhenWay w') = Just $ w == w'
matchWay _ _ = Nothing
matchFile :: FilePath -> Matcher
matchFile file (WhenFile pattern) = Just $ pattern ?== file
matchFile _ _ = Nothing
matchKeyValue :: String -> String -> Matcher
matchKeyValue key value (WhenKeyValue key' value')
| key == key' = Just $ value == value'
| otherwise = Nothing
matchKeyValue _ _ _ = Nothing
-- Argument templates
packageKey :: String -> Settings
packageKey = Vertex . PackageKey
packageDeps :: String -> Settings
packageDeps = Vertex . PackageDeps
packageDepKeys :: String -> Settings
packageDepKeys = Vertex . PackageDepKeys
{-# LANGUAGE FlexibleInstances #-}
module Expression.ArgList (
ArgList (..),
ArgsTeller,
fromPlain,
tellArgs
) where
import Data.Monoid
data ArgList = Plain [String]
| PackageKey String
| PackageDeps String
| PackageDepKeys String
type ArgsTeller = ArgList -> Maybe [String]
-- Monoid instance for args-tellers (asks them one by one)
instance Monoid ArgsTeller where
mempty = const Nothing
p `mappend` q = \a -> getFirst $ First (p a) <> First (q a)
fromPlain :: ArgsTeller
fromPlain (Plain list) = Just list
fromPlain _ = Nothing
tellArgs :: ArgsTeller -> ArgList -> ArgList
tellArgs t a = case t a of
Just list -> Plain list
Nothing -> a
{-# LANGUAGE FlexibleInstances #-}
module Expression.PG (
module Expression.Predicate,
PG (..),
fromList,
mapP,
project,
linearise
) where
import Data.Monoid
import Control.Applicative
import Expression.Predicate
-- A generic 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)
instance Monoid (PG p v) where
mempty = Epsilon
mappend = Overlay
-- For constructing a PG from an unordered list use mconcat.
fromList :: [v] -> PG p v
fromList = foldr Sequence Epsilon . map Vertex
-- Map over all PG predicates, e.g., partially evaluate a given PG.
mapP :: (p -> p) -> PG p v -> PG p v
mapP _ Epsilon = Epsilon
mapP _ v @ (Vertex _) = v
mapP f (Overlay l r) = Overlay (mapP f l) (mapP f r)
mapP f (Sequence l r) = Sequence (mapP f l) (mapP f r)
mapP f (Condition x r) = Condition (f x ) (mapP f r)
-- Partially evaluate a PG using a truth-teller (compute a 'projection')
project :: TruthTeller a -> PG (Predicate a) v -> PG (Predicate a) v
project t = mapP (evaluate t)
-- Linearise a PG into a list. Returns Nothing if the given expression
-- cannot be uniquely evaluated due to remaining parameters.
-- Overlay subexpressions are evaluated in arbitrary order.
linearise :: PG (Predicate a) v -> Maybe [v]
linearise Epsilon = Just []
linearise (Vertex v) = Just [v]
linearise (Overlay l r) = (++) <$> linearise l <*> linearise r -- TODO: union
linearise (Sequence l r) = (++) <$> linearise l <*> linearise r
linearise (Condition x r) = case tellTruth x of
Just True -> linearise r
Just False -> Just []
Nothing -> Nothing
{-# LANGUAGE FlexibleInstances #-}
module Expression.Predicate (
module Expression.TruthTeller,
Predicate (..),
multiOr, multiAnd,
evaluate, tellTruth
) where
import Control.Applicative
import Expression.TruthTeller
-- An abstract datatype for predicates that can depend on unevaluated variables
data Predicate a = Evaluated Bool -- Evaluated predicate
| Parameter a -- To be evaluated later
| Not (Predicate a) -- Negate predicate
| And (Predicate a) (Predicate a) -- Conjunction
| Or (Predicate a) (Predicate a) -- Disjunction
multiOr :: [Predicate a] -> Predicate a
multiOr = foldr Or (Evaluated False)
multiAnd :: [Predicate a] -> Predicate a
multiAnd = foldr And (Evaluated True)
-- Partially evaluate a Predicate using a TruthTeller
evaluate :: TruthTeller a -> Predicate a -> Predicate a
evaluate _ p @ (Evaluated _) = p
evaluate t p @ (Parameter q) = case t q of
Just bool -> Evaluated bool
Nothing -> p
evaluate t (Not p ) = Not (evaluate t p)
evaluate t (And p q) = And (evaluate t p) (evaluate t q)
evaluate t (Or p q) = Or (evaluate t p) (evaluate t q)
-- Attempt to fully evaluate a predicate (a truth teller!). Returns Nothing if
-- the predicate cannot be evaluated due to remaining parameters.
tellTruth :: TruthTeller (Predicate a)
tellTruth (Evaluated bool) = Just bool
tellTruth (Not p) = not <$> tellTruth p
tellTruth (And p q)
| p' == Just False || q' == Just False = Just False
| p' == Just True && q' == Just True = Just True
| otherwise = Nothing
where
p' = tellTruth p
q' = tellTruth q
tellTruth (Or p q)
| p' == Just True || q' == Just True = Just True
| p' == Just False && q' == Just False = Just False
| otherwise = Nothing
where
p' = tellTruth p
q' = tellTruth q
tellTruth (Parameter _) = Nothing -- cannot evaluate Parameter
{-# LANGUAGE FlexibleInstances #-}
module Expression.TruthTeller (
TruthTeller (..)
) where
import Data.Monoid
-- TruthTeller takes an argument and attempts to determine its truth.
-- Returns Nothing if the truth cannot be determined.
type TruthTeller a = a -> Maybe Bool
-- Monoid instance for truth-tellers (asks them one by one)
instance Monoid (TruthTeller a) where
mempty = const Nothing
p `mappend` q = \a -> getFirst $ First (p a) <> First (q a)
......@@ -6,9 +6,7 @@ module Settings (
) where
import Base
import Ways
import Package.Base (Package)
import Oracles.Builder
import Expression
data IntegerLibrary = IntegerGmp | IntegerGmp2 | IntegerSimple
......@@ -24,208 +22,20 @@ integerLibraryName = case integerLibrary of
buildHaddock :: Bool
buildHaddock = True
-- A generic Parameterised Graph datatype for parameterised argument lists
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)
instance Monoid (PG p v) where
mempty = Epsilon
mappend = Overlay
fromList :: [v] -> PG p v
fromList = foldr Sequence Epsilon . map Vertex
type RewritePG p v = PG p v -> PG p v
data Predicate a = Evaluated Bool -- Evaluated predicate
| Parameter a -- To be evaluated later
| Not (Predicate a) -- Negate predicate
| And (Predicate a) (Predicate a) -- Conjunction
| Or (Predicate a) (Predicate a) -- Disjunction
multiOr :: [Predicate a] -> RewritePG (Predicate a) v
multiOr = Condition . foldr Or (Evaluated False)
multiAnd :: [Predicate a] -> RewritePG (Predicate a) v
multiAnd = Condition . foldr And (Evaluated True)
type RewrtePredicate a = Predicate a -> Predicate a
-- Evaluator takes an argument and attempts to determine its truth.
-- Returns Nothing if the attempt fails.
type Evaluator a = a -> Maybe Bool
-- Monoid instance for evaluators (returns first successful evaluation)
instance Monoid (Evaluator a) where
mempty = const Nothing
p `mappend` q = \a -> getFirst $ First (p a) <> First (q a)
-- Apply an evalulator to a predicate (partial evaluation, or 'projection').
apply :: Evaluator a -> RewrtePredicate a
apply _ p @ (Evaluated _) = p
apply e p @ (Parameter q) = case e q of
Just bool -> Evaluated bool
Nothing -> p
apply e (Not p ) = Not (apply e p)
apply e (And p q) = And (apply e p) (apply e q)
apply e (Or p q) = Or (apply e p) (apply e q)
-- Map over all PG predicates, e.g., apply an evaluator to a given PG.
mapP :: RewrtePredicate a -> RewritePG (Predicate a) v
mapP _ Epsilon = Epsilon
mapP _ v @ (Vertex _) = v
mapP r (Overlay p q) = Overlay (mapP r p) (mapP r q)
mapP r (Sequence p q) = Sequence (mapP r p) (mapP r q)
mapP r (Condition x p) = Condition (r x) (mapP r p)
project :: Evaluator a -> RewritePG (Predicate a) v
project = mapP . apply
-- Attempt to evaluate a predicate. Returns Nothing if the predicate
-- cannot be uniquely evaluated due to remaining parameters.
-- An alternative type: evalPredicate :: Evaluator (Predicate a)
evalPredicate :: Predicate a -> Maybe Bool
evalPredicate (Evaluated bool) = Just bool
evalPredicate (Not p) = not <$> evalPredicate p
evalPredicate (And p q)
| p' == Just False || q' == Just False = Just False
| p' == Just True && q' == Just True = Just True
| otherwise = Nothing
where
p' = evalPredicate p
q' = evalPredicate q
evalPredicate (Or p q)
| p' == Just True || q' == Just True = Just True
| p' == Just False && q' == Just False = Just False
| otherwise = Nothing
where
p' = evalPredicate p
q' = evalPredicate q
evalPredicate (Parameter _) = Nothing -- cannot evaluate Parameter
-- Linearise a PG into a list. Returns Nothing if the given expression
-- cannot be uniquely evaluated due to remaining parameters.
linearise :: PG (Predicate a) v -> Maybe [v]
linearise Epsilon = Just []
linearise (Vertex v) = Just [v]
linearise (Overlay p q) = (++) <$> linearise p <*> linearise q -- TODO: union
linearise (Sequence p q) = (++) <$> linearise p <*> linearise q
linearise (Condition x p) = case evalPredicate x of
Just True -> linearise p
Just False -> Just []
Nothing -> Nothing
-- GHC build specific
type Expression a = PG (Predicate BuildParameter) a
type Rewrite a = Expression a -> Expression a
--type ArgsExpression = Expression String
--type Args = Expression String
--args :: [String] -> Args
--args = fromList
data BuildParameter = WhenPackage Package
| WhenBuilder Builder
| WhenStage Stage
| WhenWay Way
| WhenFile FilePattern
| WhenKeyValue String String -- from config files
-- Predicates
alternatives :: (b -> BuildParameter) -> [b] -> Rewrite a
alternatives p = multiOr . map (Parameter . p)
whenPackages :: [Package] -> Rewrite a
whenPackages = alternatives WhenPackage
whenBuilders :: [Builder] -> Rewrite a
whenBuilders = alternatives WhenBuilder
whenStages :: [Stage] -> Rewrite a
whenStages = alternatives WhenStage
unlessStage :: Stage -> Rewrite a
unlessStage stage = Condition (Not $ Parameter $ WhenStage stage)
whenWays :: [Way] -> Rewrite a
whenWays = alternatives WhenWay
whenFiles :: [FilePattern] -> Rewrite a
whenFiles = alternatives WhenFile
whenKeyValues :: String -> [String] -> Rewrite a
whenKeyValues key = alternatives (WhenKeyValue key)
whenKeyValue :: String -> String -> Rewrite a
whenKeyValue key value = whenKeyValues key [value]
-- Evaluators
packageEvaluator :: Package -> Evaluator BuildParameter
packageEvaluator p (WhenPackage p') = Just $ p == p'
packageEvaluator _ _ = Nothing
builderEvaluator :: Builder -> Evaluator BuildParameter
builderEvaluator b (WhenBuilder b') = Just $ b == b'
builderEvaluator _ _ = Nothing
stageEvaluator :: Stage -> Evaluator BuildParameter
stageEvaluator s (WhenStage s') = Just $ s == s'
stageEvaluator _ _ = Nothing
wayEvaluator :: Way -> Evaluator BuildParameter
wayEvaluator w (WhenWay w') = Just $ w == w'
wayEvaluator _ _ = Nothing
fileEvaluator :: FilePath -> Evaluator BuildParameter
fileEvaluator file (WhenFile pattern) = Just $ pattern ?== file
fileEvaluator _ _ = Nothing
keyValueEvaluator :: String -> String -> Evaluator BuildParameter
keyValueEvaluator key value (WhenKeyValue key' value')
| key == key' = Just $ value == value'
| otherwise = Nothing
keyValueEvaluator _ _ _ = Nothing
setPackage :: Package -> Rewrite a
setPackage = project . packageEvaluator
setBuilder :: Builder -> Rewrite a
setBuilder = project . builderEvaluator
setStage :: Stage -> Rewrite a
setStage = project . stageEvaluator
setWay :: Way -> Rewrite a
setWay = project . wayEvaluator
setFile :: FilePath -> Rewrite a
setFile = project . fileEvaluator
setKeyValue :: String -> String -> Rewrite a
setKeyValue key = project . keyValueEvaluator key
whenPackageKey :: Rewrite a
whenPackageKey = whenKeyValue "supports-package-key" "YES" . unlessStage Stage0
--packageArgs =
-- Vertex "-hide-all-packages"
-- ~>
-- Vertex "-no-user-package-db"
-- ~>
-- Vertex "-include-pkg-deps"
-- ~> If (MatchStage Stage0)
-- (Vertex "-package-db libraries/bootstrapping.conf")
-- ~> If usePackageKey
-- (
-- )
whenPackageKey :: Guard
whenPackageKey = keyYes "supports-package-key" <> notStage Stage0
depSettings :: Settings
depSettings =
opts ["-hide-all-packages", "-no-user-package-db", "-include-pkg-deps"]
<>
stage Stage0 ? opts ["-package-db libraries/bootstrapping.conf"]
<>
whenPackageKey ?
(packageKey "-this-package-key" <> packageDepKeys "-package-key")
<>
(Not $ whenPackageKey) ?
(packageKey "-package-name" <> packageDeps "-package")
--packageArgs :: Stage -> FilePath -> Args
--packageArgs stage pathDist = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment