Expression.hs 5.5 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 8
    Predicate, PredicateLike (..), applyPredicate, (??),
    Args, Ways, Packages,
9 10
    apply, append, appendM, remove,
    appendSub, appendSubD, filterSub, removeSub,
11
    interpret, interpretExpr,
12
    stage, package, builder, file, way
13 14
    ) where

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

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

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

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

60
-- Basic operations on expressions:
61 62 63 64 65
-- 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
66
append :: Monoid a => a -> DiffExpr a
67
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
68

69
-- 3) remove given elements from a list expression
Andrey Mokhov's avatar
Andrey Mokhov committed
70
remove :: Eq a => [a] -> DiffExpr [a]
71
remove xs = apply . filter $ (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
72

73
-- 4) apply a predicate to an expression
74 75 76 77 78 79
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
80 81 82
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
    notP :: a -> Predicate
83 84 85

infixr 8 ?

86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
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

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

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

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

127
filterSub :: String -> (String -> Bool) -> Args
128
filterSub prefix p = apply . map $ filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
129 130 131 132 133
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

134
-- Remove given elements from a list of sub-arguments with a given prefix
135
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
136
removeSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
137 138
removeSub prefix xs = filterSub prefix (`notElem` xs)

139
-- Interpret a given expression in a given environment
140 141
interpretExpr :: Target -> Expr a -> Action a
interpretExpr = flip runReaderT
142

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

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

151
-- Basic predicates (see Switches.hs for derived predicates)
152
stage :: Stage -> Predicate
153 154
stage s = liftM (s ==) (asks getStage)

155 156 157
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

158 159 160
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

161
file :: FilePattern -> Predicate
162
file f = liftM (any (f ?==)) (asks getFiles)
163 164 165

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