Expression.hs 4.18 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
    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 40 41
type Predicate = Expr Bool
type Ways      = DiffExpr [Way]
type Packages  = DiffExpr [Package]
42

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

Andrey Mokhov's avatar
Andrey Mokhov committed
47 48 49 50 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
append :: Monoid a => a -> DiffExpr a
append x = return $ Endo (<> x)

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
87
interpret = flip runReaderT
88

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

92 93 94
interpretDiff :: Environment -> Expr a -> Action a
interpretDiff env = interpret env . fromDiff

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

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

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

106 107
infixr 8 ?

108
stage :: Stage -> Predicate
109 110
stage s = liftM (s ==) (asks getStage)

111
notStage :: Stage -> Predicate
112 113
notStage = liftM not . stage

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

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

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

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

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

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

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

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