Expression.hs 5.45 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances #-}
2
module Expression (
3
    module Target,
4
    module Data.Monoid,
5
    module Control.Monad.Reader,
6
    Expr, DiffExpr, fromDiffExpr,
7
    Predicate, Args, Ways, Packages,
Andrey Mokhov's avatar
Andrey Mokhov committed
8
    append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
9
    interpret, interpretExpr,
10
    applyPredicate, (?), (??), stage, package, builder, file, way,
11
    configKeyValue, configKeyValues
12 13
    ) where

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

24 25 26 27 28 29 30 31 32 33 34 35
-- 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

-- If values of type a form a Monoid then so do computations of type Expr a:
-- * the empty computation returns the identity element of the underlying type
-- * two computations can be combined by combining their results
instance Monoid a => Monoid (Expr a) where
    mempty  = return mempty
    mappend = liftM2 mappend

-- Diff a holds functions of type a -> a and is equipped with a Monoid instance.
36
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
37
-- The name comes from "difference lists".
38 39
newtype Diff a = Diff { fromDiff :: a -> a }

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

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

59 60
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
61
append :: Monoid a => a -> DiffExpr a
62
append x = return . Diff $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
63

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

68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
-- 3) apply a predicate to an expression
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
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate

infixr 8 ?

-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
appendM mx = lift mx >>= append

Andrey Mokhov's avatar
Andrey Mokhov committed
84 85 86 87
-- 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.
88
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
89
appendSub prefix xs
90
    | xs' == [] = mempty
91
    | otherwise = return . Diff $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
92
  where
93
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
94
    go True  []     = []
95
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
96
    go found (y:ys) = if prefix `isPrefixOf` y
97 98
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
99 100 101

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

105
filterSub :: String -> (String -> Bool) -> Args
106
filterSub prefix p = return . Diff $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
107 108 109 110 111
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

112
-- Remove given elements from a list of sub-arguments with a given prefix
113
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
114
removeSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
115 116
removeSub prefix xs = filterSub prefix (`notElem` xs)

117
-- Interpret a given expression in a given environment
118 119
interpretExpr :: Target -> Expr a -> Action a
interpretExpr = flip runReaderT
120

121
-- Extract an expression from a difference expression
122 123
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
124

125
-- Interpret a given difference expression in a given environment
126 127
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
128

129
-- An equivalent of if-then-else for predicates
Andrey Mokhov's avatar
Andrey Mokhov committed
130
(??) :: Monoid a => Predicate -> (Expr a, Expr a) -> Expr a
131 132
p ?? (t, f) = p ? t <> (liftM not p) ? f

133
-- Basic predicates (see Switches.hs for derived predicates)
134
stage :: Stage -> Predicate
135 136
stage s = liftM (s ==) (asks getStage)

137 138 139
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

140 141 142
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

143
file :: FilePattern -> Predicate
144
file f = liftM (any (f ?==)) (asks getFiles)
145 146 147

way :: Way -> Predicate
way w = liftM (w ==) (asks getWay)
148

149
configKeyValue :: String -> String -> Predicate
150 151
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

152 153
-- Check if there is at least one match
-- Example: configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
154
configKeyValues :: String -> [String] -> Predicate
Andrey Mokhov's avatar
Andrey Mokhov committed
155
configKeyValues key values = liftM (`elem` values) (lift $ askConfig key)