Expression.hs 4.07 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,
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 92 93
fromDiff :: Monoid a => DiffExpr a -> Expr a
fromDiff = fmap (($ mempty) . appEndo)

applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
94 95 96
    bool <- predicate
    if bool then expr else return mempty

Andrey Mokhov's avatar
Andrey Mokhov committed
97 98
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate
99

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

103 104
infixr 8 ?

105
stage :: Stage -> Predicate
106 107
stage s = liftM (s ==) (asks getStage)

108
notStage :: Stage -> Predicate
109 110
notStage = liftM not . stage

111 112 113 114 115 116 117
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

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

package :: Package -> Predicate
118 119
package p = liftM (p ==) (asks getPackage)

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

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

127
configKeyYes :: String -> Predicate
128 129
configKeyYes key = configKeyValue key "YES"

130
configKeyNo :: String -> Predicate
131 132
configKeyNo key = configKeyValue key "NO"

133 134
configKeyNonEmpty :: String -> Predicate
configKeyNonEmpty key = liftM not $ configKeyValue key ""