Expression.hs 6.31 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 28
import Control.Monad.Trans.Reader

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

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

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

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

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

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

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

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

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

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

infixr 8 ?

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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