Re-export Expression from Predicates
[ghc.git] / src / Expression.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 module Expression (
3 -- * Expressions
4 Expr, DiffExpr, fromDiffExpr,
5 -- ** Operators
6 apply, append, arg, remove, removePair,
7 appendSub, appendSubD, filterSub, removeSub,
8 -- ** Evaluation
9 interpret, interpretInContext, interpretDiff,
10 -- ** Predicates
11 Predicate, (?), applyPredicate,
12 -- ** Common expressions
13 Args, Ways, Packages,
14 -- ** Context and Target
15 Context, vanillaContext, stageContext, Target, dummyTarget,
16
17 -- * Convenient accessors
18 getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
19 getInput, getOutput,
20
21 -- * Re-exports
22 module Control.Monad.Trans.Reader,
23 module Data.Monoid,
24 module Builder,
25 module Package,
26 module Stage,
27 module Way
28 ) where
29
30 import Control.Monad.Trans.Reader
31 import Data.Monoid
32
33 import Base
34 import Builder
35 import Context
36 import Package
37 import Stage
38 import Target
39 import Way
40
41 -- | @Expr a@ is a computation that produces a value of type @Action a@ and can
42 -- read parameters of the current build 'Target'.
43 type Expr a = ReaderT Target Action a
44
45 -- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
46 -- list is a list with efficient concatenation, encoded as a value @a -> a@. We
47 -- could use @Dual (Endo a)@ instead of @Diff a@, but the former may look scary.
48 newtype Diff a = Diff { fromDiff :: a -> a }
49
50 -- | @DiffExpr a@ is a computation that builds a difference list (i.e., a
51 -- function of type @'Action' (a -> a)@) and can read parameters of the current
52 -- build 'Target'.
53 type DiffExpr a = Expr (Diff a)
54
55 -- Note the reverse order of function composition (y . x), which ensures that
56 -- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
57 -- applied first, and c2 is applied second.
58 instance Monoid (Diff a) where
59 mempty = Diff id
60 Diff x `mappend` Diff y = Diff $ y . x
61
62 -- | The following expressions are used throughout the build system for
63 -- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
64 -- and 'Packages'.
65 type Predicate = Expr Bool
66 type Args = DiffExpr [String]
67 type Packages = DiffExpr [Package]
68 type Ways = DiffExpr [Way]
69
70 -- Basic operations on expressions:
71 -- | Transform an expression by applying a given function.
72 apply :: (a -> a) -> DiffExpr a
73 apply = return . Diff
74
75 -- | Append something to an expression.
76 append :: Monoid a => a -> DiffExpr a
77 append x = apply (<> x)
78
79 -- | Remove given elements from a list expression.
80 remove :: Eq a => [a] -> DiffExpr [a]
81 remove xs = apply $ filter (`notElem` xs)
82
83 -- | Remove given pair of elements from a list expression.
84 -- Example: removePair "-flag" "b" ["-flag", "a", "-flag", "b"] = ["-flag", "a"]
85 removePair :: Eq a => a -> a -> DiffExpr [a]
86 removePair x y = apply filterPair
87 where
88 filterPair (z1 : z2 : zs) = if x == z1 && y == z2
89 then filterPair zs
90 else z1 : filterPair (z2 : zs)
91 filterPair zs = zs
92
93 -- | Apply a predicate to an expression.
94 applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
95 applyPredicate predicate expr = do
96 bool <- predicate
97 if bool then expr else return mempty
98
99 -- | Add a single argument to 'Args'.
100 arg :: String -> Args
101 arg = append . return
102
103 -- | A convenient operator for predicate application.
104 class PredicateLike a where
105 (?) :: Monoid m => a -> Expr m -> Expr m
106
107 infixr 3 ?
108
109 instance PredicateLike Predicate where
110 (?) = applyPredicate
111
112 instance PredicateLike Bool where
113 (?) = applyPredicate . return
114
115 instance PredicateLike (Action Bool) where
116 (?) = applyPredicate . lift
117
118 -- | @appendSub@ appends a list of sub-arguments to all arguments starting with a
119 -- given prefix. If there is no argument with such prefix then a new argument
120 -- of the form @prefix=listOfSubarguments@ is appended to the expression.
121 -- Note: nothing is done if the list of sub-arguments is empty.
122 appendSub :: String -> [String] -> Args
123 appendSub prefix xs
124 | xs' == [] = mempty
125 | otherwise = apply . go $ False
126 where
127 xs' = filter (/= "") xs
128 go True [] = []
129 go False [] = [prefix ++ "=" ++ unwords xs']
130 go found (y:ys) = if prefix `isPrefixOf` y
131 then unwords (y : xs') : go True ys
132 else y : go found ys
133
134 -- | @appendSubD@ is similar to 'appendSub' but it extracts the list of sub-arguments
135 -- from the given 'DiffExpr'.
136 appendSubD :: String -> Args -> Args
137 appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
138
139 filterSub :: String -> (String -> Bool) -> Args
140 filterSub prefix p = apply $ map filterSubstr
141 where
142 filterSubstr s
143 | prefix `isPrefixOf` s = unwords . filter p . words $ s
144 | otherwise = s
145
146 -- | Remove given elements from a list of sub-arguments with a given prefix
147 -- Example: removeSub "--configure-option=CFLAGS" ["-Werror"].
148 removeSub :: String -> [String] -> Args
149 removeSub prefix xs = filterSub prefix (`notElem` xs)
150
151 -- | Interpret a given expression according to the given 'Target'.
152 interpret :: Target -> Expr a -> Action a
153 interpret = flip runReaderT
154
155 -- | Interpret a given expression by looking only at the given 'Context'.
156 interpretInContext :: Context -> Expr a -> Action a
157 interpretInContext = interpret . dummyTarget
158
159 -- | Extract an expression from a difference expression.
160 fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
161 fromDiffExpr = fmap (($ mempty) . fromDiff)
162
163 -- | Interpret a given difference expression in a given environment.
164 interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
165 interpretDiff target = interpret target . fromDiffExpr
166
167 -- | Get the current build 'Context'.
168 getContext :: Expr Context
169 getContext = asks context
170
171 -- | Get the 'Stage' of the current 'Context'.
172 getStage :: Expr Stage
173 getStage = stage <$> asks context
174
175 -- | Get the 'Package' of the current 'Context'.
176 getPackage :: Expr Package
177 getPackage = package <$> asks context
178
179 -- | Get the 'Way' of the current 'Context'.
180 getWay :: Expr Way
181 getWay = way <$> asks context
182
183 -- | Get the 'Builder' for the current 'Target'.
184 getBuilder :: Expr Builder
185 getBuilder = asks builder
186
187 -- | Get the input files of the current 'Target'.
188 getInputs :: Expr [FilePath]
189 getInputs = asks inputs
190
191 -- | Run 'getInputs' and check that the result contains one input file only.
192 getInput :: Expr FilePath
193 getInput = do
194 target <- ask
195 getSingleton getInputs $
196 "getInput: exactly one input file expected in target " ++ show target
197
198 -- | Get the files produced by the current 'Target'.
199 getOutputs :: Expr [FilePath]
200 getOutputs = asks outputs
201
202 -- | Run 'getOutputs' and check that the result contains one output file only.
203 getOutput :: Expr FilePath
204 getOutput = do
205 target <- ask
206 getSingleton getOutputs $
207 "getOutput: exactly one output file expected in target " ++ show target
208
209 getSingleton :: Expr [a] -> String -> Expr a
210 getSingleton expr msg = do
211 xs <- expr
212 case xs of
213 [res] -> return res
214 _ -> lift $ putError msg