Expression.hs 4.67 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,
11
    applyPredicate, (?), (??), stage, builder, package,
12
    configKeyValue, configKeyValues
13 14 15 16 17 18
    ) where

import Base hiding (arg, args, Args, TargetDir)
import Ways
import Oracles
import Package
19
import Data.Monoid
20 21 22 23 24 25 26
import Control.Monad.Reader

data Environment = Environment
     {
        getStage   :: Stage,
        getBuilder :: Builder,
        getPackage :: Package
27
        -- getWay  :: Way, and maybe something else will be useful later
28 29
     }

30 31
-- TODO: all readers are currently partial functions. Can use type classes to
-- guarantee these errors never occur.
32 33 34 35 36 37 38 39
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
40
type Expr a = ReaderT Environment Action a
41
type DiffExpr a = Expr (Dual (Endo a))
42

Andrey Mokhov's avatar
Andrey Mokhov committed
43
type Predicate = Expr Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
44 45 46 47

type Settings = DiffExpr [String]
type Ways     = DiffExpr [Way]
type Packages = DiffExpr [Package]
48

Andrey Mokhov's avatar
Andrey Mokhov committed
49
instance Monoid a => Monoid (Expr a) where
50 51 52
    mempty  = return mempty
    mappend = liftM2 mappend

53 54
-- Basic operations on expressions:
-- 1) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
55
append :: Monoid a => a -> DiffExpr a
56
append x = return . Dual . Endo $ (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
57

58
-- 2) remove given elements from a list expression
Andrey Mokhov's avatar
Andrey Mokhov committed
59
remove :: Eq a => [a] -> DiffExpr [a]
60
remove xs = return . Dual . Endo $ filter (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
61

62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
-- 3) apply a predicate to an expression
applyPredicate :: Monoid a => Predicate -> Expr a -> Expr a
applyPredicate predicate expr = do
    bool <- predicate
    if bool then expr else return mempty

-- A convenient operator for predicate application
(?) :: Monoid a => Predicate -> Expr a -> Expr a
(?) = applyPredicate

infixr 8 ?

-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
appendM mx = lift mx >>= append

Andrey Mokhov's avatar
Andrey Mokhov committed
78 79 80 81
-- 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.
82
appendSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
83
appendSub prefix xs
84 85
    | xs' == [] = mempty
    | otherwise = return . Dual . Endo $ go False
Andrey Mokhov's avatar
Andrey Mokhov committed
86
  where
87
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
88
    go True  []     = []
89
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
90
    go found (y:ys) = if prefix `isPrefixOf` y
91 92
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
93 94 95

-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
96
appendSubD :: String -> Settings -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
97 98
appendSubD prefix diffExpr = fromDiff diffExpr >>= appendSub prefix

99 100
filterSub :: String -> (String -> Bool) -> Settings
filterSub prefix p = return . Dual . Endo $ map filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
101 102 103 104 105
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

106 107
-- remove given elements from a list of sub-arguments with a given prefix
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
108
removeSub :: String -> [String] -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
109 110
removeSub prefix xs = filterSub prefix (`notElem` xs)

111
-- Interpret a given expression in a given environment
Andrey Mokhov's avatar
Andrey Mokhov committed
112
interpret :: Environment -> Expr a -> Action a
113
interpret = flip runReaderT
114

115
-- Extract an expression from a difference expression
Andrey Mokhov's avatar
Andrey Mokhov committed
116
fromDiff :: Monoid a => DiffExpr a -> Expr a
117
fromDiff = fmap (($ mempty) . appEndo . getDual)
Andrey Mokhov's avatar
Andrey Mokhov committed
118

119
-- Interpret a given difference expression in a given environment
120
interpretDiff :: Monoid a => Environment -> DiffExpr a -> Action a
121 122
interpretDiff env = interpret env . fromDiff

123
-- An equivalent of if-then-else for predicates
Andrey Mokhov's avatar
Andrey Mokhov committed
124
(??) :: Monoid a => Predicate -> (Expr a, Expr a) -> Expr a
125 126
p ?? (t, f) = p ? t <> (liftM not p) ? f

127
-- Basic predicates
128
stage :: Stage -> Predicate
129 130
stage s = liftM (s ==) (asks getStage)

131 132 133 134
builder :: Builder -> Predicate
builder b = liftM (b ==) (asks getBuilder)

package :: Package -> Predicate
135 136
package p = liftM (p ==) (asks getPackage)

137
configKeyValue :: String -> String -> Predicate
138 139 140
configKeyValue key value = liftM (value ==) (lift $ askConfig key)

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