Expression.hs 2.44 KB
Newer Older
1 2 3 4 5 6
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
    module Control.Monad.Reader,
    Ways,
    Predicate,
    Expression,
7
    Environment (..), defaultEnvironment,
8
    interpret,
9
    whenPredicate, (?), (??), stage, notStage, builder, notBuilder, package,
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
    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"
    }

35
type Expression a = ReaderT Environment Action a
36

37 38
type Ways      = Expression [Way]
type Predicate = Expression Bool
39

40
instance Monoid a => Monoid (Expression a) where
41 42 43
    mempty  = return mempty
    mappend = liftM2 mappend

44 45
interpret :: Environment -> Expression a -> Action a
interpret = flip runReaderT
46

47
whenPredicate :: Monoid a => Predicate -> Expression a -> Expression a
48 49 50 51
whenPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

52
(?) :: Monoid a => Predicate -> Expression a -> Expression a
53 54
(?) = whenPredicate

55 56 57
(??) :: Monoid a => Predicate -> (Expression a, Expression a) -> Expression a
p ?? (t, f) = p ? t <> (liftM not p) ? f

58 59
infixr 8 ?

60
stage :: Stage -> Predicate
61 62
stage s = liftM (s ==) (asks getStage)

63
notStage :: Stage -> Predicate
64 65
notStage = liftM not . stage

66 67 68 69 70 71 72
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

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

package :: Package -> Predicate
73 74
package p = liftM (p ==) (asks getPackage)

75
configKeyValue :: String -> String -> Predicate
76 77 78
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

-- checks if there is at least one match
79
configKeyValues :: String -> [String] -> Predicate
80 81
configKeyValues key values = liftM (flip elem $ values) (lift $ askConfig key)

82
configKeyYes :: String -> Predicate
83 84
configKeyYes key = configKeyValue key "YES"

85
configKeyNo :: String -> Predicate
86 87
configKeyNo key = configKeyValue key "NO"

88 89
configKeyNonEmpty :: String -> Predicate
configKeyNonEmpty key = liftM not $ configKeyValue key ""