Expression.hs 5.05 KB
Newer Older
1 2 3
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
    module Control.Monad.Reader,
4
    module Data.Monoid,
Andrey Mokhov's avatar
Andrey Mokhov committed
5
    Expr, DiffExpr, fromDiff,
6
    Predicate,
Andrey Mokhov's avatar
Andrey Mokhov committed
7
    Settings, Ways, Packages,
8
    Environment (..), defaultEnvironment,
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
10
    interpret, interpretDiff,
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 22 23 24
import Control.Monad.Reader

data Environment = Environment
     {
        getStage   :: Stage,
25
        getPackage :: Package,
26
        getBuilder :: Builder,
Andrey Mokhov's avatar
Andrey Mokhov committed
27
        getFile    :: FilePath, -- TODO: handle multple files?
28
        getWay     :: Way
29 30
     }

31 32
-- TODO: all readers are currently partial functions. Can use type classes to
-- guarantee these errors never occur.
33 34 35 36
defaultEnvironment :: Environment
defaultEnvironment = Environment
    {
        getStage   = error "Stage not set in the environment",
37
        getPackage = error "Package not set in the environment",
38
        getBuilder = error "Builder not set in the environment",
39 40
        getFile    = error "File not set in the environment",
        getWay     = error "Way not set in the environment"
41 42
    }

Andrey Mokhov's avatar
Andrey Mokhov committed
43
type Expr a = ReaderT Environment Action a
44
type DiffExpr a = Expr (Dual (Endo a))
45

Andrey Mokhov's avatar
Andrey Mokhov committed
46
type Predicate = Expr Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
47 48 49 50

type Settings = DiffExpr [String]
type Ways     = DiffExpr [Way]
type Packages = DiffExpr [Package]
51

Andrey Mokhov's avatar
Andrey Mokhov committed
52
instance Monoid a => Monoid (Expr a) where
53 54 55
    mempty  = return mempty
    mappend = liftM2 mappend

56 57
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
58
append :: Monoid a => a -> DiffExpr a
59
append x = return . Dual . Endo $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
60

61
-- 2) remove given elements from a list expression
Andrey Mokhov's avatar
Andrey Mokhov committed
62
remove :: Eq a => [a] -> DiffExpr [a]
63
remove xs = return . Dual . Endo $ filter (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
64

65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
-- 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
81 82 83 84
-- 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.
85
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
86
appendSub prefix xs
87 88
    | xs' == [] = mempty
    | otherwise = return . Dual . Endo $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
89
  where
90
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
91
    go True  []     = []
92
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
93
    go found (y:ys) = if prefix `isPrefixOf` y
94 95
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
96 97 98

-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
99
appendSubD :: String -> Settings -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
100 101
appendSubD prefix diffExpr = fromDiff diffExpr >>= appendSub prefix

102 103
filterSub :: String -> (String -> Bool) -> Settings
filterSub prefix p = return . Dual . Endo $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
104 105 106 107 108
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

109 110
-- remove given elements from a list of sub-arguments with a given prefix
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
111
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
112 113
removeSub prefix xs = filterSub prefix (`notElem` xs)

114
-- Interpret a given expression in a given environment
Andrey Mokhov's avatar
Andrey Mokhov committed
115
interpret :: Environment -> Expr a -> Action a
116
interpret = flip runReaderT
117

118
-- Extract an expression from a difference expression
Andrey Mokhov's avatar
Andrey Mokhov committed
119
fromDiff :: Monoid a => DiffExpr a -> Expr a
120
fromDiff = fmap (($ mempty) . appEndo . getDual)
Andrey Mokhov's avatar
Andrey Mokhov committed
121

122
-- Interpret a given difference expression in a given environment
123
interpretDiff :: Monoid a => Environment -> DiffExpr a -> Action a
124 125
interpretDiff env = interpret env . fromDiff

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

130
-- Basic predicates (see Switches.hs for derived predicates)
131
stage :: Stage -> Predicate
132 133
stage s = liftM (s ==) (asks getStage)

134 135 136
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

137 138 139
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

140 141 142 143 144
file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile)

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

146
configKeyValue :: String -> String -> Predicate
147 148
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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