Expression.hs 6.74 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
18
    getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
Ben Gamari's avatar
Ben Gamari committed
19 20 21
    getInput, getOutput,

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

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

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

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

Ben Gamari's avatar
Ben Gamari committed
44
-- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
Andrey Mokhov's avatar
Andrey Mokhov committed
45 46
-- 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.
47 48
newtype Diff a = Diff { fromDiff :: a -> a }

Andrey Mokhov's avatar
Andrey Mokhov committed
49 50 51
-- | @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'.
52 53 54 55 56
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.
57 58 59
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
60

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
82
-- | Remove given pair of elements from a list expression.
83 84 85 86 87 88 89 90 91
-- 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
92
-- | Apply a predicate to an expression.
93 94 95 96 97
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
98
-- | Add a single argument to 'Args'.
Andrey Mokhov's avatar
Andrey Mokhov committed
99 100 101
arg :: String -> Args
arg = append . return

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

106
infixr 3 ?
107

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

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

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

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

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

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

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

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

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
166
-- | Convenient getters for target parameters.
167
getStage :: Expr Stage
168
getStage = stage <$> asks context
169

Andrey Mokhov's avatar
Andrey Mokhov committed
170
-- | Get the 'Package' of the current 'Target'.
171
getPackage :: Expr Package
172
getPackage = package <$> asks context
173

Andrey Mokhov's avatar
Andrey Mokhov committed
174
-- | Get the 'Builder' for the current 'Target'.
175
getBuilder :: Expr Builder
176
getBuilder = asks builder
177

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

Andrey Mokhov's avatar
Andrey Mokhov committed
182
-- | Get the input files of the current 'Target'.
183 184
getInputs :: Expr [FilePath]
getInputs = asks inputs
Andrey Mokhov's avatar
Andrey Mokhov committed
185

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

Andrey Mokhov's avatar
Andrey Mokhov committed
193
-- | Get the files produced by the current 'Target'.
194 195
getOutputs :: Expr [FilePath]
getOutputs = asks outputs
196

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

getSingleton :: Expr [a] -> String -> Expr a
getSingleton expr msg = do
206 207
    xs <- expr
    case xs of
208
        [res] -> return res
209
        _     -> lift $ putError msg