Expression.hs 4.17 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, builder, package,
12 13 14 15 16 17 18 19
    configKeyValue, configKeyValues,
    configKeyYes, configKeyNo, configKeyNonEmpty
    ) where

import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
20
import Data.Monoid
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
import Control.Monad.Reader

data Environment = Environment
     {
        getStage   :: Stage,
        getBuilder :: Builder,
        getPackage :: Package
     }

defaultEnvironment :: Environment
defaultEnvironment = Environment
    {
        getStage   = error "Stage not set in the environment",
        getBuilder = error "Builder not set in the environment",
        getPackage = error "Package not set in the environment"
    }

Andrey Mokhov's avatar
Andrey Mokhov committed
38
type Expr a = ReaderT Environment Action a
39
type DiffExpr a = Expr (Dual (Endo a))
40

Andrey Mokhov's avatar
Andrey Mokhov committed
41
type Predicate = Expr Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
42 43 44 45

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

Andrey Mokhov's avatar
Andrey Mokhov committed
47
instance Monoid a => Monoid (Expr a) where
48 49 50
    mempty  = return mempty
    mappend = liftM2 mappend

Andrey Mokhov's avatar
Andrey Mokhov committed
51
append :: Monoid a => a -> DiffExpr a
52
append x = return . Dual . Endo $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
53 54 55 56 57

appendM :: Monoid a => Action a -> DiffExpr a
appendM mx = lift mx >>= append

remove :: Eq a => [a] -> DiffExpr [a]
58
remove xs = return . Dual . Endo $ filter (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
59 60 61 62 63

-- 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.
64
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
65
appendSub prefix xs
66 67
    | xs' == [] = mempty
    | otherwise = return . Dual . Endo $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
68
  where
69
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
70
    go True  []     = []
71
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
72
    go found (y:ys) = if prefix `isPrefixOf` y
73 74
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
75 76 77

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

81 82
filterSub :: String -> (String -> Bool) -> Settings
filterSub prefix p = return . Dual . Endo $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
83 84 85 86 87
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

88
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
89 90 91
removeSub prefix xs = filterSub prefix (`notElem` xs)

interpret :: Environment -> Expr a -> Action a
92
interpret = flip runReaderT
93

Andrey Mokhov's avatar
Andrey Mokhov committed
94
fromDiff :: Monoid a => DiffExpr a -> Expr a
95
fromDiff = fmap (($ mempty) . appEndo . getDual)
Andrey Mokhov's avatar
Andrey Mokhov committed
96

97
interpretDiff :: Monoid a => Environment -> DiffExpr a -> Action a
98 99
interpretDiff env = interpret env . fromDiff

Andrey Mokhov's avatar
Andrey Mokhov committed
100 101
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
102 103 104
    bool <- predicate
    if bool then expr else return mempty

Andrey Mokhov's avatar
Andrey Mokhov committed
105 106
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate
107

Andrey Mokhov's avatar
Andrey Mokhov committed
108
(??) :: Monoid a => Predicate -> (Expr a, Expr a) -> Expr a
109 110
p ?? (t, f) = p ? t <> (liftM not p) ? f

111 112
infixr 8 ?

113
stage :: Stage -> Predicate
114 115
stage s = liftM (s ==) (asks getStage)

116 117 118 119
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

package :: Package -> Predicate
120 121
package p = liftM (p ==) (asks getPackage)

122
configKeyValue :: String -> String -> Predicate
123 124 125
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

-- checks if there is at least one match
126
configKeyValues :: String -> [String] -> Predicate
Andrey Mokhov's avatar
Andrey Mokhov committed
127
configKeyValues key values = liftM (`elem` values) (lift $ askConfig key)
128

129
configKeyYes :: String -> Predicate
130 131
configKeyYes key = configKeyValue key "YES"

132
configKeyNo :: String -> Predicate
133 134
configKeyNo key = configKeyValue key "NO"

135 136
configKeyNonEmpty :: String -> Predicate
configKeyNonEmpty key = liftM not $ configKeyValue key ""