Expression.hs 5.44 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, 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
import Control.Monad.Reader

22
data Target = Target
23 24
     {
        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
stageTarget :: Stage -> Target
stageTarget stage = Target
33
    {
34 35 36 37 38
        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"
39 40
    }

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
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"
    }

-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
newtype Diff a = Diff { fromDiff :: a -> a }

instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
57

58 59
type Expr a = ReaderT Target Action a
type DiffExpr a = Expr (Diff a)
Andrey Mokhov's avatar
Andrey Mokhov committed
60

61 62 63 64
type Predicate       = Expr Bool
type Settings        = DiffExpr [String] -- TODO: rename to Args
type Ways            = DiffExpr [Way]
type Packages        = DiffExpr [Package]
65

Andrey Mokhov's avatar
Andrey Mokhov committed
66
instance Monoid a => Monoid (Expr a) where
67 68 69
    mempty  = return mempty
    mappend = liftM2 mappend

70 71
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
72
append :: Monoid a => a -> DiffExpr a
73
append x = return . Diff $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
74

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

79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94
-- 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
95 96 97 98
-- 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.
99
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
100
appendSub prefix xs
101
    | xs' == [] = mempty
102
    | otherwise = return . Diff $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
103
  where
104
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
105
    go True  []     = []
106
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
107
    go found (y:ys) = if prefix `isPrefixOf` y
108 109
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
110 111 112

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

116
filterSub :: String -> (String -> Bool) -> Settings
117
filterSub prefix p = return . Diff $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
118 119 120 121 122
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

123
-- Remove given elements from a list of sub-arguments with a given prefix
124
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
125
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
126 127
removeSub prefix xs = filterSub prefix (`notElem` xs)

128
-- Interpret a given expression in a given environment
129
interpret :: Target -> Expr a -> Action a
130
interpret = flip runReaderT
131

132
-- Extract an expression from a difference expression
133 134
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
135

136
-- Interpret a given difference expression in a given environment
137 138
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
139

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

144
-- Basic predicates (see Switches.hs for derived predicates)
145
stage :: Stage -> Predicate
146 147
stage s = liftM (s ==) (asks getStage)

148 149 150
package :: Package -> Predicate
package p = liftM (p ==) (asks getPackage)

151 152 153
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

154 155 156 157 158
file :: FilePattern -> Predicate
file f = liftM (f ?==) (asks getFile)

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

160
configKeyValue :: String -> String -> Predicate
161 162
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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