Expression.hs 5.43 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 Base
15
import Ways
Andrey Mokhov's avatar
Andrey Mokhov committed
16 17
import Builder
import Package
18
import Target
19
import Oracles.Base
20
import Data.Monoid
21
import Control.Monad.Reader hiding (liftIO)
22

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

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

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

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

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

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
-- 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
83 84 85 86
-- 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.
87
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
88
appendSub prefix xs
89
    | xs' == [] = mempty
90
    | otherwise = return . Diff $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
91
  where
92
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
93
    go True  []     = []
94
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
95
    go found (y:ys) = if prefix `isPrefixOf` y
96 97
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
98 99 100

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

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

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

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

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

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

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

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

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

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

142 143 144 145 146
file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile)

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

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

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