Expression.hs 5.72 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances #-}
2
module Expression (
3
    module Target,
4
    module Data.Monoid,
5
    module Control.Monad.Reader,
6
    Expr, DiffExpr, fromDiffExpr,
7 8
    Predicate, PredicateLike (..), applyPredicate, (??),
    Args, Ways, Packages,
9 10
    apply, append, appendM, remove,
    appendSub, appendSubD, filterSub, removeSub,
11
    interpret, interpretDiff,
Andrey Mokhov's avatar
Andrey Mokhov committed
12
    getStage, getPackage, getBuilder, getFiles, getFile,
13
    getSources, getSource, getWay
14 15
    ) where

16
import Way
17
import Base
18
import Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
19 20
import Builder
import Package
21 22 23
import Target (Target)
import Target hiding (Target(..))
import qualified Target
24
import Data.List
25
import Data.Monoid
26
import Control.Monad.Reader hiding (liftIO)
27

28 29 30 31 32
-- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target.
type Expr a = ReaderT Target Action a

-- Diff a holds functions of type a -> a and is equipped with a Monoid instance.
33
-- We could use Dual (Endo a) instead of Diff a, but the former may look scary.
34
-- The name comes from "difference lists".
35 36
newtype Diff a = Diff { fromDiff :: a -> a }

37 38 39 40 41 42 43
-- DiffExpr a is a computation that builds a difference list (i.e., a function
-- of type Action (a -> a)) and can read parameters of the current build Target.
type DiffExpr a = Expr (Diff a)

-- Note the reverse order of function composition (y . x), which ensures that
-- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
-- applied first, and c2 is applied second.
44 45 46
instance Monoid (Diff a) where
    mempty = Diff id
    Diff x `mappend` Diff y = Diff $ y . x
47

48
-- The following expressions are used throughout the build system for
49
-- specifying conditions (Predicate), lists of arguments (Args), Ways and
50 51
-- Packages.
type Predicate = Expr Bool
52
type Args      = DiffExpr [String]
53
type Packages  = DiffExpr [Package]
54
type Ways      = DiffExpr [Way]
55

56
-- Basic operations on expressions:
57 58 59 60 61
-- 1) transform an expression by applying a given function
apply :: (a -> a) -> DiffExpr a
apply = return . Diff

-- 2) append something to an expression
Andrey Mokhov's avatar
Andrey Mokhov committed
62
append :: Monoid a => a -> DiffExpr a
63
append x = apply (<> x)
Andrey Mokhov's avatar
Andrey Mokhov committed
64

65
-- 3) remove given elements from a list expression
Andrey Mokhov's avatar
Andrey Mokhov committed
66
remove :: Eq a => [a] -> DiffExpr [a]
67
remove xs = apply . filter $ (`notElem` xs)
Andrey Mokhov's avatar
Andrey Mokhov committed
68

69
-- 4) apply a predicate to an expression
70 71 72 73 74 75
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
76 77 78
class PredicateLike a where
    (?)  :: Monoid m => a -> Expr m -> Expr m
    notP :: a -> Predicate
79 80 81

infixr 8 ?

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
instance PredicateLike Predicate where
    (?)  = applyPredicate
    notP = liftM not

instance PredicateLike Bool where
    (?)  = applyPredicate . return
    notP = return . not

instance PredicateLike (Action Bool) where
    (?)  = applyPredicate . lift
    notP = lift . fmap not

-- An equivalent of if-then-else for predicates
(??) :: (PredicateLike a, Monoid m) => a -> (Expr m, Expr m) -> Expr m
p ?? (t, f) = p ? t <> notP p ? f

98 99
-- A monadic version of append
appendM :: Monoid a => Action a -> DiffExpr a
100
appendM = (append =<<) . lift
101

Andrey Mokhov's avatar
Andrey Mokhov committed
102 103 104 105
-- 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.
106
appendSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
107
appendSub prefix xs
108
    | xs' == [] = mempty
109
    | otherwise = apply . go $ False
Andrey Mokhov's avatar
Andrey Mokhov committed
110
  where
111
    xs' = filter (/= "") xs
Andrey Mokhov's avatar
Andrey Mokhov committed
112
    go True  []     = []
113
    go False []     = [prefix ++ "=" ++ unwords xs']
Andrey Mokhov's avatar
Andrey Mokhov committed
114
    go found (y:ys) = if prefix `isPrefixOf` y
115 116
                      then unwords (y : xs') : go True ys
                      else y : go found ys
Andrey Mokhov's avatar
Andrey Mokhov committed
117 118 119

-- appendSubD is similar to appendSub but it extracts the list of sub-arguments
-- from the given DiffExpr.
120
appendSubD :: String -> Args -> Args
121
appendSubD prefix diffExpr = fromDiffExpr diffExpr >>= appendSub prefix
Andrey Mokhov's avatar
Andrey Mokhov committed
122

123
filterSub :: String -> (String -> Bool) -> Args
124
filterSub prefix p = apply . map $ filterSubstr
Andrey Mokhov's avatar
Andrey Mokhov committed
125 126 127 128 129
  where
    filterSubstr s
        | prefix `isPrefixOf` s = unwords . filter p . words $ s
        | otherwise             = s

130
-- Remove given elements from a list of sub-arguments with a given prefix
131
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"]
132
removeSub :: String -> [String] -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
133 134
removeSub prefix xs = filterSub prefix (`notElem` xs)

135
-- Interpret a given expression in a given environment
136 137
interpret :: Target -> Expr a -> Action a
interpret = flip runReaderT
138

139
-- Extract an expression from a difference expression
140 141
fromDiffExpr :: Monoid a => DiffExpr a -> Expr a
fromDiffExpr = fmap (($ mempty) . fromDiff)
Andrey Mokhov's avatar
Andrey Mokhov committed
142

143
-- Interpret a given difference expression in a given environment
144 145
interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
interpretDiff target = interpret target . fromDiffExpr
146

147 148 149 150 151 152 153 154 155 156
-- Convenient getters for target parameters
getStage :: Expr Stage
getStage = asks Target.stage

getPackage :: Expr Package
getPackage = asks Target.package

getBuilder :: Expr Builder
getBuilder = asks Target.builder

Andrey Mokhov's avatar
Andrey Mokhov committed
157 158 159 160 161 162 163 164 165 166 167 168 169 170
getWay :: Expr Way
getWay = asks Target.way

getSources :: Expr [FilePath]
getSources = asks Target.sources

getSource :: Expr FilePath
getSource = do
    target <- ask
    srcs   <- getSources
    case srcs of
        [src] -> return src
        _     -> error $ "Exactly one source expected in target " ++ show target

171 172 173
getFiles :: Expr [FilePath]
getFiles = asks Target.files

Andrey Mokhov's avatar
Andrey Mokhov committed
174 175 176 177 178 179
-- Run getFiles and check that it contains a single file only
getFile :: Expr FilePath
getFile = do
    target <- ask
    files  <- getFiles
    case files of
180 181
        [res] -> return res
        _     -> error $ "Exactly one file expected in target " ++ show target