Expression.hs 6.77 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,
    getDependencies, getDependency, getWay,
Andrey Mokhov's avatar
Andrey Mokhov committed
14
    stage, package, builder, stagedBuilder, file, way
15 16
    ) where

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

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

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

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

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

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

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

infixr 8 ?

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

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

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

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

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

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

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

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

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

155 156 157 158 159 160 161 162 163 164 165 166 167
-- 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
168 169 170 171 172 173 174 175 176
-- 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

Andrey Mokhov's avatar
Andrey Mokhov committed
177 178 179 180 181 182 183 184 185 186 187 188
getDependencies :: Expr [FilePath]
getDependencies = asks Target.dependencies

getDependency :: Expr FilePath
getDependency = do
    target <- ask
    deps   <- getDependencies
    case deps of
        [dep] -> return dep
        _     -> error $ "Exactly one dependency expected in target "
                       ++ show target

189 190 191
getWay :: Expr Way
getWay = asks Target.way

192
-- Basic predicates (see Switches.hs for derived predicates)
193
stage :: Stage -> Predicate
194
stage s = liftM (s ==) getStage
195

196
package :: Package -> Predicate
197
package p = liftM (p ==) getPackage
198

Andrey Mokhov's avatar
Andrey Mokhov committed
199
-- For unstaged builders, e.g. GhcCabal
200
builder :: Builder -> Predicate
201
builder b = liftM (b ==) getBuilder
202

Andrey Mokhov's avatar
Andrey Mokhov committed
203 204 205 206 207 208 209
-- For staged builders, e.g. Ghc Stage
stagedBuilder :: (Stage -> Builder) -> Predicate
stagedBuilder sb = do
    stage <- getStage
    builder <- getBuilder
    return $ builder == sb stage

210
file :: FilePattern -> Predicate
211
file f = liftM (any (f ?==)) getFiles
212 213

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