[commit: ghc] wip/nfs-locking: Implement basic infrastructure for parameterised expressions. (a5a8d53)
git at git.haskell.org
git at git.haskell.org
Thu Oct 26 23:26:26 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/a5a8d53e5cca5cb6a5609bde961d6f560fbb143f/ghc
>---------------------------------------------------------------
commit a5a8d53e5cca5cb6a5609bde961d6f560fbb143f
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Tue Feb 10 02:44:34 2015 +0000
Implement basic infrastructure for parameterised expressions.
>---------------------------------------------------------------
a5a8d53e5cca5cb6a5609bde961d6f560fbb143f
src/Base.hs | 2 +-
src/Settings.hs | 165 +++++++++++++++++++++++++++++++++++++++++---------------
2 files changed, 122 insertions(+), 45 deletions(-)
diff --git a/src/Base.hs b/src/Base.hs
index fa9104a..49b0fb2 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -16,7 +16,7 @@ module Base (
productArgs, concatArgs
) where
-import Development.Shake hiding ((*>))
+import Development.Shake hiding ((*>), alternatives)
import Development.Shake.FilePath
import Control.Applicative
import Data.Function
diff --git a/src/Settings.hs b/src/Settings.hs
index 42ceed9..aaec2ab 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -7,6 +7,7 @@ module Settings (
import Base
import Ways
+import Oracles.Builder
data IntegerLibrary = IntegerGmp | IntegerGmp2 | IntegerSimple
@@ -22,52 +23,45 @@ integerLibraryName = case integerLibrary of
buildHaddock :: Bool
buildHaddock = True
--- A Parameterised Graph datatype for storing argument lists with conditions
-data PG a b = Epsilon
- | Vertex a
- | Overlay (PG a b) (PG a b)
- | Sequence (PG a b) (PG a b)
- | Condition b (PG a b)
+-- 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 a b) where
+instance Monoid (PG p v) where
mempty = Epsilon
mappend = Overlay
-type ArgsExpression = PG String Predicate
-type WaysExpression = PG Way Predicate
+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
-data Match = MatchPackage FilePath -- Match a Package name
- | MatchFile FilePath -- Match a file
- | MatchStage Stage -- Match a Stage
- | MatchWay Way -- Match a Way
- | MatchKeyValue String String -- Match a key with a value (config)
-
--- A Matcher takes a Match description and attempts to evaluate it.
+-- Evaluator takes a Parameter and attempts to evaluate it.
-- Returns Nothing if the attempt fails.
-type Matcher = Match -> Maybe Bool
+type Evaluator a = a -> Maybe Bool
--- A Monoid instance for matchers (returns first successful match)
-instance Monoid Matcher where
+-- Monoid instance for evaluators (returns first successful evaluation)
+instance Monoid (Evaluator a) where
mempty = const Nothing
- p `mappend` q = \m -> getFirst $ First (p m) <> First (q m)
-
-data Predicate = Evaluated Bool -- Evaluated predicate
- | If Match -- Perform a match to evaluate
- | Not Predicate -- Negate predicate
- | And Predicate Predicate -- Conjunction of two predicates
- | Or Predicate Predicate -- Disjunction of two predicates
+ e `mappend` f = \p -> getFirst $ First (e p) <> First (f p)
-match :: Predicate -> Matcher -> Predicate
-match p @ (Evaluated _) _ = p
-match p @ (If match ) m = case m match of
+-- Apply an evalulator to a predicate (partial evaluation, or projection)
+apply :: Evaluator a -> Predicate a -> Predicate a
+apply _ p @ (Evaluated _) = p
+apply e p @ (Parameter q) = case e q of
Just bool -> Evaluated bool
Nothing -> p
-match (Not p ) m = match p m
-match (And p q) m = And (match p m) (match q m)
-match (Or p q) m = Or (match p m) (match q m)
+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)
--- returns Nothing if the given predicate cannot be uniquely evaluated
-evalPredicate :: Predicate -> Maybe Bool
+-- Attempt to evaluate a predicate. Returns Nothing if the predicate
+-- cannot be uniquely evaluated due to remaining parameters.
+evalPredicate :: Predicate a -> Maybe Bool
evalPredicate (Evaluated bool) = Just bool
evalPredicate (Not p) = not <$> evalPredicate p
evalPredicate (And p q)
@@ -84,15 +78,98 @@ evalPredicate (Or p q)
where
p' = evalPredicate p
q' = evalPredicate q
-evalPredicate (If _) = Nothing
-
--- returns Nothing if the given expression cannot be uniquely evaluated
-evalPG :: PG a Predicate -> Maybe [a]
-evalPG Epsilon = Just []
-evalPG (Vertex v) = Just [v]
-evalPG (Overlay p q) = (++) <$> evalPG p <*> evalPG q
-evalPG (Sequence p q) = (++) <$> evalPG p <*> evalPG q
-evalPG (Condition x p) = case evalPredicate x of
- Just True -> evalPG p
+evalPredicate (Parameter _) = Nothing -- cannot evaluate Parameter
+
+-- Flatten 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 (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
+
+type PGP p v = PG (Predicate p) v
+
+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)
+
+-- GHC build specific
+
+data BuildParameter = WhenPackage FilePath
+ | WhenBuilder Builder
+ | WhenStage Stage
+ | WhenWay Way
+ | WhenFile FilePath
+ | WhenKeyValue String String -- from config files
+
+type Expression a = PGP BuildParameter a
+
+type Rewrite a = Expression a -> Expression a
+
+type ArgsExpression = Expression String
+
+alternatives :: (b -> BuildParameter) -> [b] -> Rewrite a
+alternatives p bs = disjuction bs (Parameter . p)
+
+whenPackages :: [FilePath] -> 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 :: [FilePath] -> 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]
+
+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
+-- (
+
+-- )
+
+--packageArgs :: Stage -> FilePath -> Args
+--packageArgs stage pathDist = do
+-- usePackageKey <- SupportsPackageKey || stage /= Stage0
+-- args [ arg "-hide-all-packages"
+-- , arg "-no-user-package-db"
+-- , arg "-include-pkg-deps"
+-- , when (stage == Stage0) $
+-- arg "-package-db libraries/bootstrapping.conf"
+-- , if usePackageKey
+-- then productArgs ["-this-package-key"] [arg $ PackageKey pathDist]
+-- <> productArgs ["-package-key" ] [args $ DepKeys pathDist]
+-- else productArgs ["-package-name" ] [arg $ PackageKey pathDist]
+-- <> productArgs ["-package" ] [args $ Deps pathDist]
+-- ]
More information about the ghc-commits
mailing list