Expression.hs 6.88 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances #-}
2
module Expression (
Ben Gamari's avatar
Ben Gamari committed
3
    -- * Expressions
4
    Expr, DiffExpr, fromDiffExpr,
Ben Gamari's avatar
Ben Gamari committed
5
    -- ** Operators
6
7
    apply, append, arg, remove, removePair,
    appendSub, appendSubD, filterSub, removeSub,
Ben Gamari's avatar
Ben Gamari committed
8
    -- ** Evaluation
9
    interpret, interpretInContext, interpretDiff,
Ben Gamari's avatar
Ben Gamari committed
10
11
12
13
    -- ** Predicates
    Predicate, (?), applyPredicate,
    -- ** Common expressions
    Args, Ways, Packages,
14
15
    -- ** Context and Target
    Context, vanillaContext, stageContext, Target, dummyTarget,
Ben Gamari's avatar
Ben Gamari committed
16
17

    -- * Convenient accessors
Andrey Mokhov's avatar
Andrey Mokhov committed
18
    getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
Ben Gamari's avatar
Ben Gamari committed
19
20
21
    getInput, getOutput,

    -- * Re-exports
22
    module Control.Monad.Trans.Reader,
23
    module Data.Monoid,
Ben Gamari's avatar
Ben Gamari committed
24
25
26
27
    module Builder,
    module Package,
    module Stage,
    module Way
28
29
    ) where

30
import Control.Monad.Trans.Reader
31
import Data.Monoid
32

33
import Base
34
import Builder
35
import Context
Andrey Mokhov's avatar
Andrey Mokhov committed
36
import Package
Andrey Mokhov's avatar
Andrey Mokhov committed
37
import Stage
38
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
39
import Way
40

Andrey Mokhov's avatar
Andrey Mokhov committed
41
42
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
43
44
type Expr a = ReaderT Target Action a

Ben Gamari's avatar
Ben Gamari committed
45
-- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
Andrey Mokhov's avatar
Andrey Mokhov committed
46
47
-- list is a list with efficient concatenation, encoded as a value @a -> a@. We
-- could use @Dual (Endo a)@ instead of @Diff a@, but the former may look scary.
48
49
newtype Diff a = Diff { fromDiff :: a -> a }

Andrey Mokhov's avatar
Andrey Mokhov committed
50
51
52
-- | @DiffExpr a@ is a computation that builds a difference list (i.e., a
-- function of type @'Action' (a -> a)@) and can read parameters of the current
-- build 'Target'.
53
54
55
56
57
type DiffExpr a = Expr (Diff a)

-- Note the reverse order of function composition (y . x), which ensures that
-- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
-- applied first, and c2 is applied second.
58
59
60
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
61

Ben Gamari's avatar
Ben Gamari committed
62
63
64
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- 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:
Andrey Mokhov's avatar
Andrey Mokhov committed
71
-- | Transform an expression by applying a given function.
72
73
74
apply :: (a -> a) -> DiffExpr a
apply = return . Diff

Andrey Mokhov's avatar
Andrey Mokhov committed
75
-- | Append something to an expression.
Andrey Mokhov's avatar
Andrey Mokhov committed
76
append :: Monoid a => a -> DiffExpr a
77
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
78

