Expression.hs 6.1 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances #-}
2
module Expression (
3
    module Control.Monad.Reader,
Andrey Mokhov's avatar
Andrey Mokhov committed
4 5 6 7 8
    module Builder,
    module Package,
    module Stage,
    module Util,
    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 26
import Util
import Way
27

28 29 30 31 32
-- 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.
33
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
34
-- The name comes from "difference lists".
35 36
newtype Diff a = Diff { fromDiff :: a -> a }

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

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

56
-- Basic operations on expressions:
57 58 59 60 61
-- 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
62
append :: Monoid a => a -> DiffExpr a
63
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
64

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

69
-- 4) apply a predicate to an expression
70 71 72 73 74 75
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
76 77 78
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
    notP :: a -> Predicate
79 80 81

infixr 8 ?

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
102 103 104 105
-- 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.
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 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

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)

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")

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

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

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

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

getBuilder :: Expr Builder
162
getBuilder = asks builder
163

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

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

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

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

180
-- Run getFiles and check that the result contains a single file only
Andrey Mokhov's avatar
Andrey Mokhov committed
181 182 183
getFile :: Expr FilePath
getFile = do
    target <- ask
184 185 186 187 188 189 190
    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
191
        [res] -> return res
192
        _     -> lift $ putError msg