Expression.hs 6.09 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances #-}
2
module Expression (
Andrey Mokhov's avatar
Andrey Mokhov committed
3
    module Base,
4
    module Control.Monad.Reader,
Andrey Mokhov's avatar
Andrey Mokhov committed
5 6 7 8
    module Builder,
    module Package,
    module Stage,
    module Way,
9
    Expr, DiffExpr, fromDiffExpr,
Andrey Mokhov's avatar
Andrey Mokhov committed
10
    Predicate, (?), (??), notP, applyPredicate,
11
    Args, Ways, Packages,
12 13
    apply, append, appendM, remove,
    appendSub, appendSubD, filterSub, removeSub,
14
    interpret, interpretPartial, interpretWithStage, interpretDiff,
Andrey Mokhov's avatar
Andrey Mokhov committed
15
    getStage, getPackage, getBuilder, getFiles, getFile,
16
    getSources, getSource, getWay
17 18
    ) where

19
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
20
import Builder
Andrey Mokhov's avatar
Andrey Mokhov committed
21
import Control.Monad.Reader
Andrey Mokhov's avatar
Andrey Mokhov committed
22
import Package
Andrey Mokhov's avatar
Andrey Mokhov committed
23
import Stage
24
import Target (Target (..), PartialTarget (..), fromPartial)
Andrey Mokhov's avatar
Andrey Mokhov committed
25
import Way
26

27 28 29 30 31
-- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target.
type Expr a = ReaderT Target Action a

-- Diff a holds functions of type a -> a and is equipped with a Monoid instance.
32
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
33
-- The name comes from "difference lists".
34 35
newtype Diff a = Diff { fromDiff :: a -> a }

36 37 38 39 40 41 42
-- 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.
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.
43 44 45
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
46

47
-- The following expressions are used throughout the build system for
48
-- specifying conditions (Predicate), lists of arguments (Args), Ways and
49 50
-- Packages.
type Predicate = Expr Bool
51
type Args      = DiffExpr [String]
52
type Packages  = DiffExpr [Package]
53
type Ways      = DiffExpr [Way]
54

55
-- Basic operations on expressions:
56 57 58 59 60
-- 1) transform an expression by applying a given function
apply :: (a -> a) -> DiffExpr a
apply = return . Diff

-- 2) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
61
append :: Monoid a => a -> DiffExpr a
62
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
63

64
-- 3) remove given elements from a list expression
Andrey Mokhov's avatar
Andrey Mokhov committed
65
remove :: Eq a => [a] -> DiffExpr [a]
66
remove xs = apply . filter $ (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
67

68
-- 4) apply a predicate to an expression
69 70 71 72 73 74
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

-- A convenient operator for predicate application
75 76 77
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
    notP :: a -> Predicate
78 79 80

infixr 8 ?

81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
instance PredicateLike Predicate where
    (?)  = applyPredicate
    notP = liftM not

instance PredicateLike Bool where
    (?)  = applyPredicate . return
    notP = return . not

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

-- An equivalent of if-then-else for predicates
(??) :: (PredicateLike a, Monoid m) => a -> (Expr m, Expr m) -> Expr m
p ?? (t, f) = p ? t <> notP p ? f

97 98
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
99
appendM = (append =<<) . lift
100

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

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

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

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

134
-- Interpret a given expression in a given environment
135 136
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
137

138 139 140 141 142 143 144
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")

145
-- Extract an expression from a difference expression
146 147
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
148

149
-- Interpret a given difference expression in a given environment
150 151
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
152

153 154
-- Convenient getters for target parameters
getStage :: Expr Stage
155
getStage = asks stage
156 157

getPackage :: Expr Package
158
getPackage = asks package
159 160

getBuilder :: Expr Builder
161
getBuilder = asks builder
162

Andrey Mokhov's avatar
Andrey Mokhov committed
163
getWay :: Expr Way
164
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
165 166

getSources :: Expr [FilePath]
167
getSources = asks sources
Andrey Mokhov's avatar
Andrey Mokhov committed
168

169
-- Run getSources and check that the result contains a single file only
Andrey Mokhov's avatar
Andrey Mokhov committed
170 171 172
getSource :: Expr FilePath
getSource = do
    target <- ask
173 174
    getSingleton getSources $
        "getSource: exactly one source expected in target " ++ show target
Andrey Mokhov's avatar
Andrey Mokhov committed
175

176
getFiles :: Expr [FilePath]
177
getFiles = asks files
178

179
-- Run getFiles and check that the result contains a single file only
Andrey Mokhov's avatar
Andrey Mokhov committed
180 181 182
getFile :: Expr FilePath
getFile = do
    target <- ask
183 184 185 186 187 188 189
    getSingleton getFiles $
        "getFile: exactly one file expected in target " ++ show target

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