Expression.hs 5.99 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 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
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
77 78 79

infixr 8 ?

80 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

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

93 94
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
95
appendM = (append =<<) . lift
96

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

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

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

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

130
-- Interpret a given expression in a given environment
131 132
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
133

134 135 136 137 138 139 140
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")

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

145
-- Interpret a given difference expression in a given environment
146 147
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
148

149 150
-- Convenient getters for target parameters
getStage :: Expr Stage
151
getStage = asks stage
152 153

getPackage :: Expr Package
154
getPackage = asks package
155 156

getBuilder :: Expr Builder
157
getBuilder = asks builder
158

Andrey Mokhov's avatar
Andrey Mokhov committed
159
getWay :: Expr Way
160
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
161 162

getSources :: Expr [FilePath]
163
getSources = asks sources
Andrey Mokhov's avatar
Andrey Mokhov committed
164

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

172
getFiles :: Expr [FilePath]
173
getFiles = asks files
174

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