Expression.hs 6.41 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,
Andrey Mokhov's avatar
Andrey Mokhov committed
12 13
    getStage, getPackage, getBuilder, getFiles, getFile, getWay,
    stage, package, builder, stagedBuilder, file, way
14 15
    ) where

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

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

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

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

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

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

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

infixr 8 ?

89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
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

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

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

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

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

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

142
-- Interpret a given expression in a given environment
143 144
interpretExpr :: Target -> Expr a -> Action a
interpretExpr = flip runReaderT
145

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

150
-- Interpret a given difference expression in a given environment
151 152
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
153

154 155 156 157 158 159 160 161 162 163 164 165 166
-- Convenient getters for target parameters
getStage :: Expr Stage
getStage = asks Target.stage

getPackage :: Expr Package
getPackage = asks Target.package

getBuilder :: Expr Builder
getBuilder = asks Target.builder

getFiles :: Expr [FilePath]
getFiles = asks Target.files

Andrey Mokhov's avatar
Andrey Mokhov committed
167 168 169 170 171 172 173 174 175
-- Run getFiles and check that it contains a single file only
getFile :: Expr FilePath
getFile = do
    target <- ask
    files  <- getFiles
    case files of
        [file] -> return file
        _      -> error $ "Exactly one file expected in target " ++ show target

176 177 178
getWay :: Expr Way
getWay = asks Target.way

179
-- Basic predicates (see Switches.hs for derived predicates)
180
stage :: Stage -> Predicate
181
stage s = liftM (s ==) getStage
182

183
package :: Package -> Predicate
184
package p = liftM (p ==) getPackage
185

Andrey Mokhov's avatar
Andrey Mokhov committed
186
-- For unstaged builders, e.g. GhcCabal
187
builder :: Builder -> Predicate
188
builder b = liftM (b ==) getBuilder
189

Andrey Mokhov's avatar
Andrey Mokhov committed
190 191 192 193 194 195 196
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = do
    stage <- getStage
    builder <- getBuilder
    return $ builder == sb stage

197
file :: FilePattern -> Predicate
198
file f = liftM (any (f ?==)) getFiles
199 200

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