Expression.hs 3.81 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
{-# LANGUAGE FlexibleInstances #-}

module Expression (
    Guard,
    Settings,
    module Expression.ArgList,
    module Expression.Predicate,
    opts, fence, (?),
    packages, package, setPackage,
    builders, builder, setBuilder,
    stages, stage, notStage, setStage,
    ways, way, setWay,
    files, file, setFile,
    keyValues, keyValue, keyYes, keyNo, setKeyValue,
    packageKey, packageDeps, packageDepKeys
    ) where

import Base
import Ways
import Package.Base (Package)
import Oracles.Builder
import Expression.PG
import Expression.Predicate
import Expression.ArgList

data BuildParameter = WhenPackage  Package
                    | WhenBuilder  Builder
                    | WhenStage    Stage
                    | WhenWay      Way
                    | WhenFile     FilePattern
                    | WhenKeyValue String String -- from config files

type Guard = Predicate BuildParameter

instance Monoid Guard where
    mempty = Evaluated True
    mappend = And

type Settings = PG Guard ArgList

opts :: [String] -> Settings
opts = mconcat . map (\s -> Vertex $ Plain [s])

fence :: Settings -> Settings -> Settings
fence = Sequence

(?) :: Guard -> Settings -> Settings
(?) = Condition

infixl 7 ?

alternatives :: (a -> BuildParameter) -> [a] -> Guard
alternatives p = multiOr . map (Parameter . p)

-- Basic GHC build guards

packages :: [Package] -> Guard
packages = alternatives WhenPackage

builders :: [Builder] -> Guard
builders = alternatives WhenBuilder

stages :: [Stage] -> Guard
stages = alternatives WhenStage

ways :: [Way] -> Guard
ways = alternatives WhenWay

files :: [FilePattern] -> Guard
files = alternatives WhenFile

keyValues :: String -> [String] -> Guard
keyValues key = alternatives (WhenKeyValue key)

package :: Package -> Guard
package p = packages [p]

builder :: Builder -> Guard
builder b = builders [b]

stage :: Stage -> Guard
stage s = stages [s]

notStage :: Stage -> Guard
notStage = Not . Parameter . WhenStage

way :: Way -> Guard
way w = ways [w]

file :: FilePattern -> Guard
file f = files [f]

keyValue :: String -> String -> Guard
keyValue key value = keyValues key [value]

keyYes, keyNo :: String -> Guard
keyYes key = keyValues key ["YES"]
keyNo  key = keyValues key ["NO" ]

-- Partial evaluation of settings

setPackage :: Package -> Settings -> Settings
setPackage = project . matchPackage

setBuilder :: Builder -> Settings -> Settings
setBuilder = project . matchBuilder

setStage :: Stage -> Settings -> Settings
setStage = project . matchStage

setWay :: Way -> Settings -> Settings
setWay = project . matchWay

setFile :: FilePath -> Settings -> Settings
setFile = project . matchFile

setKeyValue :: String -> String -> Settings -> Settings
setKeyValue key = project . matchKeyValue key

-- Truth-tellers for partial evaluation

type Matcher = TruthTeller BuildParameter

matchPackage :: Package -> Matcher
matchPackage p (WhenPackage p') = Just $ p == p'
matchPackage _ _                = Nothing

matchBuilder :: Builder -> Matcher
matchBuilder b (WhenBuilder b') = Just $ b == b'
matchBuilder _ _                = Nothing

matchStage :: Stage -> Matcher
matchStage s (WhenStage s') = Just $ s == s'
matchStage _ _              = Nothing

matchWay :: Way -> Matcher
matchWay w (WhenWay w') = Just $ w == w'
matchWay _ _            = Nothing

matchFile :: FilePath -> Matcher
matchFile file (WhenFile pattern) = Just $ pattern ?== file
matchFile _ _                     = Nothing

matchKeyValue :: String -> String -> Matcher
matchKeyValue key value (WhenKeyValue key' value')
    | key == key' = Just $ value == value'
    | otherwise   = Nothing
matchKeyValue _ _ _ = Nothing

-- Argument templates

packageKey :: String -> Settings
packageKey = Vertex . PackageKey

packageDeps :: String -> Settings
packageDeps = Vertex . PackageDeps

packageDepKeys :: String -> Settings
packageDepKeys = Vertex . PackageDepKeys