adamc@25
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@25
|
2 * All rights reserved.
|
adamc@25
|
3 *
|
adamc@25
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@25
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@25
|
6 *
|
adamc@25
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@25
|
8 * this list of conditions and the following disclaimer.
|
adamc@25
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@25
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@25
|
11 * and/or other materials provided with the distribution.
|
adamc@25
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@25
|
13 * derived from this software without specific prior written permission.
|
adamc@25
|
14 *
|
adamc@25
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@25
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@25
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@25
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@25
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@25
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@25
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@25
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@25
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@25
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@25
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@25
|
26 *)
|
adamc@25
|
27
|
adamc@244
|
28 (* Pretty-printing monomorphic Ur/Web *)
|
adamc@25
|
29
|
adamc@25
|
30 structure MonoPrint :> MONO_PRINT = struct
|
adamc@25
|
31
|
adamc@25
|
32 open Print.PD
|
adamc@25
|
33 open Print
|
adamc@25
|
34
|
adamc@25
|
35 open Mono
|
adamc@25
|
36
|
adamc@25
|
37 structure E = MonoEnv
|
adamc@25
|
38
|
adamc@25
|
39 val debug = ref false
|
adamc@25
|
40
|
adamc@252
|
41 val dummyt = (TRecord [], ErrorMsg.dummySpan)
|
adamc@252
|
42
|
adamc@25
|
43 fun p_typ' par env (t, _) =
|
adamc@25
|
44 case t of
|
adamc@25
|
45 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
|
adamc@25
|
46 space,
|
adamc@25
|
47 string "->",
|
adamc@25
|
48 space,
|
adamc@25
|
49 p_typ env t2])
|
adamc@25
|
50 | TRecord xcs => box [string "{",
|
adamc@25
|
51 p_list (fn (x, t) =>
|
adamc@25
|
52 box [string x,
|
adamc@25
|
53 space,
|
adamc@25
|
54 string ":",
|
adamc@25
|
55 space,
|
adamc@25
|
56 p_typ env t]) xcs,
|
adamc@25
|
57 string "}"]
|
adamc@196
|
58 | TDatatype (n, _) =>
|
adamc@178
|
59 ((if !debug then
|
adamc@178
|
60 string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
61 else
|
adamc@178
|
62 string (#1 (E.lookupDatatype env n)))
|
adamc@178
|
63 handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
|
adamc@51
|
64 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@292
|
65 | TOption t => box [string "option(",
|
adamc@292
|
66 p_typ env t,
|
adamc@292
|
67 string ")"]
|
adamc@25
|
68
|
adamc@25
|
69 and p_typ env = p_typ' false env
|
adamc@25
|
70
|
adamc@109
|
71 fun p_enamed env n =
|
adamc@178
|
72 (if !debug then
|
adamc@178
|
73 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
74 else
|
adamc@178
|
75 string (#1 (E.lookupENamed env n)))
|
adamc@178
|
76 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
|
adamc@178
|
77
|
adamc@178
|
78 fun p_con_named env n =
|
adamc@178
|
79 (if !debug then
|
adamc@178
|
80 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
81 else
|
adamc@178
|
82 string (#1 (E.lookupConstructor env n)))
|
adamc@178
|
83 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
|
adamc@178
|
84
|
adamc@178
|
85 fun p_patCon env pc =
|
adamc@178
|
86 case pc of
|
adamc@178
|
87 PConVar n => p_con_named env n
|
adamc@186
|
88 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
|
adamc@185
|
89 string m,
|
adamc@185
|
90 string ".",
|
adamc@185
|
91 string con,
|
adamc@185
|
92 string ")"]
|
adamc@178
|
93
|
adamc@178
|
94 fun p_pat' par env (p, _) =
|
adamc@178
|
95 case p of
|
adamc@178
|
96 PWild => string "_"
|
adamc@182
|
97 | PVar (s, _) => string s
|
adamc@178
|
98 | PPrim p => Prim.p_t p
|
adamc@188
|
99 | PCon (_, n, NONE) => p_patCon env n
|
adamc@188
|
100 | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
|
adamc@288
|
101 space,
|
adamc@288
|
102 p_pat' true env p])
|
adamc@178
|
103 | PRecord xps =>
|
adamc@178
|
104 box [string "{",
|
adamc@182
|
105 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
|
adamc@178
|
106 box [string x,
|
adamc@178
|
107 space,
|
adamc@178
|
108 string "=",
|
adamc@178
|
109 space,
|
adamc@178
|
110 p_pat env p]) xps,
|
adamc@178
|
111 string "}"]
|
adamc@288
|
112 | PNone _ => string "None"
|
adamc@288
|
113 | PSome (_, p) => box [string "Some",
|
adamc@288
|
114 space,
|
adamc@288
|
115 p_pat' true env p]
|
adamc@178
|
116
|
adamc@178
|
117 and p_pat x = p_pat' false x
|
adamc@109
|
118
|
adamc@25
|
119 fun p_exp' par env (e, _) =
|
adamc@25
|
120 case e of
|
adamc@25
|
121 EPrim p => Prim.p_t p
|
adamc@25
|
122 | ERel n =>
|
adamc@178
|
123 ((if !debug then
|
adamc@178
|
124 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
|
adamc@178
|
125 else
|
adamc@178
|
126 string (#1 (E.lookupERel env n)))
|
adamc@178
|
127 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
|
adamc@109
|
128 | ENamed n => p_enamed env n
|
adamc@188
|
129 | ECon (_, pc, NONE) => p_patCon env pc
|
adamc@188
|
130 | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
|
adamc@188
|
131 space,
|
adamc@188
|
132 p_exp' true env e])
|
adamc@297
|
133 | ENone _ => string "None"
|
adamc@290
|
134 | ESome (_, e) => parenIf par (box [string "Some",
|
adamc@290
|
135 space,
|
adamc@290
|
136 p_exp' true env e])
|
adamc@109
|
137
|
adamc@51
|
138 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@51
|
139 | EFfiApp (m, x, es) => box [string "FFI(",
|
adamc@51
|
140 string m,
|
adamc@51
|
141 string ".",
|
adamc@51
|
142 string x,
|
adamc@51
|
143 string "(",
|
adamc@51
|
144 p_list (p_exp env) es,
|
adamc@51
|
145 string "))"]
|
adamc@25
|
146 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
|
adamc@25
|
147 space,
|
adamc@25
|
148 p_exp' true env e2])
|
adamc@252
|
149 | EAbs (x, t, _, e) => parenIf true (box [string "fn",
|
adamc@252
|
150 space,
|
adamc@252
|
151 string x,
|
adamc@252
|
152 space,
|
adamc@252
|
153 string ":",
|
adamc@252
|
154 space,
|
adamc@252
|
155 p_typ env t,
|
adamc@252
|
156 space,
|
adamc@252
|
157 string "=>",
|
adamc@252
|
158 space,
|
adamc@252
|
159 p_exp (E.pushERel env x t NONE) e])
|
adamc@25
|
160
|
adamc@387
|
161 | EUnop (s, e) => parenIf true (box [string s,
|
adamc@387
|
162 space,
|
adamc@387
|
163 p_exp' true env e])
|
adamc@387
|
164 | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1,
|
adamc@387
|
165 space,
|
adamc@387
|
166 string s,
|
adamc@387
|
167 space,
|
adamc@387
|
168 p_exp' true env e2])
|
adamc@387
|
169
|
adamc@25
|
170 | ERecord xes => box [string "{",
|
adamc@29
|
171 p_list (fn (x, e, _) =>
|
adamc@25
|
172 box [string x,
|
adamc@25
|
173 space,
|
adamc@25
|
174 string "=",
|
adamc@25
|
175 space,
|
adamc@25
|
176 p_exp env e]) xes,
|
adamc@25
|
177 string "}"]
|
adamc@25
|
178 | EField (e, x) =>
|
adamc@25
|
179 box [p_exp' true env e,
|
adamc@25
|
180 string ".",
|
adamc@25
|
181 string x]
|
adamc@25
|
182
|
adamc@252
|
183 | ECase (e, pes, _) => parenIf true (box [string "case",
|
adamc@252
|
184 space,
|
adamc@252
|
185 p_exp env e,
|
adamc@252
|
186 space,
|
adamc@252
|
187 string "of",
|
adamc@252
|
188 space,
|
adamc@252
|
189 p_list_sep (box [space, string "|", space])
|
adamc@252
|
190 (fn (p, e) => box [p_pat env p,
|
adamc@252
|
191 space,
|
adamc@252
|
192 string "=>",
|
adamc@252
|
193 space,
|
adamc@252
|
194 p_exp (E.patBinds env p) e]) pes])
|
adamc@94
|
195
|
adamc@283
|
196 | EError (e, t) => box [string "(error",
|
adamc@283
|
197 space,
|
adamc@283
|
198 p_exp env e,
|
adamc@283
|
199 space,
|
adamc@283
|
200 string ":",
|
adamc@283
|
201 space,
|
adamc@283
|
202 p_typ env t,
|
adamc@283
|
203 string ")"]
|
adamc@283
|
204
|
adamc@331
|
205 | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1,
|
adamc@331
|
206 space,
|
adamc@331
|
207 string "^",
|
adamc@331
|
208 space,
|
adamc@331
|
209 p_exp env e2])
|
adamc@94
|
210
|
adamc@102
|
211 | EWrite e => box [string "write(",
|
adamc@102
|
212 p_exp env e,
|
adamc@102
|
213 string ")"]
|
adamc@102
|
214
|
adamc@106
|
215 | ESeq (e1, e2) => box [p_exp env e1,
|
adamc@106
|
216 string ";",
|
adamc@106
|
217 space,
|
adamc@106
|
218 p_exp env e2]
|
adamc@252
|
219 | ELet (x, t, e1, e2) => box [string "(let",
|
adamc@251
|
220 space,
|
adamc@251
|
221 string x,
|
adamc@251
|
222 space,
|
adamc@251
|
223 string ":",
|
adamc@251
|
224 space,
|
adamc@251
|
225 p_typ env t,
|
adamc@251
|
226 space,
|
adamc@251
|
227 string "=",
|
adamc@251
|
228 space,
|
adamc@252
|
229 string "(",
|
adamc@251
|
230 p_exp env e1,
|
adamc@252
|
231 string ")",
|
adamc@251
|
232 space,
|
adamc@251
|
233 string "in",
|
adamc@251
|
234 space,
|
adamc@252
|
235 string "(",
|
adamc@252
|
236 p_exp (E.pushERel env x t NONE) e2,
|
adamc@252
|
237 string "))"]
|
adamc@106
|
238
|
adamc@111
|
239 | EClosure (n, es) => box [string "CLOSURE(",
|
adamc@111
|
240 p_enamed env n,
|
adamc@111
|
241 p_list_sep (string "") (fn e => box [string ", ",
|
adamc@111
|
242 p_exp env e]) es,
|
adamc@111
|
243 string ")"]
|
adamc@111
|
244
|
adamc@252
|
245 | EQuery {exps, tables, state, query, body, initial} =>
|
adamc@252
|
246 box [string "query[",
|
adamc@252
|
247 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
|
adamc@252
|
248 string "] [",
|
adamc@252
|
249 p_list (fn (x, xts) => box [string x,
|
adamc@252
|
250 space,
|
adamc@252
|
251 string ":",
|
adamc@252
|
252 space,
|
adamc@252
|
253 string "{",
|
adamc@252
|
254 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts,
|
adamc@252
|
255 string "}"]) tables,
|
adamc@252
|
256 string "] [",
|
adamc@252
|
257 p_typ env state,
|
adamc@252
|
258 string "]",
|
adamc@252
|
259 space,
|
adamc@252
|
260 p_exp env query,
|
adamc@252
|
261 space,
|
adamc@252
|
262 string "initial",
|
adamc@252
|
263 space,
|
adamc@252
|
264 p_exp env initial,
|
adamc@252
|
265 space,
|
adamc@252
|
266 string "in",
|
adamc@252
|
267 space,
|
adamc@252
|
268 p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
|
adamc@307
|
269 | EDml e => box [string "dml(",
|
adamc@307
|
270 p_exp env e,
|
adamc@307
|
271 string ")"]
|
adamc@338
|
272 | ENextval e => box [string "nextval(",
|
adamc@338
|
273 p_exp env e,
|
adamc@338
|
274 string ")"]
|
adamc@252
|
275
|
adamc@25
|
276 and p_exp env = p_exp' false env
|
adamc@25
|
277
|
adamc@126
|
278 fun p_vali env (x, n, t, e, s) =
|
adamc@126
|
279 let
|
adamc@126
|
280 val xp = if !debug then
|
adamc@126
|
281 box [string x,
|
adamc@126
|
282 string "__",
|
adamc@126
|
283 string (Int.toString n)]
|
adamc@126
|
284 else
|
adamc@126
|
285 string x
|
adamc@126
|
286 in
|
adamc@126
|
287 box [xp,
|
adamc@126
|
288 space,
|
adamc@126
|
289 string "as",
|
adamc@126
|
290 space,
|
adamc@126
|
291 string s,
|
adamc@126
|
292 space,
|
adamc@126
|
293 string ":",
|
adamc@126
|
294 space,
|
adamc@126
|
295 p_typ env t,
|
adamc@126
|
296 space,
|
adamc@126
|
297 string "=",
|
adamc@126
|
298 space,
|
adamc@126
|
299 p_exp env e]
|
adamc@126
|
300 end
|
adamc@126
|
301
|
adamc@164
|
302 fun p_datatype env (x, n, cons) =
|
adamc@164
|
303 let
|
adamc@168
|
304 val env = E.pushDatatype env x n cons
|
adamc@164
|
305 in
|
adamc@164
|
306 box [string "datatype",
|
adamc@164
|
307 space,
|
adamc@164
|
308 string x,
|
adamc@164
|
309 space,
|
adamc@164
|
310 string "=",
|
adamc@164
|
311 space,
|
adamc@164
|
312 p_list_sep (box [space, string "|", space])
|
adamc@164
|
313 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
314 else string x
|
adamc@164
|
315 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
316 else string x, space, string "of", space, p_typ env t])
|
adamc@164
|
317 cons]
|
adamc@164
|
318 end
|
adamc@164
|
319
|
adamc@126
|
320 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@25
|
321 case d of
|
adamc@164
|
322 DDatatype x => p_datatype env x
|
adamc@164
|
323 | DVal vi => box [string "val",
|
adamc@126
|
324 space,
|
adamc@126
|
325 p_vali env vi]
|
adamc@126
|
326 | DValRec vis =>
|
adamc@25
|
327 let
|
adamc@126
|
328 val env = E.declBinds env dAll
|
adamc@25
|
329 in
|
adamc@25
|
330 box [string "val",
|
adamc@25
|
331 space,
|
adamc@126
|
332 string "rec",
|
adamc@25
|
333 space,
|
adamc@126
|
334 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
|
adamc@25
|
335 end
|
adamc@109
|
336
|
adamc@144
|
337 | DExport (ek, s, n, ts) => box [string "export",
|
adamc@144
|
338 space,
|
adamc@144
|
339 CorePrint.p_export_kind ek,
|
adamc@144
|
340 space,
|
adamc@144
|
341 p_enamed env n,
|
adamc@144
|
342 space,
|
adamc@144
|
343 string "as",
|
adamc@144
|
344 space,
|
adamc@144
|
345 string s,
|
adamc@144
|
346 p_list_sep (string "") (fn t => box [space,
|
adamc@144
|
347 string "(",
|
adamc@144
|
348 p_typ env t,
|
adamc@144
|
349 string ")"]) ts]
|
adamc@271
|
350
|
adamc@273
|
351 | DTable (s, xts) => box [string "(* SQL table ",
|
adamc@273
|
352 string s,
|
adamc@273
|
353 space,
|
adamc@273
|
354 string ":",
|
adamc@273
|
355 space,
|
adamc@273
|
356 p_list (fn (x, t) => box [string x,
|
adamc@273
|
357 space,
|
adamc@273
|
358 string ":",
|
adamc@273
|
359 space,
|
adamc@273
|
360 p_typ env t]) xts,
|
adamc@273
|
361 space,
|
adamc@273
|
362 string "*)"]
|
adamc@338
|
363 | DSequence s => box [string "(* SQL sequence ",
|
adamc@338
|
364 string s,
|
adamc@338
|
365 string "*)"]
|
adamc@271
|
366 | DDatabase s => box [string "database",
|
adamc@271
|
367 space,
|
adamc@271
|
368 string s]
|
adamc@100
|
369
|
adamc@25
|
370 fun p_file env file =
|
adamc@25
|
371 let
|
adamc@31
|
372 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@31
|
373 (p_decl env d,
|
adamc@31
|
374 E.declBinds env d))
|
adamc@25
|
375 env file
|
adamc@25
|
376 in
|
adamc@25
|
377 p_list_sep newline (fn x => x) pds
|
adamc@25
|
378 end
|
adamc@25
|
379
|
adamc@25
|
380 end
|