Refactor argument expressions.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Wed, 8 Apr 2015 01:34:02 +0000 (02:34 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Wed, 8 Apr 2015 01:34:02 +0000 (02:34 +0100)
src/Expression.hs [new file with mode: 0644]
src/Expression/ArgList.hs [new file with mode: 0644]
src/Expression/PG.hs [new file with mode: 0644]
src/Expression/Predicate.hs [new file with mode: 0644]
src/Expression/TruthTeller.hs [new file with mode: 0644]
src/Settings.hs

diff --git a/src/Expression.hs b/src/Expression.hs
new file mode 100644 (file)
index 0000000..2b2b20d
--- /dev/null
@@ -0,0 +1,159 @@
+{-# 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
diff --git a/src/Expression/ArgList.hs b/src/Expression/ArgList.hs
new file mode 100644 (file)
index 0000000..d381a9c
--- /dev/null
@@ -0,0 +1,32 @@
+{-# 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
+
diff --git a/src/Expression/PG.hs b/src/Expression/PG.hs
new file mode 100644 (file)
index 0000000..098dedf
--- /dev/null
@@ -0,0 +1,56 @@
+{-# 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
diff --git a/src/Expression/Predicate.hs b/src/Expression/Predicate.hs
new file mode 100644 (file)
index 0000000..bfccaa7
--- /dev/null
@@ -0,0 +1,55 @@
+{-# 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
diff --git a/src/Expression/TruthTeller.hs b/src/Expression/TruthTeller.hs
new file mode 100644 (file)
index 0000000..f6c9e4f
--- /dev/null
@@ -0,0 +1,16 @@
+{-# 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)
index 6d25a92..2885282 100644 (file)
@@ -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