Andrey Mokhov's avatar
Andrey Mokhov committed
79
-- | Remove given elements from a list expression.
Andrey Mokhov's avatar
Andrey Mokhov committed
80
remove :: Eq a => [a] -> DiffExpr [a]
81
remove xs = apply $ filter (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
82

Andrey Mokhov's avatar
Andrey Mokhov committed
83
-- | Remove given pair of elements from a list expression.
84
85
86
87
88
89
90
91
92
-- Example: removePair "-flag" "b" ["-flag", "a", "-flag", "b"] = ["-flag", "a"]
removePair :: Eq a => a -> a -> DiffExpr [a]
removePair x y = apply filterPair
  where
    filterPair (z1 : z2 : zs) = if x == z1 && y == z2
                                then filterPair zs
                                else z1 : filterPair (z2 : zs)
    filterPair zs = zs

Andrey Mokhov's avatar
Andrey Mokhov committed
93
-- | Apply a predicate to an expression.
94
95
96
97
98
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

Andrey Mokhov's avatar
Andrey Mokhov committed
99
-- | Add a single argument to 'Args'.
Andrey Mokhov's avatar
Andrey Mokhov committed
100
101
102
arg :: String -> Args
arg = append . return

Andrey Mokhov's avatar
Andrey Mokhov committed
103
-- | A convenient operator for predicate application.
104
class PredicateLike a where
Andrey Mokhov's avatar
Andrey Mokhov committed
105
    (?) :: Monoid m => a -> Expr m -> Expr m
106

107
infixr 3 ?
108

109
instance PredicateLike Predicate where
Andrey Mokhov's avatar
Andrey Mokhov committed
110
    (?) = applyPredicate
111
112

instance PredicateLike Bool where
Andrey Mokhov's avatar
Andrey Mokhov committed
113
    (?) = applyPredicate . return
114
115

instance PredicateLike (Action Bool) where
Andrey Mokhov's avatar
Andrey Mokhov committed
116
    (?) = applyPredicate . lift
117

Ben Gamari's avatar
Ben Gamari committed
118
-- | @appendSub@ appends a list of sub-arguments to all arguments starting with a
Andrey Mokhov's avatar
Andrey Mokhov committed
119
-- given prefix. If there is no argument with such prefix then a new argument
Ben Gamari's avatar
Ben Gamari committed
120
-- of the form @prefix=listOfSubarguments@ is appended to the expression.
Andrey Mokhov's avatar
Andrey Mokhov committed
121
-- Note: nothing is done if the list of sub-arguments is empty.
122
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
123
appendSub prefix xs
124
    | xs' == [] = mempty
125
    | otherwise = apply . go $ False
Andrey Mokhov's avatar
Andrey Mokhov committed
126
  where
127
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
128
    go True  []     = []
129
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
130
    go found (y:ys) = if prefix `isPrefixOf` y
131
132
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
133

Ben Gamari's avatar
Ben Gamari committed
134
135
-- | @appendSubD@ is similar to 'appendSub' but it extracts the list of sub-arguments
-- from the given 'DiffExpr'.
136
appendSubD :: String -> Args -> Args
137
appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
Andrey Mokhov's avatar
Andrey Mokhov committed
138

139
filterSub :: String -> (String -> Bool) -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
140
filterSub prefix p = apply $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
141
142
143
144
145
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

Ben Gamari's avatar
Ben Gamari committed
146
-- | Remove given elements from a list of sub-arguments with a given prefix
Andrey Mokhov's avatar
Andrey Mokhov committed
147
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"].
148
removeSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
149
150
removeSub prefix xs = filterSub prefix (`notElem` xs)

151
-- | Interpret a given expression according to the given 'Target'.
152
153
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
154

155
156
157
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext :: Context -> Expr a -> Action a
interpretInContext = interpret . dummyTarget
158

Andrey Mokhov's avatar
Andrey Mokhov committed
159
-- | Extract an expression from a difference expression.
160
161
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
162

Andrey Mokhov's avatar
Andrey Mokhov committed
163
-- | Interpret a given difference expression in a given environment.
164
165
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
166

Andrey Mokhov's avatar
Andrey Mokhov committed
167
168
169
170
171
-- | Get the current build 'Context'.
getContext :: Expr Context
getContext = asks context

-- | Get the 'Stage' of the current 'Context'.
172
getStage :: Expr Stage
173
getStage = stage <$> asks context
174

Andrey Mokhov's avatar
Andrey Mokhov committed
175
-- | Get the 'Package' of the current 'Context'.
176
getPackage :: Expr Package
177
getPackage = package <$> asks context
178

Andrey Mokhov's avatar
Andrey Mokhov committed
179
180
181
182
-- | Get the 'Way' of the current 'Context'.
getWay :: Expr Way
getWay = way <$> asks context

Andrey Mokhov's avatar
Andrey Mokhov committed
183
-- | Get the 'Builder' for the current 'Target'.
184
getBuilder :: Expr Builder
185
getBuilder = asks builder
186

Andrey Mokhov's avatar
Andrey Mokhov committed
187
-- | Get the input files of the current 'Target'.
188
189
getInputs :: Expr [FilePath]
getInputs = asks inputs
Andrey Mokhov's avatar
Andrey Mokhov committed
190

Andrey Mokhov's avatar
Andrey Mokhov committed
191
-- | Run 'getInputs' and check that the result contains one input file only.
192
193
getInput :: Expr FilePath
getInput = do
Andrey Mokhov's avatar
Andrey Mokhov committed
194
    target <- ask
195
196
    getSingleton getInputs $
        "getInput: exactly one input file expected in target " ++ show target
Andrey Mokhov's avatar
Andrey Mokhov committed
197

Andrey Mokhov's avatar
Andrey Mokhov committed
198
-- | Get the files produced by the current 'Target'.
199
200
getOutputs :: Expr [FilePath]
getOutputs = asks outputs
201

Andrey Mokhov's avatar
Andrey Mokhov committed
202
-- | Run 'getOutputs' and check that the result contains one output file only.
203
204
getOutput :: Expr FilePath
getOutput = do
Andrey Mokhov's avatar
Andrey Mokhov committed
205
    target <- ask
206
207
    getSingleton getOutputs $
        "getOutput: exactly one output file expected in target " ++ show target
208
209
210

getSingleton :: Expr [a] -> String -> Expr a
getSingleton expr msg = do
211
212
    xs <- expr
    case xs of
213
        [res] -> return res
214
        _     -> lift $ putError msg