Expression.hs 6.28 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
Andrey Mokhov's avatar
Andrey Mokhov committed
6
    apply, append, arg, remove, appendSub, appendSubD, filterSub, removeSub,
Ben Gamari's avatar
Ben Gamari committed
7
    -- ** Evaluation
8
    interpret, interpretPartial, interpretWithStage, interpretDiff,
Ben Gamari's avatar
Ben Gamari committed
9 10 11 12 13 14 15 16
    -- ** Predicates
    Predicate, (?), applyPredicate,
    -- ** Common expressions
    Args, Ways, Packages,
    -- ** Targets
    Target, PartialTarget (..), fromPartial, fullTarget, fullTargetWithWay,

    -- * Convenient accessors
17
    getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
Ben Gamari's avatar
Ben Gamari committed
18 19 20 21 22 23 24
    getInput, getOutput,

    -- * Re-exports
    module Builder,
    module Package,
    module Stage,
    module Way
25 26
    ) where

27
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
28
import Package
Ben Gamari's avatar
Ben Gamari committed
29
import Builder
Andrey Mokhov's avatar
Andrey Mokhov committed
30
import Stage
31
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
32
import Way
33

Ben Gamari's avatar
Ben Gamari committed
34 35
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can read
-- parameters of the current build 'Target'.
36 37
type Expr a = ReaderT Target Action a

Ben Gamari's avatar
Ben Gamari committed
38 39 40
-- | @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.
41 42
newtype Diff a = Diff { fromDiff :: a -> a }

Ben Gamari's avatar
Ben Gamari committed
43 44
-- | @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'.
45 46 47 48 49
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.
50 51 52
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
53

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

62
-- Basic operations on expressions:
Ben Gamari's avatar
Ben Gamari committed
63
-- | Transform an expression by applying a given function
64 65 66
apply :: (a -> a) -> DiffExpr a
apply = return . Diff

Ben Gamari's avatar
Ben Gamari committed
67
-- | Append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
68
append :: Monoid a => a -> DiffExpr a
69
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
70

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

Ben Gamari's avatar
Ben Gamari committed
75
-- | Apply a predicate to an expression
76 77 78 79 80
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
81
-- | Add a single argument to 'Args'
Andrey Mokhov's avatar
Andrey Mokhov committed
82 83 84
arg :: String -> Args
arg = append . return

Ben Gamari's avatar
Ben Gamari committed
85
-- | A convenient operator for predicate application
86 87
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
88 89 90

infixr 8 ?

91 92 93 94 95 96 97 98 99
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
100
-- | @appendSub@ appends a list of sub-arguments to all arguments starting with a
Andrey Mokhov's avatar
Andrey Mokhov committed
101
-- given prefix. If there is no argument with such prefix then a new argument
Ben Gamari's avatar
Ben Gamari committed
102
-- of the form @prefix=listOfSubarguments@ is appended to the expression.
Andrey Mokhov's avatar
Andrey Mokhov committed
103
-- Note: nothing is done if the list of sub-arguments is empty.
104
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
105
appendSub prefix xs
106
    | xs' == [] = mempty
107
    | otherwise = apply . go $ False
Andrey Mokhov's avatar
Andrey Mokhov committed
108
  where
109
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
110
    go True  []     = []
111
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
112
    go found (y:ys) = if prefix `isPrefixOf` y
113 114
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
115

Ben Gamari's avatar
Ben Gamari committed
116 117
-- | @appendSubD@ is similar to 'appendSub' but it extracts the list of sub-arguments
-- from the given 'DiffExpr'.
118
appendSubD :: String -> Args -> Args
119
appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
Andrey Mokhov's avatar
Andrey Mokhov committed
120

121
filterSub :: String -> (String -> Bool) -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
122
filterSub prefix p = apply $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
123 124 125 126 127
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

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

Ben Gamari's avatar
Ben Gamari committed
133
-- | Interpret a given expression in a given environment
134 135
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
136

137 138 139 140 141 142 143
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
144
-- | Extract an expression from a difference expression
145 146
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
147

Ben Gamari's avatar
Ben Gamari committed
148
-- | Interpret a given difference expression in a given environment
149 150
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
151

Ben Gamari's avatar
Ben Gamari committed
152
-- | Convenient getters for target parameters
153
getStage :: Expr Stage
154
getStage = asks stage
155

Ben Gamari's avatar
Ben Gamari committed
156
-- | Get the 'Package' of the current 'Target'
157
getPackage :: Expr Package
158
getPackage = asks package
159

Ben Gamari's avatar
Ben Gamari committed
160
-- | Get the 'Builder' for the current 'Target'
161
getBuilder :: Expr Builder
162
getBuilder = asks builder
163

Ben Gamari's avatar
Ben Gamari committed
164
-- | Get the 'Way' of the current 'Target'
Andrey Mokhov's avatar
Andrey Mokhov committed
165
getWay :: Expr Way
166
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
167

Ben Gamari's avatar
Ben Gamari committed
168
-- | Get the input files of the current 'Target'
169 170
getInputs :: Expr [FilePath]
getInputs = asks inputs
Andrey Mokhov's avatar
Andrey Mokhov committed
171

Ben Gamari's avatar
Ben Gamari committed
172
-- | Run 'getInputs' and check that the result contains a single input file only
173 174
getInput :: Expr FilePath
getInput = do
Andrey Mokhov's avatar
Andrey Mokhov committed
175
    target <- ask
176 177
    getSingleton getInputs $
        "getInput: exactly one input file expected in target " ++ show target
Andrey Mokhov's avatar
Andrey Mokhov committed
178

Ben Gamari's avatar
Ben Gamari committed
179
-- | Get the files produced by the current 'Target'
180 181
getOutputs :: Expr [FilePath]
getOutputs = asks outputs
182

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

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