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

import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
20
import Data.Monoid
21 22
import Development.Shake.Classes
import GHC.Generics
23 24
import Control.Monad.Reader

25 26 27
-- 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.
28
data Target = Target
29 30
     {
        getStage   :: Stage,
31
        getPackage :: Package,
32
        getBuilder :: Builder,
Andrey Mokhov's avatar
Andrey Mokhov committed
33
        getFile    :: FilePath, -- TODO: handle multple files?
34
        getWay     :: Way
35
     }
36 37 38 39 40 41 42 43 44 45 46 47 48
     deriving (Eq, Generic)

-- Shows a target as "package:file@stage (builder, way)"
instance Show Target where
    show target = show (getPackage target)
                  ++ ":" ++ show (getFile target)
                  ++ "@" ++ show (getStage target)
                  ++ " (" ++ show (getBuilder target)
                  ++ ", " ++ show (getWay target) ++ ")"

instance Binary Target
instance NFData Target
instance Hashable Target
49

50 51
stageTarget :: Stage -> Target
stageTarget stage = Target
52
    {
53 54 55 56 57
        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"
58 59
    }

60 61 62 63 64 65 66 67 68 69
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"
    }

70 71 72 73 74 75 76 77 78 79 80 81
-- 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.
82
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
83
-- The name comes from "difference lists".
84 85
newtype Diff a = Diff { fromDiff :: a -> a }

86 87 88 89 90 91 92
-- 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.
93 94 95
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
96

97 98 99 100 101 102 103
-- 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]
104

105 106
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
107
append :: Monoid a => a -> DiffExpr a
108
append x = return . Diff $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
109

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

114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
-- 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
130 131 132 133
-- 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.
134
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
135
appendSub prefix xs
136
    | xs' == [] = mempty
137
    | otherwise = return . Diff $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
138
  where
139
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
140
    go True  []     = []
141
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
142
    go found (y:ys) = if prefix `isPrefixOf` y
143 144
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
145 146 147

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

151
filterSub :: String -> (String -> Bool) -> Settings
152
filterSub prefix p = return . Diff $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
153 154 155 156 157
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

158
-- Remove given elements from a list of sub-arguments with a given prefix
159
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
160
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
161 162
removeSub prefix xs = filterSub prefix (`notElem` xs)

163
-- Interpret a given expression in a given environment
164 165
interpretExpr :: Target -> Expr a -> Action a
interpretExpr = flip runReaderT
166

167
-- Extract an expression from a difference expression
168 169
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
170

171
-- Interpret a given difference expression in a given environment
172 173
interpret :: Monoid a => Target -> DiffExpr a -> Action a
interpret target = interpretExpr target . fromDiffExpr
174

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

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

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

186 187 188
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

189 190 191 192 193
file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile)

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

195
configKeyValue :: String -> String -> Predicate
196 197
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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