[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