Expression.hs 4.24 KB
Newer Older
1 2 3
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
    module Control.Monad.Reader,
Andrey Mokhov's avatar
Andrey Mokhov committed
4
    Expr, DiffExpr, fromDiff,
5
    Predicate,
Andrey Mokhov's avatar
Andrey Mokhov committed
6
    Settings, Ways, Packages,
7
    Environment (..), defaultEnvironment,
Andrey Mokhov's avatar
Andrey Mokhov committed
8
    append, appendM, remove, appendSub, appendSubD, filterSub, removeSub,
9
    interpret, interpretDiff,
Andrey Mokhov's avatar
Andrey Mokhov committed
10
    applyPredicate, (?), (??), stage, notStage, builder, notBuilder, package,
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
    configKeyValue, configKeyValues,
    configKeyYes, configKeyNo, configKeyNonEmpty
    ) where

import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
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
36 37
type Expr a = ReaderT Environment Action a
type DiffExpr a = Expr (Endo a)
38

Andrey Mokhov's avatar
Andrey Mokhov committed
39
type Predicate = Expr Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
40 41 42 43

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
49
append :: Monoid a => a -> DiffExpr a
Andrey Mokhov's avatar
Andrey Mokhov committed
50
append = return . Endo . mappend
Andrey Mokhov's avatar
Andrey Mokhov committed
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88

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

remove :: Eq a => [a] -> DiffExpr [a]
remove xs = return . Endo $ filter (`notElem` xs)

-- 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.
appendSub :: String -> [String] -> DiffExpr [String]
appendSub prefix xs
    | xs == []  = mempty
    | otherwise = return $ Endo (go False)
  where
    go True  []     = []
    go False []     = [prefix ++ "=" ++ unwords xs]
    go found (y:ys) = if prefix `isPrefixOf` y
                      then unwords (y : xs) : go True ys
                      else go found ys

-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
appendSubD :: String -> DiffExpr [String] -> DiffExpr [String]
appendSubD prefix diffExpr = fromDiff diffExpr >>= appendSub prefix

filterSub :: String -> (String -> Bool) -> DiffExpr [String]
filterSub prefix p = return . Endo $ map filterSubstr
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

removeSub :: String -> [String] -> DiffExpr [String]
removeSub prefix xs = filterSub prefix (`notElem` xs)

interpret :: Environment -> Expr a -> Action a
89
interpret = flip runReaderT
90

Andrey Mokhov's avatar
Andrey Mokhov committed
91 92 93
fromDiff :: Monoid a => DiffExpr a -> Expr a
fromDiff = fmap (($ mempty) . appEndo)

94
interpretDiff :: Monoid a => Environment -> DiffExpr a -> Action a
95 96
interpretDiff env = interpret env . fromDiff

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

Andrey Mokhov's avatar
Andrey Mokhov committed
102 103
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate
104

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

108 109
infixr 8 ?

110
stage :: Stage -> Predicate
111 112
stage s = liftM (s ==) (asks getStage)

113
notStage :: Stage -> Predicate
114 115
notStage = liftM not . stage

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

notBuilder :: Builder -> Predicate
notBuilder = liftM not . builder

package :: Package -> Predicate
123 124
package p = liftM (p ==) (asks getPackage)

125
configKeyValue :: String -> String -> Predicate
126 127 128
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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

132
configKeyYes :: String -> Predicate
133 134
configKeyYes key = configKeyValue key "YES"

135
configKeyNo :: String -> Predicate
136 137
configKeyNo key = configKeyValue key "NO"

138 139
configKeyNonEmpty :: String -> Predicate
configKeyNonEmpty key = liftM not $ configKeyValue key ""