[commit: ghc] wip/nfs-locking: Implement predicates and evaluators. (71be3a8)
git at git.haskell.org
git at git.haskell.org
Thu Oct 26 23:09:39 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/71be3a823ae81fde9371e93cd9efa9ffbb9a6cea/ghc
>---------------------------------------------------------------
commit 71be3a823ae81fde9371e93cd9efa9ffbb9a6cea
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Wed Feb 11 03:23:27 2015 +0000
Implement predicates and evaluators.
>---------------------------------------------------------------
71be3a823ae81fde9371e93cd9efa9ffbb9a6cea
src/Settings.hs | 114 ++++++++++++++++++++++++++++++++++++++++++++------------
src/Targets.hs | 1 +
2 files changed, 92 insertions(+), 23 deletions(-)
diff --git a/src/Settings.hs b/src/Settings.hs
index aaec2ab..6d25a92 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -7,6 +7,7 @@ module Settings (
import Base
import Ways
+import Package.Base (Package)
import Oracles.Builder
data IntegerLibrary = IntegerGmp | IntegerGmp2 | IntegerSimple
@@ -34,23 +35,36 @@ 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
--- Evaluator takes a Parameter and attempts to evaluate it.
+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
- e `mappend` f = \p -> getFirst $ First (e p) <> First (f p)
+ p `mappend` q = \a -> getFirst $ First (p a) <> First (q a)
--- Apply an evalulator to a predicate (partial evaluation, or projection)
-apply :: Evaluator a -> Predicate a -> Predicate 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
@@ -59,8 +73,20 @@ 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
@@ -80,46 +106,42 @@ evalPredicate (Or p q)
q' = evalPredicate q
evalPredicate (Parameter _) = Nothing -- cannot evaluate Parameter
--- Flatten a PG into a list. Returns Nothing if the given expression
+-- 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
+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
-(~>) :: PG p v -> PG p v -> PG p v
-a ~> b = Sequence a b
+-- GHC build specific
-type PGP p v = PG (Predicate p) v
+type Expression a = PG (Predicate BuildParameter) a
+type Rewrite a = Expression a -> Expression a
-disjuction :: [a] -> (a -> Predicate p) -> PGP p v -> PGP p v
-disjuction [] _ = id
-disjuction (a:as) convert = Condition (foldr Or (convert a) $ map convert as)
+--type ArgsExpression = Expression String
+--type Args = Expression String
--- GHC build specific
+--args :: [String] -> Args
+--args = fromList
-data BuildParameter = WhenPackage FilePath
+data BuildParameter = WhenPackage Package
| WhenBuilder Builder
| WhenStage Stage
| WhenWay Way
- | WhenFile FilePath
+ | WhenFile FilePattern
| WhenKeyValue String String -- from config files
-type Expression a = PGP BuildParameter a
-
-type Rewrite a = Expression a -> Expression a
-
-type ArgsExpression = Expression String
+-- Predicates
alternatives :: (b -> BuildParameter) -> [b] -> Rewrite a
-alternatives p bs = disjuction bs (Parameter . p)
+alternatives p = multiOr . map (Parameter . p)
-whenPackages :: [FilePath] -> Rewrite a
+whenPackages :: [Package] -> Rewrite a
whenPackages = alternatives WhenPackage
whenBuilders :: [Builder] -> Rewrite a
@@ -134,7 +156,7 @@ unlessStage stage = Condition (Not $ Parameter $ WhenStage stage)
whenWays :: [Way] -> Rewrite a
whenWays = alternatives WhenWay
-whenFiles :: [FilePath] -> Rewrite a
+whenFiles :: [FilePattern] -> Rewrite a
whenFiles = alternatives WhenFile
whenKeyValues :: String -> [String] -> Rewrite a
@@ -143,6 +165,52 @@ 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
diff --git a/src/Targets.hs b/src/Targets.hs
index bdfb2ee..bc50ed9 100644
--- a/src/Targets.hs
+++ b/src/Targets.hs
@@ -4,6 +4,7 @@ module Targets (
) where
import Package.Base
+import Settings
-- These are the packages we build:
-- TODO: this should eventually be removed and replaced by the top-level
More information about the ghc-commits
mailing list