Expression.hs 4.28 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,
Andrey Mokhov's avatar
Andrey Mokhov committed
11
    applyPredicate, (?), (??), stage, notStage, builder, notBuilder, 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 39
type Expr a = ReaderT Environment Action a
type DiffExpr a = Expr (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
Andrey Mokhov's avatar
Andrey Mokhov committed
52
append = return . Endo . mappend
Andrey Mokhov's avatar
Andrey Mokhov committed
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 89 90

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
91
interpret = flip runReaderT
92

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

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

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

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

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

110 111
infixr 8 ?

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

115
notStage :: Stage -> Predicate
116 117
notStage = liftM not . stage

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

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

package :: Package -> Predicate
125 126
package p = liftM (p ==) (asks getPackage)

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

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

134
configKeyYes :: String -> Predicate
135 136
configKeyYes key = configKeyValue key "YES"

137
configKeyNo :: String -> Predicate
138 139
configKeyNo key = configKeyValue key "NO"

140 141
configKeyNonEmpty :: String -> Predicate
configKeyNonEmpty key = liftM not $ configKeyValue key ""