Expression.hs 5.4 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,
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
10
    interpret, interpretExpr,
11
    stage, package, builder, file, way
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
-- 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
75 76 77
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
    notP :: a -> Predicate
78 79 80

infixr 8 ?

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

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

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

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

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

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

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

138
-- Extract an expression from a difference expression
139 140
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
141

142
-- Interpret a given difference expression in a given environment
143 144
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
145

146
-- Basic predicates (see Switches.hs for derived predicates)
147
stage :: Stage -> Predicate
148 149
stage s = liftM (s ==) (asks getStage)

150 151 152
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

153 154 155
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

156
file :: FilePattern -> Predicate
157
file f = liftM (any (f ?==)) (asks getFiles)
158 159 160

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