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

17
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
18 19
import Builder
import Package
Andrey Mokhov's avatar
Andrey Mokhov committed
20
import Stage
21
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
22
import Way
23

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

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

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

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
71 72 73 74
-- Add a single String argument to Args
arg :: String -> Args
arg = append . return

75
-- 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

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

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

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

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

123
-- Interpret a given expression in a given environment
124 125
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
126

127 128 129 130 131 132 133
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")

134
-- Extract an expression from a difference expression
135 136
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
137

138
-- Interpret a given difference expression in a given environment
139 140
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
141

142 143
-- Convenient getters for target parameters
getStage :: Expr Stage
144
getStage = asks stage
145 146

getPackage :: Expr Package
147
getPackage = asks package
148 149

getBuilder :: Expr Builder
150
getBuilder = asks builder
151

Andrey Mokhov's avatar
Andrey Mokhov committed
152
getWay :: Expr Way
153
getWay = asks way
Andrey Mokhov's avatar
Andrey Mokhov committed
154 155

getSources :: Expr [FilePath]
156
getSources = asks sources
Andrey Mokhov's avatar
Andrey Mokhov committed
157

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

165
getFiles :: Expr [FilePath]
166
getFiles = asks files
167

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