Expression.hs 5.86 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,
10
    Predicate, (?), applyPredicate,
11
    Args, Ways, Packages,
12
    Target, PartialTarget (..), fromPartial, fullTarget, fullTargetWithWay,
13 14
    apply, append, appendM, remove,
    appendSub, appendSubD, filterSub, removeSub,
15
    interpret, interpretPartial, interpretWithStage, interpretDiff,
Andrey Mokhov's avatar
Andrey Mokhov committed
16
    getStage, getPackage, getBuilder, getFiles, getFile,
17
    getSources, getSource, getWay
18 19
    ) where

20
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
21
import Builder
Andrey Mokhov's avatar
Andrey Mokhov committed
22
import Control.Monad.Reader
Andrey Mokhov's avatar
Andrey Mokhov committed
23
import Package
Andrey Mokhov's avatar
Andrey Mokhov committed
24
import Stage
25
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
26
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
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
78 79 80

infixr 8 ?

81 82 83 84 85 86 87 88 89
instance PredicateLike Predicate where
    (?)  = applyPredicate

instance PredicateLike Bool where
    (?)  = applyPredicate . return

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

90 91
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
92
appendM = (append =<<) . lift
93

Andrey Mokhov's avatar
Andrey Mokhov committed
94 95 96 97
-- 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.
98
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
99
appendSub prefix xs
100
    | xs' == [] = mempty
101
    | otherwise = apply . go $ False
Andrey Mokhov's avatar
Andrey Mokhov committed
102
  where
103
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
104
    go True  []     = []
105
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
106
    go found (y:ys) = if prefix `isPrefixOf` y
107 108
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
109 110 111

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

115
filterSub :: String -> (String -> Bool) -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
116
filterSub prefix p = apply $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
117 118 119 120 121
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

122
-- Remove given elements from a list of sub-arguments with a given prefix
123
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
124
removeSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
125 126
removeSub prefix xs = filterSub prefix (`notElem` xs)

127
-- Interpret a given expression in a given environment
128 129
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
130

131 132 133 134 135 136 137
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")

138
-- Extract an expression from a difference expression
139 140
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
141

142
-- Interpret a given difference expression in a given environment
143 144
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
145

146 147
-- Convenient getters for target parameters
getStage :: Expr Stage
148
getStage = asks stage
149 150

getPackage :: Expr Package
151
getPackage = asks package
152 153

getBuilder :: Expr Builder
154
getBuilder = asks builder
155

Andrey Mokhov's avatar
Andrey Mokhov committed
156
getWay :: Expr Way
157
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
158 159

getSources :: Expr [FilePath]
160
getSources = asks sources
Andrey Mokhov's avatar
Andrey Mokhov committed
161

162
-- Run getSources and check that the result contains a single file only
Andrey Mokhov's avatar
Andrey Mokhov committed
163 164 165
getSource :: Expr FilePath
getSource = do
    target <- ask
166 167
    getSingleton getSources $
        "getSource: exactly one source expected in target " ++ show target
Andrey Mokhov's avatar
Andrey Mokhov committed
168

169
getFiles :: Expr [FilePath]
170
getFiles = asks files
171

172
-- Run getFiles and check that the result contains a single file only
Andrey Mokhov's avatar
Andrey Mokhov committed
173 174 175
getFile :: Expr FilePath
getFile = do
    target <- ask
176 177 178 179 180 181 182
    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
183
        [res] -> return res
184
        _     -> lift $ putError msg