Expression.hs 5.42 KB
Newer Older
1 2
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
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 hiding (Args)
15
import Ways
16
import Target
17 18
import Oracles
import Package
19
import Data.Monoid
20 21
import Control.Monad.Reader

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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