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@25
|
161 | ERecord xes => box [string "{",
|
adamc@29
|
162 p_list (fn (x, e, _) =>
|
adamc@25
|
163 box [string x,
|
adamc@25
|
164 space,
|
adamc@25
|
165 string "=",
|
adamc@25
|
166 space,
|
adamc@25
|
167 p_exp env e]) xes,
|
adamc@25
|
168 string "}"]
|
adamc@25
|
169 | EField (e, x) =>
|
adamc@25
|
170 box [p_exp' true env e,
|
adamc@25
|
171 string ".",
|
adamc@25
|
172 string x]
|
adamc@25
|
173
|
adamc@252
|
174 | ECase (e, pes, _) => parenIf true (box [string "case",
|
adamc@252
|
175 space,
|
adamc@252
|
176 p_exp env e,
|
adamc@252
|
177 space,
|
adamc@252
|
178 string "of",
|
adamc@252
|
179 space,
|
adamc@252
|
180 p_list_sep (box [space, string "|", space])
|
adamc@252
|
181 (fn (p, e) => box [p_pat env p,
|
adamc@252
|
182 space,
|
adamc@252
|
183 string "=>",
|
adamc@252
|
184 space,
|
adamc@252
|
185 p_exp (E.patBinds env p) e]) pes])
|
adamc@94
|
186
|
adamc@283
|
187 | EError (e, t) => box [string "(error",
|
adamc@283
|
188 space,
|
adamc@283
|
189 p_exp env e,
|
adamc@283
|
190 space,
|
adamc@283
|
191 string ":",
|
adamc@283
|
192 space,
|
adamc@283
|
193 p_typ env t,
|
adamc@283
|
194 string ")"]
|
adamc@283
|
195
|
adamc@331
|
196 | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1,
|
adamc@331
|
197 space,
|
adamc@331
|
198 string "^",
|
adamc@331
|
199 space,
|
adamc@331
|
200 p_exp env e2])
|
adamc@94
|
201
|
adamc@102
|
202 | EWrite e => box [string "write(",
|
adamc@102
|
203 p_exp env e,
|
adamc@102
|
204 string ")"]
|
adamc@102
|
205
|
adamc@106
|
206 | ESeq (e1, e2) => box [p_exp env e1,
|
adamc@106
|
207 string ";",
|
adamc@106
|
208 space,
|
adamc@106
|
209 p_exp env e2]
|
adamc@252
|
210 | ELet (x, t, e1, e2) => box [string "(let",
|
adamc@251
|
211 space,
|
adamc@251
|
212 string x,
|
adamc@251
|
213 space,
|
adamc@251
|
214 string ":",
|
adamc@251
|
215 space,
|
adamc@251
|
216 p_typ env t,
|
adamc@251
|
217 space,
|
adamc@251
|
218 string "=",
|
adamc@251
|
219 space,
|
adamc@252
|
220 string "(",
|
adamc@251
|
221 p_exp env e1,
|
adamc@252
|
222 string ")",
|
adamc@251
|
223 space,
|
adamc@251
|
224 string "in",
|
adamc@251
|
225 space,
|
adamc@252
|
226 string "(",
|
adamc@252
|
227 p_exp (E.pushERel env x t NONE) e2,
|
adamc@252
|
228 string "))"]
|
adamc@106
|
229
|
adamc@111
|
230 | EClosure (n, es) => box [string "CLOSURE(",
|
adamc@111
|
231 p_enamed env n,
|
adamc@111
|
232 p_list_sep (string "") (fn e => box [string ", ",
|
adamc@111
|
233 p_exp env e]) es,
|
adamc@111
|
234 string ")"]
|
adamc@111
|
235
|
adamc@252
|
236 | EQuery {exps, tables, state, query, body, initial} =>
|
adamc@252
|
237 box [string "query[",
|
adamc@252
|
238 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
|
adamc@252
|
239 string "] [",
|
adamc@252
|
240 p_list (fn (x, xts) => box [string x,
|
adamc@252
|
241 space,
|
adamc@252
|
242 string ":",
|
adamc@252
|
243 space,
|
adamc@252
|
244 string "{",
|
adamc@252
|
245 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts,
|
adamc@252
|
246 string "}"]) tables,
|
adamc@252
|
247 string "] [",
|
adamc@252
|
248 p_typ env state,
|
adamc@252
|
249 string "]",
|
adamc@252
|
250 space,
|
adamc@252
|
251 p_exp env query,
|
adamc@252
|
252 space,
|
adamc@252
|
253 string "initial",
|
adamc@252
|
254 space,
|
adamc@252
|
255 p_exp env initial,
|
adamc@252
|
256 space,
|
adamc@252
|
257 string "in",
|
adamc@252
|
258 space,
|
adamc@252
|
259 p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
|
adamc@307
|
260 | EDml e => box [string "dml(",
|
adamc@307
|
261 p_exp env e,
|
adamc@307
|
262 string ")"]
|
adamc@252
|
263
|
adamc@25
|
264 and p_exp env = p_exp' false env
|
adamc@25
|
265
|
adamc@126
|
266 fun p_vali env (x, n, t, e, s) =
|
adamc@126
|
267 let
|
adamc@126
|
268 val xp = if !debug then
|
adamc@126
|
269 box [string x,
|
adamc@126
|
270 string "__",
|
adamc@126
|
271 string (Int.toString n)]
|
adamc@126
|
272 else
|
adamc@126
|
273 string x
|
adamc@126
|
274 in
|
adamc@126
|
275 box [xp,
|
adamc@126
|
276 space,
|
adamc@126
|
277 string "as",
|
adamc@126
|
278 space,
|
adamc@126
|
279 string s,
|
adamc@126
|
280 space,
|
adamc@126
|
281 string ":",
|
adamc@126
|
282 space,
|
adamc@126
|
283 p_typ env t,
|
adamc@126
|
284 space,
|
adamc@126
|
285 string "=",
|
adamc@126
|
286 space,
|
adamc@126
|
287 p_exp env e]
|
adamc@126
|
288 end
|
adamc@126
|
289
|
adamc@164
|
290 fun p_datatype env (x, n, cons) =
|
adamc@164
|
291 let
|
adamc@168
|
292 val env = E.pushDatatype env x n cons
|
adamc@164
|
293 in
|
adamc@164
|
294 box [string "datatype",
|
adamc@164
|
295 space,
|
adamc@164
|
296 string x,
|
adamc@164
|
297 space,
|
adamc@164
|
298 string "=",
|
adamc@164
|
299 space,
|
adamc@164
|
300 p_list_sep (box [space, string "|", space])
|
adamc@164
|
301 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
302 else string x
|
adamc@164
|
303 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
304 else string x, space, string "of", space, p_typ env t])
|
adamc@164
|
305 cons]
|
adamc@164
|
306 end
|
adamc@164
|
307
|
adamc@126
|
308 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@25
|
309 case d of
|
adamc@164
|
310 DDatatype x => p_datatype env x
|
adamc@164
|
311 | DVal vi => box [string "val",
|
adamc@126
|
312 space,
|
adamc@126
|
313 p_vali env vi]
|
adamc@126
|
314 | DValRec vis =>
|
adamc@25
|
315 let
|
adamc@126
|
316 val env = E.declBinds env dAll
|
adamc@25
|
317 in
|
adamc@25
|
318 box [string "val",
|
adamc@25
|
319 space,
|
adamc@126
|
320 string "rec",
|
adamc@25
|
321 space,
|
adamc@126
|
322 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
|
adamc@25
|
323 end
|
adamc@109
|
324
|
adamc@144
|
325 | DExport (ek, s, n, ts) => box [string "export",
|
adamc@144
|
326 space,
|
adamc@144
|
327 CorePrint.p_export_kind ek,
|
adamc@144
|
328 space,
|
adamc@144
|
329 p_enamed env n,
|
adamc@144
|
330 space,
|
adamc@144
|
331 string "as",
|
adamc@144
|
332 space,
|
adamc@144
|
333 string s,
|
adamc@144
|
334 p_list_sep (string "") (fn t => box [space,
|
adamc@144
|
335 string "(",
|
adamc@144
|
336 p_typ env t,
|
adamc@144
|
337 string ")"]) ts]
|
adamc@271
|
338
|
adamc@273
|
339 | DTable (s, xts) => box [string "(* SQL table ",
|
adamc@273
|
340 string s,
|
adamc@273
|
341 space,
|
adamc@273
|
342 string ":",
|
adamc@273
|
343 space,
|
adamc@273
|
344 p_list (fn (x, t) => box [string x,
|
adamc@273
|
345 space,
|
adamc@273
|
346 string ":",
|
adamc@273
|
347 space,
|
adamc@273
|
348 p_typ env t]) xts,
|
adamc@273
|
349 space,
|
adamc@273
|
350 string "*)"]
|
adamc@271
|
351 | DDatabase s => box [string "database",
|
adamc@271
|
352 space,
|
adamc@271
|
353 string s]
|
adamc@100
|
354
|
adamc@25
|
355 fun p_file env file =
|
adamc@25
|
356 let
|
adamc@31
|
357 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@31
|
358 (p_decl env d,
|
adamc@31
|
359 E.declBinds env d))
|
adamc@25
|
360 env file
|
adamc@25
|
361 in
|
adamc@25
|
362 p_list_sep newline (fn x => x) pds
|
adamc@25
|
363 end
|
adamc@25
|
364
|
adamc@25
|
365 end
|