Base.hs 7.44 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
2
{-# LANGUAGE FlexibleInstances #-}

3
module Expression.Base (
Andrey Mokhov's avatar
Andrey Mokhov committed
4
5
6
    module Expression.Build,
    module Expression.Predicate,
    (?), (??), whenExists,
7
8
    Args (..), -- TODO: hide?
    Combine (..), -- TODO: hide?
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    Settings,
10
11
    Packages,
    FilePaths,
Andrey Mokhov's avatar
Andrey Mokhov committed
12
    Ways,
13
    project,
14
    arg, args, argPath, argsOrdered, argBuildPath, argBuildDir,
15
    argInput, argOutput,
16
17
    argConfig, argStagedConfig, argConfigList, argStagedConfigList,
    argBuilderPath, argStagedBuilderPath,
18
    argWithBuilder, argWithStagedBuilder,
19
20
    argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
    argIncludeDirs, argDepIncludeDirs,
21
22
    argConcat, argConcatPath, argConcatSpace,
    argPairs, argPrefix, argPrefixPath,
23
    argBootPkgConstraints,
Andrey Mokhov's avatar
Andrey Mokhov committed
24
25
    setPackage, setBuilder, setBuilderFamily, setStage, setWay,
    setFile, setConfig
Andrey Mokhov's avatar
Andrey Mokhov committed
26
27
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
28
import Base hiding (arg, args, Args)
Andrey Mokhov's avatar
Andrey Mokhov committed
29
import Ways
30
import Util
31
import Package (Package)
Andrey Mokhov's avatar
Andrey Mokhov committed
32
33
34
import Oracles.Builder
import Expression.PG
import Expression.Predicate
Andrey Mokhov's avatar
Andrey Mokhov committed
35
import Expression.Build
36

Andrey Mokhov's avatar
Andrey Mokhov committed
37
38
-- Settings can be built out of the following primitive elements
data Args
39
40
41
42
43
44
    = Plain String           -- a plain old string argument: e.g., "-O2"
    | BuildPath              -- evaluates to build path: "libraries/base"
    | BuildDir               -- evaluates to build directory: "dist-install"
    | Input                  -- evaluates to input file(s): "src.c"
    | Output                 -- evaluates to output file(s): "src.o"
    | Config String          -- evaluates to the value of a given config key
45
    | ConfigList String      -- as above, but evaluates to a list of values
46
47
    | BuilderPath Builder    -- evaluates to the path to a given builder
    | PackageData String     -- looks up value a given key in package-data.mk
48
    | PackageDataList String -- as above, but evaluates to a list of values
49
50
51
    | BootPkgConstraints     -- evaluates to boot package constraints
    | Fold Combine Settings  -- fold settings using a given combine method

52
53
data Combine = Id            -- Keep given settings as is
             | Concat        -- Concatenate: a ++ b
54
55
             | ConcatPath    -- </>-concatenate: a </> b
             | ConcatSpace   -- concatenate with a space: a ++ " " ++ b
56
57
58
59
60

type Ways      = BuildExpression Way
type Settings  = BuildExpression Args
type Packages  = BuildExpression Package
type FilePaths = BuildExpression FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
61

Andrey Mokhov's avatar
Andrey Mokhov committed
62
63
-- A single argument
arg :: String -> Settings
64
arg = return . Plain
Andrey Mokhov's avatar
Andrey Mokhov committed
65

66
67
68
69
-- A single FilePath argument
argPath :: FilePath -> Settings
argPath = return . Plain . unifyPath

Andrey Mokhov's avatar
Andrey Mokhov committed
70
71
-- A set of arguments (unordered)
args :: [String] -> Settings
72
args = msum . map arg
Andrey Mokhov's avatar
Andrey Mokhov committed
73

Andrey Mokhov's avatar
Andrey Mokhov committed
74
75
-- An (ordered) list of arguments
argsOrdered :: [String] -> Settings
76
argsOrdered = mproduct . map arg
Andrey Mokhov's avatar
Andrey Mokhov committed
77

78
79
argBuildPath :: Settings
argBuildPath = return BuildPath
Andrey Mokhov's avatar
Andrey Mokhov committed
80

81
82
argBuildDir :: Settings
argBuildDir = return BuildDir
Andrey Mokhov's avatar
Andrey Mokhov committed
83

84
85
86
87
88
argInput :: Settings
argInput = return Input

argOutput :: Settings
argOutput = return Output
Andrey Mokhov's avatar
Andrey Mokhov committed
89

Andrey Mokhov's avatar
Andrey Mokhov committed
90
argConfig :: String -> Settings
91
92
argConfig = return . Config

93
94
95
argConfigList :: String -> Settings
argConfigList = return . ConfigList

96
97
98
99
100
101
argStagedConfig :: String -> Settings
argStagedConfig key =
    msum $ map (\s -> stage s ? argConfig (stagedKey s)) [Stage0 ..]
  where
    stagedKey :: Stage -> String
    stagedKey stage = key ++ "-stage" ++ show stage
Andrey Mokhov's avatar
Andrey Mokhov committed
102

103
104
105
106
107
108
109
argStagedConfigList :: String -> Settings
argStagedConfigList key =
    msum $ map (\s -> stage s ? argConfigList (stagedKey s)) [Stage0 ..]
  where
    stagedKey :: Stage -> String
    stagedKey stage = key ++ "-stage" ++ show stage

Andrey Mokhov's avatar
Andrey Mokhov committed
110
argBuilderPath :: Builder -> Settings
111
argBuilderPath = return . BuilderPath
Andrey Mokhov's avatar
Andrey Mokhov committed
112

Andrey Mokhov's avatar
Andrey Mokhov committed
113
114
115
-- evaluates to the path to a given builder, taking current stage into account
argStagedBuilderPath :: (Stage -> Builder) -> Settings
argStagedBuilderPath f =
116
117
    msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
argWithBuilder :: Builder -> Settings
argWithBuilder builder =
    let key = case builder of
            Ar       -> "--with-ar="
            Ld       -> "--with-ld="
            Gcc _    -> "--with-gcc="
            Ghc _    -> "--with-ghc="
            Alex     -> "--with-alex="
            Happy    -> "--with-happy="
            GhcPkg _ -> "--with-ghc-pkg="
            HsColour -> "--with-hscolour="
    in
    argPrefix key (argBuilderPath builder)

argWithStagedBuilder :: (Stage -> Builder) -> Settings
argWithStagedBuilder f =
    msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]

136
137
138
139
140
-- Accessing key value pairs from package-data.mk files
argPackageKey :: Settings
argPackageKey = return $ PackageData "PACKAGE_KEY"

argPackageDeps :: Settings
141
argPackageDeps = return $ PackageDataList "DEPS"
Andrey Mokhov's avatar
Andrey Mokhov committed
142

143
argPackageDepKeys :: Settings
144
argPackageDepKeys = return $ PackageDataList "DEP_KEYS"
Andrey Mokhov's avatar
Andrey Mokhov committed
145

146
argSrcDirs :: Settings
147
argSrcDirs = return $ PackageDataList "HS_SRC_DIRS"
Andrey Mokhov's avatar
Andrey Mokhov committed
148

149
argIncludeDirs :: Settings
150
argIncludeDirs = return $ PackageDataList "INCLUDE_DIRS"
151
152

argDepIncludeDirs :: Settings
153
argDepIncludeDirs = return $ PackageDataList "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
Andrey Mokhov's avatar
Andrey Mokhov committed
154

Andrey Mokhov's avatar
Andrey Mokhov committed
155
argBootPkgConstraints :: Settings
156
157
argBootPkgConstraints = return BootPkgConstraints

158
-- Concatenate arguments: arg1 ++ arg2 ++ ...
159
160
161
argConcat :: Settings -> Settings
argConcat = return . Fold Concat

162
-- </>-concatenate arguments: arg1 </> arg2 </> ...
163
164
argConcatPath :: Settings -> Settings
argConcatPath = return . Fold ConcatPath
Andrey Mokhov's avatar
Andrey Mokhov committed
165

166
167
168
169
-- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
argConcatSpace :: Settings -> Settings
argConcatSpace = return . Fold ConcatSpace

170
171
172
-- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
argPairs :: String -> Settings -> Settings
argPairs prefix settings = settings >>= (arg prefix |>) . return
Andrey Mokhov's avatar
Andrey Mokhov committed
173

174
175
-- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
argPrefix :: String -> Settings -> Settings
176
argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
177
178

-- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
179
180
argPrefixPath :: String -> Settings -> Settings
argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
Andrey Mokhov's avatar
Andrey Mokhov committed
181

182
183
184
-- Partially evaluate expression using a truth-teller (compute a 'projection')
project :: (BuildVariable -> Maybe Bool) -> BuildExpression v
                                         -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
185
project _ Epsilon = Epsilon
186
project t (Vertex v) = Vertex v -- TODO: go deeper
Andrey Mokhov's avatar
Andrey Mokhov committed
187
188
189
project t (Overlay   l r) = Overlay   (project  t l) (project t r)
project t (Sequence  l r) = Sequence  (project  t l) (project t r)
project t (Condition l r) = Condition (evaluate t l) (project t r)
Andrey Mokhov's avatar
Andrey Mokhov committed
190

191
192
-- Partial evaluation of setting
setPackage :: Package -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
193
194
setPackage = project . matchPackage

195
setBuilder :: Builder -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
196
197
setBuilder = project . matchBuilder

198
199
setBuilderFamily :: (Stage -> Builder) -> BuildExpression v
                                       -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
200
setBuilderFamily = project . matchBuilderFamily
201

202
setStage :: Stage -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
203
204
setStage = project . matchStage

205
setWay :: Way -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
206
207
setWay = project . matchWay

208
setFile :: FilePath -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
209
210
setFile = project . matchFile

211
setConfig :: String -> String -> BuildExpression v -> BuildExpression v
Andrey Mokhov's avatar
Andrey Mokhov committed
212
setConfig key = project . matchConfig key
213

Andrey Mokhov's avatar
Andrey Mokhov committed
214
--type ArgsTeller = Args -> Maybe [String]
215

Andrey Mokhov's avatar
Andrey Mokhov committed
216
217
218
--fromPlain :: ArgsTeller
--fromPlain (Plain list) = Just list
--fromPlain _            = Nothing
219

Andrey Mokhov's avatar
Andrey Mokhov committed
220
221
222
223
--tellArgs :: ArgsTeller -> Args -> Args
--tellArgs t a = case t a of
--    Just list -> Plain list
--    Nothing   -> a