Finish Args datatype, propagate changes to related modules.
[hadrian.git] / src / Expression / Base.hs
1 {-# LANGUAGE FlexibleInstances #-}
2
3 module Expression.Base (
4 module Expression.Build,
5 module Expression.Predicate,
6 (?), (??), whenExists,
7 Args (..), -- hide?
8 Settings,
9 Packages,
10 FilePaths,
11 Ways,
12 project,
13 arg, args, argsOrdered, argBuildPath, argBuildDir,
14 argInput, argOutput,
15 argConfig, argStagedConfig, argBuilderPath, argStagedBuilderPath,
16 argWithBuilder, argWithStagedBuilder,
17 argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
18 argIncludeDirs, argDepIncludeDirs,
19 argConcat, argConcatPath, argConcatSpace, argPairs, argPrefix,
20 argBootPkgConstraints,
21 setPackage, setBuilder, setBuilderFamily, setStage, setWay,
22 setFile, setConfig
23 ) where
24
25 import Base hiding (arg, args, Args)
26 import Ways
27 import Package (Package)
28 import Oracles.Builder
29 import Expression.PG
30 import Expression.Predicate
31 import Expression.Build
32
33 -- Settings can be built out of the following primitive elements
34 data Args
35 = Plain String -- a plain old string argument: e.g., "-O2"
36 | BuildPath -- evaluates to build path: "libraries/base"
37 | BuildDir -- evaluates to build directory: "dist-install"
38 | Input -- evaluates to input file(s): "src.c"
39 | Output -- evaluates to output file(s): "src.o"
40 | Config String -- evaluates to the value of a given config key
41 | BuilderPath Builder -- evaluates to the path to a given builder
42 | PackageData String -- looks up value a given key in package-data.mk
43 | BootPkgConstraints -- evaluates to boot package constraints
44 | Fold Combine Settings -- fold settings using a given combine method
45
46 data Combine = Concat -- Concatenate: a ++ b
47 | ConcatPath -- </>-concatenate: a </> b
48 | ConcatSpace -- concatenate with a space: a ++ " " ++ b
49
50 type Ways = BuildExpression Way
51 type Settings = BuildExpression Args
52 type Packages = BuildExpression Package
53 type FilePaths = BuildExpression FilePath
54
55 -- A single argument
56 arg :: String -> Settings
57 arg = return . Plain
58
59 -- A set of arguments (unordered)
60 args :: [String] -> Settings
61 args = msum . map arg
62
63 -- An (ordered) list of arguments
64 argsOrdered :: [String] -> Settings
65 argsOrdered = mproduct . map arg
66
67 argBuildPath :: Settings
68 argBuildPath = return BuildPath
69
70 argBuildDir :: Settings
71 argBuildDir = return BuildDir
72
73 argInput :: Settings
74 argInput = return Input
75
76 argOutput :: Settings
77 argOutput = return Output
78
79 argConfig :: String -> Settings
80 argConfig = return . Config
81
82 argStagedConfig :: String -> Settings
83 argStagedConfig key =
84 msum $ map (\s -> stage s ? argConfig (stagedKey s)) [Stage0 ..]
85 where
86 stagedKey :: Stage -> String
87 stagedKey stage = key ++ "-stage" ++ show stage
88
89 argBuilderPath :: Builder -> Settings
90 argBuilderPath = return . BuilderPath
91
92 -- evaluates to the path to a given builder, taking current stage into account
93 argStagedBuilderPath :: (Stage -> Builder) -> Settings
94 argStagedBuilderPath f =
95 msum $ map (\s -> stage s ? argBuilderPath (f s)) [Stage0 ..]
96
97 argWithBuilder :: Builder -> Settings
98 argWithBuilder builder =
99 let key = case builder of
100 Ar -> "--with-ar="
101 Ld -> "--with-ld="
102 Gcc _ -> "--with-gcc="
103 Ghc _ -> "--with-ghc="
104 Alex -> "--with-alex="
105 Happy -> "--with-happy="
106 GhcPkg _ -> "--with-ghc-pkg="
107 HsColour -> "--with-hscolour="
108 in
109 argPrefix key (argBuilderPath builder)
110
111 argWithStagedBuilder :: (Stage -> Builder) -> Settings
112 argWithStagedBuilder f =
113 msum $ map (\s -> stage s ? argWithBuilder (f s)) [Stage0 ..]
114
115
116 -- Accessing key value pairs from package-data.mk files
117 argPackageKey :: Settings
118 argPackageKey = return $ PackageData "PACKAGE_KEY"
119
120 argPackageDeps :: Settings
121 argPackageDeps = return $ PackageData "DEPS"
122
123 argPackageDepKeys :: Settings
124 argPackageDepKeys = return $ PackageData "DEP_KEYS"
125
126 argSrcDirs :: Settings
127 argSrcDirs = return $ PackageData "HS_SRC_DIRS"
128
129 argIncludeDirs :: Settings
130 argIncludeDirs = return $ PackageData "INCLUDE_DIRS"
131
132 argDepIncludeDirs :: Settings
133 argDepIncludeDirs = return $ PackageData "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
134
135 argBootPkgConstraints :: Settings
136 argBootPkgConstraints = return BootPkgConstraints
137
138 -- Concatenate arguments: arg1 ++ arg2 ++ ...
139 argConcat :: Settings -> Settings
140 argConcat = return . Fold Concat
141
142 -- </>-concatenate arguments: arg1 </> arg2 </> ...
143 argConcatPath :: Settings -> Settings
144 argConcatPath = return . Fold ConcatPath
145
146 -- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
147 argConcatSpace :: Settings -> Settings
148 argConcatSpace = return . Fold ConcatSpace
149
150 -- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
151 argPairs :: String -> Settings -> Settings
152 argPairs prefix settings = settings >>= (arg prefix |>) . return
153
154 -- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
155 argPrefix :: String -> Settings -> Settings
156 argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
157
158 -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
159 argPaths :: String -> Settings -> Settings
160 argPaths prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
161
162 -- Partially evaluate Settings using a truth-teller (compute a 'projection')
163 project :: (BuildVariable -> Maybe Bool) -> Settings -> Settings
164 project _ Epsilon = Epsilon
165 project t (Vertex v) = Vertex v -- TODO: go deeper
166 project t (Overlay l r) = Overlay (project t l) (project t r)
167 project t (Sequence l r) = Sequence (project t l) (project t r)
168 project t (Condition l r) = Condition (evaluate t l) (project t r)
169
170 -- Partial evaluation of settings
171
172 setPackage :: Package -> Settings -> Settings
173 setPackage = project . matchPackage
174
175 setBuilder :: Builder -> Settings -> Settings
176 setBuilder = project . matchBuilder
177
178 setBuilderFamily :: (Stage -> Builder) -> Settings -> Settings
179 setBuilderFamily = project . matchBuilderFamily
180
181 setStage :: Stage -> Settings -> Settings
182 setStage = project . matchStage
183
184 setWay :: Way -> Settings -> Settings
185 setWay = project . matchWay
186
187 setFile :: FilePath -> Settings -> Settings
188 setFile = project . matchFile
189
190 setConfig :: String -> String -> Settings -> Settings
191 setConfig key = project . matchConfig key
192
193 --type ArgsTeller = Args -> Maybe [String]
194
195 --fromPlain :: ArgsTeller
196 --fromPlain (Plain list) = Just list
197 --fromPlain _ = Nothing
198
199 --tellArgs :: ArgsTeller -> Args -> Args
200 --tellArgs t a = case t a of
201 -- Just list -> Plain list
202 -- Nothing -> a