Expression.hs 6.35 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
    getInput, getOutput,

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

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

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

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

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

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

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

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

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

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

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

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

infixr 8 ?

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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