Base.hs 6.47 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
7
    module Expression.Build,
    module Expression.Predicate,
    (?), (??), whenExists,
    Args (..), -- hide?
Andrey Mokhov's avatar
Andrey Mokhov committed
8
    Settings,
9
10
    Packages,
    FilePaths,
Andrey Mokhov's avatar
Andrey Mokhov committed
11
    Ways,
12
13
14
    project,
    arg, args, argsOrdered, argBuildPath, argBuildDir,
    argInput, argOutput,
15
16
    argConfig, argStagedConfig, argBuilderPath, argStagedBuilderPath,
    argWithBuilder, argWithStagedBuilder,
17
18
    argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
    argIncludeDirs, argDepIncludeDirs,
19
    argConcat, argConcatPath, argConcatSpace, argPairs, argPrefix,
20
    argBootPkgConstraints,
Andrey Mokhov's avatar
Andrey Mokhov committed
21
22
    setPackage, setBuilder, setBuilderFamily, setStage, setWay,
    setFile, setConfig
Andrey Mokhov's avatar
Andrey Mokhov committed
23
24
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
25
import Base hiding (arg, args, Args)
Andrey Mokhov's avatar
Andrey Mokhov committed
26
import Ways
27
import Package (Package)
Andrey Mokhov's avatar
Andrey Mokhov committed
28
29
30
import Oracles.Builder
import Expression.PG
import Expression.Predicate
Andrey Mokhov's avatar
Andrey Mokhov committed
31
import Expression.Build
32

Andrey Mokhov's avatar
Andrey Mokhov committed
33
34
-- Settings can be built out of the following primitive elements
data Args
35
36
37
38
39
40
41
42
43
44
45
    = 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
    | BuilderPath Builder    -- evaluates to the path to a given builder
    | PackageData String     -- looks up value a given key in package-data.mk
    | BootPkgConstraints     -- evaluates to boot package constraints
    | Fold Combine Settings  -- fold settings using a given combine method

46
47
48
data Combine = Concat        -- Concatenate: a ++ b
             | ConcatPath    -- </>-concatenate: a </> b
             | ConcatSpace   -- concatenate with a space: a ++ " " ++ b
49
50
51
52
53

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

Andrey Mokhov's avatar
Andrey Mokhov committed
55
56
-- A single argument
arg :: String -> Settings
57
arg = return . Plain
Andrey Mokhov's avatar
Andrey Mokhov committed
58

Andrey Mokhov's avatar
Andrey Mokhov committed
59
60
-- A set of arguments (unordered)
args :: [String] -> Settings
61
args = msum . map arg
Andrey Mokhov's avatar
Andrey Mokhov committed
62

Andrey Mokhov's avatar
Andrey Mokhov committed
63
64
-- An (ordered) list of arguments
argsOrdered :: [String] -> Settings
65
argsOrdered = mproduct . map arg
Andrey Mokhov's avatar
Andrey Mokhov committed
66

67
68
argBuildPath :: Settings
argBuildPath = return BuildPath
Andrey Mokhov's avatar
Andrey Mokhov committed
69

70
71
argBuildDir :: Settings
argBuildDir = return BuildDir
Andrey Mokhov's avatar
Andrey Mokhov committed
72

73
74
75
76
77
argInput :: Settings
argInput = return Input

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

Andrey Mokhov's avatar
Andrey Mokhov committed
79
argConfig :: String -> Settings
80
81
argConfig = return . Config

82
83
84
85
86
87
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
88

Andrey Mokhov's avatar
Andrey Mokhov committed
89
argBuilderPath :: Builder -> Settings
90
argBuilderPath = return . BuilderPath
Andrey Mokhov's avatar
Andrey Mokhov committed
91

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

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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 ..]


116
117
118
119
120
121
-- Accessing key value pairs from package-data.mk files
argPackageKey :: Settings
argPackageKey = return $ PackageData "PACKAGE_KEY"

argPackageDeps :: Settings
argPackageDeps = return $ PackageData "DEPS"
Andrey Mokhov's avatar
Andrey Mokhov committed
122

123
124
argPackageDepKeys :: Settings
argPackageDepKeys = return $ PackageData "DEP_KEYS"
Andrey Mokhov's avatar
Andrey Mokhov committed
125

126
127
argSrcDirs :: Settings
argSrcDirs = return $ PackageData "HS_SRC_DIRS"
Andrey Mokhov's avatar
Andrey Mokhov committed
128

129
130
131
132
133
argIncludeDirs :: Settings
argIncludeDirs = return $ PackageData "INCLUDE_DIRS"

argDepIncludeDirs :: Settings
argDepIncludeDirs = return $ PackageData "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
Andrey Mokhov's avatar
Andrey Mokhov committed
134

Andrey Mokhov's avatar
Andrey Mokhov committed
135
argBootPkgConstraints :: Settings
136
137
argBootPkgConstraints = return BootPkgConstraints

138
-- Concatenate arguments: arg1 ++ arg2 ++ ...
139
140
141
argConcat :: Settings -> Settings
argConcat = return . Fold Concat

142
-- </>-concatenate arguments: arg1 </> arg2 </> ...
143
144
argConcatPath :: Settings -> Settings
argConcatPath = return . Fold ConcatPath
Andrey Mokhov's avatar
Andrey Mokhov committed
145

146
147
148
149
-- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
argConcatSpace :: Settings -> Settings
argConcatSpace = return . Fold ConcatSpace

150
151
152
-- 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
153

154
155
-- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
argPrefix :: String -> Settings -> Settings
156
argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
157
158
159

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

Andrey Mokhov's avatar
Andrey Mokhov committed
162
163
164
-- Partially evaluate Settings using a truth-teller (compute a 'projection')
project :: (BuildVariable -> Maybe Bool) -> Settings -> Settings
project _ Epsilon = Epsilon
165
project t (Vertex v) = Vertex v -- TODO: go deeper
Andrey Mokhov's avatar
Andrey Mokhov committed
166
167
168
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
169
170
171
172
173
174
175
176
177

-- Partial evaluation of settings

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

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

178
setBuilderFamily :: (Stage -> Builder) -> Settings -> Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
179
setBuilderFamily = project . matchBuilderFamily
180

Andrey Mokhov's avatar
Andrey Mokhov committed
181
182
183
184
185
186
187
188
189
setStage :: Stage -> Settings -> Settings
setStage = project . matchStage

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
190
191
setConfig :: String -> String -> Settings -> Settings
setConfig key = project . matchConfig key
192

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

Andrey Mokhov's avatar
Andrey Mokhov committed
195
196
197
--fromPlain :: ArgsTeller
--fromPlain (Plain list) = Just list
--fromPlain _            = Nothing
198

Andrey Mokhov's avatar
Andrey Mokhov committed
199
200
201
202
--tellArgs :: ArgsTeller -> Args -> Args
--tellArgs t a = case t a of
--    Just list -> Plain list
--    Nothing   -> a