Expression.hs 6.8 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, interpretPartial, interpretWithStage, interpretDiff,
Ben Gamari's avatar
Ben Gamari committed
10 11 12 13 14
    -- ** Predicates
    Predicate, (?), applyPredicate,
    -- ** Common expressions
    Args, Ways, Packages,
    -- ** Targets
quchen's avatar
quchen committed
15
    Target, PartialTarget (..), unsafeFromPartial, fullTarget, fullTargetWithWay,
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
Andrey Mokhov's avatar
Andrey Mokhov committed
33
import Package
Ben Gamari's avatar
Ben Gamari committed
34
import Builder
Andrey Mokhov's avatar
Andrey Mokhov committed
35
import Stage
36
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
37
import Way
38

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

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

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

Ben Gamari's avatar
Ben Gamari committed
60 61 62
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
63
type Predicate = Expr Bool
64
type Args      = DiffExpr [String]
65
type Packages  = DiffExpr [Package]
66
type Ways      = DiffExpr [Way]
67

68
-- Basic operations on expressions:
Andrey Mokhov's avatar
Andrey Mokhov committed
69
-- | Transform an expression by applying a given function.
70 71 72
apply :: (a -> a) -> DiffExpr a
apply = return . Diff

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

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

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

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

105
infixr 3 ?
106

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

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

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

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

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
149
-- | Interpret a given expression in a given environment.
150 151
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
152

153
interpretPartial :: PartialTarget -> Expr a -> Action a
quchen's avatar
quchen committed
154
interpretPartial = interpret . unsafeFromPartial
155 156 157 158 159

interpretWithStage :: Stage -> Expr a -> Action a
interpretWithStage s = interpretPartial $
    PartialTarget s (error "interpretWithStage: package not set")

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
168
-- | Convenient getters for target parameters.
169
getStage :: Expr Stage
170
getStage = asks stage
171

Andrey Mokhov's avatar
Andrey Mokhov committed
172
-- | Get the 'Package' of the current 'Target'.
173
getPackage :: Expr Package
174
getPackage = asks package
175

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

Andrey Mokhov's avatar
Andrey Mokhov committed
180
-- | Get the 'Way' of the current 'Target'.
Andrey Mokhov's avatar
Andrey Mokhov committed
181
getWay :: Expr Way
182
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
183

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

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

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

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

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