Clean up code, add comments.
[hadrian.git] / src / Expression.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 module Expression (
3 module Base,
4 module Builder,
5 module Package,
6 module Stage,
7 module Way,
8 Expr, DiffExpr, fromDiffExpr,
9 Predicate, (?), applyPredicate, Args, Ways, Packages,
10 Target, PartialTarget (..), fromPartial, fullTarget, fullTargetWithWay,
11 apply, append, arg, remove, appendSub, appendSubD, filterSub, removeSub,
12 interpret, interpretPartial, interpretWithStage, interpretDiff,
13 getStage, getPackage, getBuilder, getFiles, getSources, getWay,
14 getSource, getFile
15 ) where
16
17 import Base
18 import Builder
19 import Package
20 import Stage
21 import Target
22 import Way
23
24 -- Expr a is a computation that produces a value of type Action a and can read
25 -- parameters of the current build Target.
26 type Expr a = ReaderT Target Action a
27
28 -- Diff a holds functions of type a -> a and is equipped with a Monoid instance.
29 -- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
30 -- The name comes from "difference lists".
31 newtype Diff a = Diff { fromDiff :: a -> a }
32
33 -- DiffExpr a is a computation that builds a difference list (i.e., a function
34 -- of type Action (a -> a)) and can read parameters of the current build Target.
35 type DiffExpr a = Expr (Diff a)
36
37 -- Note the reverse order of function composition (y . x), which ensures that
38 -- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
39 -- applied first, and c2 is applied second.
40 instance Monoid (Diff a) where
41 mempty = Diff id
42 Diff x `mappend` Diff y = Diff $ y . x
43
44 -- The following expressions are used throughout the build system for
45 -- specifying conditions (Predicate), lists of arguments (Args), Ways and
46 -- Packages.
47 type Predicate = Expr Bool
48 type Args = DiffExpr [String]
49 type Packages = DiffExpr [Package]
50 type Ways = DiffExpr [Way]
51
52 -- Basic operations on expressions:
53 -- 1) transform an expression by applying a given function
54 apply :: (a -> a) -> DiffExpr a
55 apply = return . Diff
56
57 -- 2) append something to an expression
58 append :: Monoid a => a -> DiffExpr a
59 append x = apply (<> x)
60
61 -- 3) remove given elements from a list expression
62 remove :: Eq a => [a] -> DiffExpr [a]
63 remove xs = apply $ filter (`notElem` xs)
64
65 -- 4) apply a predicate to an expression
66 applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
67 applyPredicate predicate expr = do
68 bool <- predicate
69 if bool then expr else return mempty
70
71 -- Add a single String argument to Args
72 arg :: String -> Args
73 arg = append . return
74
75 -- A convenient operator for predicate application
76 class PredicateLike a where
77 (?) :: Monoid m => a -> Expr m -> Expr m
78
79 infixr 8 ?
80
81 instance PredicateLike Predicate where
82 (?) = applyPredicate
83
84 instance PredicateLike Bool where
85 (?) = applyPredicate . return
86
87 instance PredicateLike (Action Bool) where
88 (?) = applyPredicate . lift
89
90 -- appendSub appends a list of sub-arguments to all arguments starting with a
91 -- given prefix. If there is no argument with such prefix then a new argument
92 -- of the form 'prefix=listOfSubarguments' is appended to the expression.
93 -- Note: nothing is done if the list of sub-arguments is empty.
94 appendSub :: String -> [String] -> Args
95 appendSub prefix xs
96 | xs' == [] = mempty
97 | otherwise = apply . go $ False
98 where
99 xs' = filter (/= "") xs
100 go True [] = []
101 go False [] = [prefix ++ "=" ++ unwords xs']
102 go found (y:ys) = if prefix `isPrefixOf` y
103 then unwords (y : xs') : go True ys
104 else y : go found ys
105
106 -- appendSubD is similar to appendSub but it extracts the list of sub-arguments
107 -- from the given DiffExpr.
108 appendSubD :: String -> Args -> Args
109 appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
110
111 filterSub :: String -> (String -> Bool) -> Args
112 filterSub prefix p = apply $ map filterSubstr
113 where
114 filterSubstr s
115 | prefix `isPrefixOf` s = unwords . filter p . words $ s
116 | otherwise = s
117
118 -- Remove given elements from a list of sub-arguments with a given prefix
119 -- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
120 removeSub :: String -> [String] -> Args
121 removeSub prefix xs = filterSub prefix (`notElem` xs)
122
123 -- Interpret a given expression in a given environment
124 interpret :: Target -> Expr a -> Action a
125 interpret = flip runReaderT
126
127 interpretPartial :: PartialTarget -> Expr a -> Action a
128 interpretPartial = interpret . fromPartial
129
130 interpretWithStage :: Stage -> Expr a -> Action a
131 interpretWithStage s = interpretPartial $
132 PartialTarget s (error "interpretWithStage: package not set")
133
134 -- Extract an expression from a difference expression
135 fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
136 fromDiffExpr = fmap (($ mempty) . fromDiff)
137
138 -- Interpret a given difference expression in a given environment
139 interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
140 interpretDiff target = interpret target . fromDiffExpr
141
142 -- Convenient getters for target parameters
143 getStage :: Expr Stage
144 getStage = asks stage
145
146 getPackage :: Expr Package
147 getPackage = asks package
148
149 getBuilder :: Expr Builder
150 getBuilder = asks builder
151
152 getWay :: Expr Way
153 getWay = asks way
154
155 getSources :: Expr [FilePath]
156 getSources = asks sources
157
158 -- Run getSources and check that the result contains a single file only
159 getSource :: Expr FilePath
160 getSource = do
161 target <- ask
162 getSingleton getSources $
163 "getSource: exactly one source expected in target " ++ show target
164
165 getFiles :: Expr [FilePath]
166 getFiles = asks files
167
168 -- Run getFiles and check that the result contains a single file only
169 getFile :: Expr FilePath
170 getFile = do
171 target <- ask
172 getSingleton getFiles $
173 "getFile: exactly one file expected in target " ++ show target
174
175 getSingleton :: Expr [a] -> String -> Expr a
176 getSingleton expr msg = do
177 list <- expr
178 case list of
179 [res] -> return res
180 _ -> lift $ putError msg