Expression.hs 6.58 KB
Newer Older
1 2 3
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
    module Control.Monad.Reader,
4
    module Data.Monoid,
5
    Expr, DiffExpr, fromDiffExpr,
6
    Predicate,
Andrey Mokhov's avatar
Andrey Mokhov committed
7
    Settings, Ways, Packages,
8
    Target (..), stageTarget, stagePackageTarget,
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
10
    interpret, interpretExpr,
11
    applyPredicate, (?), (??), stage, package, builder, file, way,
12
    configKeyValue, configKeyValues
13 14 15 16 17 18
    ) where

import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
19
import Data.Monoid
20 21
import Control.Monad.Reader

22 23 24
-- Target captures parameters relevant to the current build target: Stage and
-- Package being built, Builder that is to be invoked, file(s) that are to
-- be built and the Way they are to be built.
25
data Target = Target
26 27
     {
        getStage   :: Stage,
28
        getPackage :: Package,
29
        getBuilder :: Builder,
Andrey Mokhov's avatar
Andrey Mokhov committed
30
        getFile    :: FilePath, -- TODO: handle multple files?
31
        getWay     :: Way
32 33
     }

34 35
stageTarget :: Stage -> Target
stageTarget stage = Target
36
    {
37 38 39 40 41
        getStage   = stage,
        getPackage = error "stageTarget: Package not set",
        getBuilder = error "stageTarget: Builder not set",
        getFile    = error "stageTarget: File not set",
        getWay     = error "stageTarget: Way not set"
42 43
    }

44 45 46 47 48 49 50 51 52 53
stagePackageTarget :: Stage -> Package -> Target
stagePackageTarget stage package = Target
    {
        getStage   = stage,
        getPackage = package,
        getBuilder = error "stagePackageTarget: Builder not set",
        getFile    = error "stagePackageTarget: File not set",
        getWay     = error "stagePackageTarget: Way not set"
    }

54 55 56 57 58 59 60 61 62 63 64 65
-- 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.
66
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
67
-- The name comes from "difference lists".
68 69
newtype Diff a = Diff { fromDiff :: a -> a }

70 71 72 73 74 75 76
-- 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.
77 78 79
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
80

81 82 83 84 85 86 87
-- The following expressions are used throughout the build system for
-- specifying conditions (Predicate), lists of arguments (Settings), Ways and
-- Packages.
type Predicate = Expr Bool
type Settings  = DiffExpr [String] -- TODO: rename to Args
type Ways      = DiffExpr [Way]
type Packages  = DiffExpr [Package]
88

89 90
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
91
append :: Monoid a => a -> DiffExpr a
92
append x = return . Diff $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
93

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

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
-- 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
114 115 116 117
-- 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.
118
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
119
appendSub prefix xs
120
    | xs' == [] = mempty
121
    | otherwise = return . Diff $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
122
  where
123
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
124
    go True  []     = []
125
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
126
    go found (y:ys) = if prefix `isPrefixOf` y
127 128
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
129 130 131

-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
132
appendSubD :: String -> Settings -> Settings
133
appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
Andrey Mokhov's avatar
Andrey Mokhov committed
134

135
filterSub :: String -> (String -> Bool) -> Settings
136
filterSub prefix p = return . Diff $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
137 138 139 140 141
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

142
-- Remove given elements from a list of sub-arguments with a given prefix
143
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
144
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
145 146
removeSub prefix xs = filterSub prefix (`notElem` xs)

147
-- Interpret a given expression in a given environment
148 149
interpretExpr :: Target -> Expr a -> Action a
interpretExpr = flip runReaderT
150

151
-- Extract an expression from a difference expression
152 153
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
154

155
-- Interpret a given difference expression in a given environment
156 157
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
158

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

163
-- Basic predicates (see Switches.hs for derived predicates)
164
stage :: Stage -> Predicate
165 166
stage s = liftM (s ==) (asks getStage)

167 168 169
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

170 171 172
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

173 174 175 176 177
file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile)

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

179
configKeyValue :: String -> String -> Predicate
180 181
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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