Expression.hs 2.37 KB
Newer Older
1 2 3 4 5 6 7 8 9 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 35 36 37 38 39 40 41 42 43 44 45 46 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
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-}
module Expression (
    module Control.Monad.Reader,
    Ways,
    Packages,
    TargetDir,
    Predicate,
    Expression,
    Environment (..),
    interpret,
    whenPredicate, (?), stage, notStage, package,
    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"
    }

type Expression m a = ReaderT Environment m a

type Ways      m = Expression m [Way]
type Packages  m = Expression m [Package]
type Predicate m = Expression m Bool
type TargetDir m = Expression m FilePath

instance (Monad m, Monoid a) => Monoid (Expression m a) where
    mempty  = return mempty
    mappend = liftM2 mappend

interpret :: (Monad m, Monoid a) => Expression m a -> Environment -> m a
interpret = runReaderT

whenPredicate :: (Monad m, Monoid a) => Predicate m -> Expression m a -> Expression m a
whenPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

(?) :: (Monad m, Monoid a) => Predicate m -> Expression m a -> Expression m a
(?) = whenPredicate

infixr 8 ?

stage :: Monad m => Stage -> Predicate m
stage s = liftM (s ==) (asks getStage)

notStage :: Monad m => Stage -> Predicate m
notStage = liftM not . stage

package :: Monad m => Package -> Predicate m
package p = liftM (p ==) (asks getPackage)

configKeyValue :: String -> String -> Predicate Action
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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

configKeyYes :: String -> Predicate Action
configKeyYes key = configKeyValue key "YES"

configKeyNo :: String -> Predicate Action
configKeyNo key = configKeyValue key "NO"

configKeyNonEmpty :: String -> Predicate Action
configKeyNonEmpty key = configKeyValue key ""