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