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

15
import Way
16
import Base
17
import Util
18
import Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
19 20
import Builder
import Package
21
import Target (Target (..), PartialTarget (..), fromPartial)
22
import Data.List
23
import Data.Monoid
24
import Control.Monad.Reader hiding (liftIO)
25

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

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

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

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

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

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

infixr 8 ?

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

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

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

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

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

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

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

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

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

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

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

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

getBuilder :: Expr Builder
160
getBuilder = asks builder
161

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

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

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

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

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