Expression.hs 6.78 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 15 16 17
    -- ** Predicates
    Predicate, (?), applyPredicate,
    -- ** Common expressions
    Args, Ways, Packages,
    -- ** Targets
    Target, PartialTarget (..), fromPartial, fullTarget, fullTargetWithWay,

    -- * 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

Ben Gamari's avatar
Ben Gamari 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 44 45
-- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
-- 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 }

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

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

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

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

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

80 81 82 83 84 85 86 87 88 89
-- | Remove given pair of elements from a list expression
-- 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

Ben Gamari's avatar
Ben Gamari committed
90
-- | Apply a predicate to an expression
91 92 93 94 95
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

Ben Gamari's avatar
Ben Gamari committed
96
-- | Add a single argument to 'Args'
Andrey Mokhov's avatar
Andrey Mokhov committed
97 98 99
arg :: String -> Args
arg = append . return

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

infixr 8 ?

106 107 108 109 110 111 112 113 114
instance PredicateLike Predicate where
    (?)  = applyPredicate

instance PredicateLike Bool where
    (?)  = applyPredicate . return

instance PredicateLike (Action Bool) where
    (?)  = applyPredicate . lift

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

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

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

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

Ben Gamari's avatar
Ben Gamari committed
148
-- | Interpret a given expression in a given environment
149 150
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
151

152 153 154 155 156 157 158
interpretPartial :: PartialTarget -> Expr a -> Action a
interpretPartial = interpret . fromPartial

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

Ben Gamari's avatar
Ben Gamari 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

Ben Gamari's avatar
Ben Gamari 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

Ben Gamari's avatar
Ben Gamari committed
167
-- | Convenient getters for target parameters
168
getStage :: Expr Stage
169
getStage = asks stage
170

Ben Gamari's avatar
Ben Gamari committed
171
-- | Get the 'Package' of the current 'Target'
172
getPackage :: Expr Package
173
getPackage = asks package
174

Ben Gamari's avatar
Ben Gamari committed
175
-- | Get the 'Builder' for the current 'Target'
176
getBuilder :: Expr Builder
177
getBuilder = asks builder
178

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

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

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

Ben Gamari's avatar
Ben Gamari committed
194
-- | Get the files produced by the current 'Target'
195 196
getOutputs :: Expr [FilePath]
getOutputs = asks outputs
197

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

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