adamc@16
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@16
|
2 * All rights reserved.
|
adamc@16
|
3 *
|
adamc@16
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@16
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@16
|
6 *
|
adamc@16
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@16
|
8 * this list of conditions and the following disclaimer.
|
adamc@16
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@16
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@16
|
11 * and/or other materials provided with the distribution.
|
adamc@16
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@16
|
13 * derived from this software without specific prior written permission.
|
adamc@16
|
14 *
|
adamc@16
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@16
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@16
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@16
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@16
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@16
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@16
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@16
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@16
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@16
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@16
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@16
|
26 *)
|
adamc@16
|
27
|
adamc@244
|
28 (* Pretty-printing core Ur/Web *)
|
adamc@16
|
29
|
adamc@16
|
30 structure CorePrint :> CORE_PRINT = struct
|
adamc@16
|
31
|
adamc@16
|
32 open Print.PD
|
adamc@16
|
33 open Print
|
adamc@16
|
34
|
adamc@16
|
35 open Core
|
adamc@16
|
36
|
adamc@16
|
37 structure E = CoreEnv
|
adamc@16
|
38
|
adamc@16
|
39 val debug = ref false
|
adamc@16
|
40
|
adamc@626
|
41 fun p_kind' par env (k, _) =
|
adamc@16
|
42 case k of
|
adamc@16
|
43 KType => string "Type"
|
adamc@626
|
44 | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
|
adamc@16
|
45 space,
|
adamc@16
|
46 string "->",
|
adamc@16
|
47 space,
|
adamc@626
|
48 p_kind env k2])
|
adamc@16
|
49 | KName => string "Name"
|
adamc@626
|
50 | KRecord k => box [string "{", p_kind env k, string "}"]
|
adamc@87
|
51 | KUnit => string "Unit"
|
adamc@214
|
52 | KTuple ks => box [string "(",
|
adamc@626
|
53 p_list_sep (box [space, string "*", space]) (p_kind env) ks,
|
adamc@214
|
54 string ")"]
|
adamc@16
|
55
|
adamc@626
|
56 | KRel n => ((if !debug then
|
adamc@626
|
57 string (E.lookupKRel env n ^ "_" ^ Int.toString n)
|
adamc@626
|
58 else
|
adamc@626
|
59 string (E.lookupKRel env n))
|
adamc@626
|
60 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
|
adamc@626
|
61 | KFun (x, k) => box [string x,
|
adamc@626
|
62 space,
|
adamc@626
|
63 string "-->",
|
adamc@626
|
64 space,
|
adamc@626
|
65 p_kind (E.pushKRel env x) k]
|
adamc@626
|
66
|
adamc@626
|
67 and p_kind env = p_kind' false env
|
adamc@16
|
68
|
adamc@16
|
69 fun p_con' par env (c, _) =
|
adamc@16
|
70 case c of
|
adamc@16
|
71 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
|
adamc@16
|
72 space,
|
adamc@16
|
73 string "->",
|
adamc@16
|
74 space,
|
adamc@16
|
75 p_con env t2])
|
adamc@16
|
76 | TCFun (x, k, c) => parenIf par (box [string x,
|
adamc@16
|
77 space,
|
adamc@16
|
78 string "::",
|
adamc@16
|
79 space,
|
adamc@626
|
80 p_kind env k,
|
adamc@16
|
81 space,
|
adamc@16
|
82 string "->",
|
adamc@16
|
83 space,
|
adamc@16
|
84 p_con (E.pushCRel env x k) c])
|
adamc@16
|
85 | TRecord (CRecord (_, xcs), _) => box [string "{",
|
adamc@16
|
86 p_list (fn (x, c) =>
|
adamc@20
|
87 box [p_name env x,
|
adamc@16
|
88 space,
|
adamc@16
|
89 string ":",
|
adamc@16
|
90 space,
|
adamc@16
|
91 p_con env c]) xcs,
|
adamc@16
|
92 string "}"]
|
adamc@16
|
93 | TRecord c => box [string "$",
|
adamc@16
|
94 p_con' true env c]
|
adamc@16
|
95
|
adamc@16
|
96 | CRel n =>
|
adamc@39
|
97 ((if !debug then
|
adamc@39
|
98 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
|
adamc@39
|
99 else
|
adamc@39
|
100 string (#1 (E.lookupCRel env n)))
|
adamc@39
|
101 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
|
adamc@16
|
102 | CNamed n =>
|
adamc@39
|
103 ((if !debug then
|
adamc@39
|
104 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
|
adamc@39
|
105 else
|
adamc@39
|
106 string (#1 (E.lookupCNamed env n)))
|
adamc@480
|
107 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
|
adamc@48
|
108 | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@16
|
109
|
adamc@16
|
110 | CApp (c1, c2) => parenIf par (box [p_con env c1,
|
adamc@16
|
111 space,
|
adamc@16
|
112 p_con' true env c2])
|
adamc@16
|
113 | CAbs (x, k, c) => parenIf par (box [string "fn",
|
adamc@16
|
114 space,
|
adamc@16
|
115 string x,
|
adamc@16
|
116 space,
|
adamc@16
|
117 string "::",
|
adamc@16
|
118 space,
|
adamc@626
|
119 p_kind env k,
|
adamc@16
|
120 space,
|
adamc@16
|
121 string "=>",
|
adamc@16
|
122 space,
|
adamc@16
|
123 p_con (E.pushCRel env x k) c])
|
adamc@16
|
124
|
adamc@16
|
125 | CName s => box [string "#", string s]
|
adamc@16
|
126
|
adamc@16
|
127 | CRecord (k, xcs) =>
|
adamc@16
|
128 if !debug then
|
adamc@16
|
129 parenIf par (box [string "[",
|
adamc@16
|
130 p_list (fn (x, c) =>
|
adamc@16
|
131 box [p_con env x,
|
adamc@16
|
132 space,
|
adamc@16
|
133 string "=",
|
adamc@16
|
134 space,
|
adamc@16
|
135 p_con env c]) xcs,
|
adamc@16
|
136 string "]::",
|
adamc@626
|
137 p_kind env k])
|
adamc@16
|
138 else
|
adamc@16
|
139 parenIf par (box [string "[",
|
adamc@16
|
140 p_list (fn (x, c) =>
|
adamc@16
|
141 box [p_con env x,
|
adamc@16
|
142 space,
|
adamc@16
|
143 string "=",
|
adamc@16
|
144 space,
|
adamc@16
|
145 p_con env c]) xcs,
|
adamc@16
|
146 string "]"])
|
adamc@16
|
147 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
|
adamc@16
|
148 space,
|
adamc@16
|
149 string "++",
|
adamc@16
|
150 space,
|
adamc@16
|
151 p_con env c2])
|
adamc@621
|
152 | CMap _ => string "map"
|
adamc@87
|
153 | CUnit => string "()"
|
adamc@214
|
154
|
adamc@214
|
155 | CTuple cs => box [string "(",
|
adamc@214
|
156 p_list (p_con env) cs,
|
adamc@214
|
157 string ")"]
|
adamc@214
|
158 | CProj (c, n) => box [p_con env c,
|
adamc@214
|
159 string ".",
|
adamc@214
|
160 string (Int.toString n)]
|
adamc@626
|
161
|
adamc@626
|
162 | CKAbs (x, c) => box [string x,
|
adamc@626
|
163 space,
|
adamc@626
|
164 string "==>",
|
adamc@626
|
165 space,
|
adamc@626
|
166 p_con (E.pushKRel env x) c]
|
adamc@626
|
167 | CKApp (c, k) => box [p_con env c,
|
adamc@626
|
168 string "[[",
|
adamc@626
|
169 p_kind env k,
|
adamc@626
|
170 string "]]"]
|
adamc@626
|
171 | TKFun (x, c) => box [string x,
|
adamc@626
|
172 space,
|
adamc@626
|
173 string "-->",
|
adamc@626
|
174 space,
|
adamc@626
|
175 p_con (E.pushKRel env x) c]
|
adamc@16
|
176
|
adamc@16
|
177 and p_con env = p_con' false env
|
adamc@16
|
178
|
adamc@20
|
179 and p_name env (all as (c, _)) =
|
adamc@20
|
180 case c of
|
adamc@20
|
181 CName s => string s
|
adamc@20
|
182 | _ => p_con env all
|
adamc@20
|
183
|
adamc@109
|
184 fun p_enamed env n =
|
adamc@109
|
185 (if !debug then
|
adamc@109
|
186 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
|
adamc@109
|
187 else
|
adamc@109
|
188 string (#1 (E.lookupENamed env n)))
|
adamc@109
|
189 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
|
adamc@109
|
190
|
adamc@177
|
191 fun p_con_named env n =
|
adamc@177
|
192 (if !debug then
|
adamc@177
|
193 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
|
adamc@177
|
194 else
|
adamc@177
|
195 string (#1 (E.lookupConstructor env n)))
|
adamc@177
|
196 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
|
adamc@177
|
197
|
adamc@177
|
198 fun p_patCon env pc =
|
adamc@177
|
199 case pc of
|
adamc@177
|
200 PConVar n => p_con_named env n
|
adamc@796
|
201 | PConFfi {mod = m, con, arg, params, ...} =>
|
adamc@757
|
202 if !debug then
|
adamc@757
|
203 box [string "FFIC[",
|
adamc@757
|
204 case arg of
|
adamc@757
|
205 NONE => box []
|
adamc@796
|
206 | SOME t =>
|
adamc@796
|
207 let
|
adamc@796
|
208 val k = (KType, ErrorMsg.dummySpan)
|
adamc@796
|
209 val env' = foldl (fn (x, env) => E.pushCRel env x k) env params
|
adamc@796
|
210 in
|
adamc@796
|
211 p_con env' t
|
adamc@796
|
212 end,
|
adamc@757
|
213 string "](",
|
adamc@757
|
214 string m,
|
adamc@757
|
215 string ".",
|
adamc@757
|
216 string con,
|
adamc@757
|
217 string ")"]
|
adamc@757
|
218 else
|
adamc@757
|
219 box [string "FFIC(",
|
adamc@757
|
220 string m,
|
adamc@757
|
221 string ".",
|
adamc@757
|
222 string con,
|
adamc@757
|
223 string ")"]
|
adamc@177
|
224
|
adamc@177
|
225 fun p_pat' par env (p, _) =
|
adamc@177
|
226 case p of
|
adamc@177
|
227 PWild => string "_"
|
adamc@182
|
228 | PVar (s, _) => string s
|
adamc@177
|
229 | PPrim p => Prim.p_t p
|
adamc@192
|
230 | PCon (_, n, _, NONE) => p_patCon env n
|
adamc@192
|
231 | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n,
|
adamc@192
|
232 space,
|
adamc@192
|
233 p_pat' true env p])
|
adamc@177
|
234 | PRecord xps =>
|
adamc@177
|
235 box [string "{",
|
adamc@182
|
236 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
|
adamc@177
|
237 box [string x,
|
adamc@177
|
238 space,
|
adamc@177
|
239 string "=",
|
adamc@177
|
240 space,
|
adamc@177
|
241 p_pat env p]) xps,
|
adamc@177
|
242 string "}"]
|
adamc@177
|
243
|
adamc@177
|
244 and p_pat x = p_pat' false x
|
adamc@177
|
245
|
adamc@16
|
246 fun p_exp' par env (e, _) =
|
adamc@16
|
247 case e of
|
adamc@16
|
248 EPrim p => Prim.p_t p
|
adamc@16
|
249 | ERel n =>
|
adamc@39
|
250 ((if !debug then
|
adamc@39
|
251 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
|
adamc@39
|
252 else
|
adamc@39
|
253 string (#1 (E.lookupERel env n)))
|
adamc@39
|
254 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
|
adamc@109
|
255 | ENamed n => p_enamed env n
|
adamc@194
|
256 | ECon (_, pc, ts, NONE) => box [string "[",
|
adamc@194
|
257 p_patCon env pc,
|
adamc@194
|
258 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
|
adamc@194
|
259 string "]"]
|
adamc@194
|
260 | ECon (_, pc, ts, SOME e) => box [string "[",
|
adamc@193
|
261 p_patCon env pc,
|
adamc@193
|
262 space,
|
adamc@193
|
263 p_exp' true env e,
|
adamc@194
|
264 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
|
adamc@193
|
265 string "]"]
|
adamc@48
|
266 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@48
|
267 | EFfiApp (m, x, es) => box [string "FFI(",
|
adamc@48
|
268 string m,
|
adamc@48
|
269 string ".",
|
adamc@48
|
270 string x,
|
adamc@48
|
271 string "(",
|
adamc@48
|
272 p_list (p_exp env) es,
|
adamc@48
|
273 string "))"]
|
adamc@487
|
274 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
|
adamc@16
|
275 space,
|
adamc@16
|
276 p_exp' true env e2])
|
adamc@26
|
277 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
|
adamc@26
|
278 space,
|
adamc@26
|
279 string x,
|
adamc@26
|
280 space,
|
adamc@26
|
281 string ":",
|
adamc@26
|
282 space,
|
adamc@26
|
283 p_con env t,
|
adamc@26
|
284 space,
|
adamc@26
|
285 string "=>",
|
adamc@26
|
286 space,
|
adamc@26
|
287 p_exp (E.pushERel env x t) e])
|
adamc@16
|
288 | ECApp (e, c) => parenIf par (box [p_exp env e,
|
adamc@16
|
289 space,
|
adamc@16
|
290 string "[",
|
adamc@16
|
291 p_con env c,
|
adamc@16
|
292 string "]"])
|
adamc@16
|
293 | ECAbs (x, k, e) => parenIf par (box [string "fn",
|
adamc@16
|
294 space,
|
adamc@16
|
295 string x,
|
adamc@16
|
296 space,
|
adamc@16
|
297 string "::",
|
adamc@16
|
298 space,
|
adamc@626
|
299 p_kind env k,
|
adamc@16
|
300 space,
|
adamc@16
|
301 string "=>",
|
adamc@16
|
302 space,
|
adamc@16
|
303 p_exp (E.pushCRel env x k) e])
|
adamc@16
|
304
|
adamc@16
|
305 | ERecord xes => box [string "{",
|
adamc@29
|
306 p_list (fn (x, e, _) =>
|
adamc@21
|
307 box [p_name env x,
|
adamc@16
|
308 space,
|
adamc@16
|
309 string "=",
|
adamc@16
|
310 space,
|
adamc@16
|
311 p_exp env e]) xes,
|
adamc@16
|
312 string "}"]
|
adamc@16
|
313 | EField (e, c, {field, rest}) =>
|
adamc@16
|
314 if !debug then
|
adamc@16
|
315 box [p_exp' true env e,
|
adamc@16
|
316 string ".",
|
adamc@16
|
317 p_con' true env c,
|
adamc@16
|
318 space,
|
adamc@16
|
319 string "[",
|
adamc@16
|
320 p_con env field,
|
adamc@16
|
321 space,
|
adamc@16
|
322 string " in ",
|
adamc@16
|
323 space,
|
adamc@16
|
324 p_con env rest,
|
adamc@16
|
325 string "]"]
|
adamc@16
|
326 else
|
adamc@16
|
327 box [p_exp' true env e,
|
adamc@16
|
328 string ".",
|
adamc@16
|
329 p_con' true env c]
|
adamc@445
|
330 | EConcat (e1, c1, e2, c2) =>
|
adamc@339
|
331 parenIf par (if !debug then
|
adamc@445
|
332 box [p_exp' true env e1,
|
adamc@445
|
333 space,
|
adamc@445
|
334 string ":",
|
adamc@445
|
335 space,
|
adamc@445
|
336 p_con env c1,
|
adamc@445
|
337 space,
|
adamc@445
|
338 string "++",
|
adamc@445
|
339 space,
|
adamc@445
|
340 p_exp' true env e2,
|
adamc@445
|
341 space,
|
adamc@445
|
342 string ":",
|
adamc@445
|
343 space,
|
adamc@445
|
344 p_con env c2]
|
adamc@445
|
345 else
|
adamc@445
|
346 box [p_exp' true env e1,
|
adamc@339
|
347 space,
|
adamc@339
|
348 string "with",
|
adamc@339
|
349 space,
|
adamc@339
|
350 p_exp' true env e2])
|
adamc@149
|
351 | ECut (e, c, {field, rest}) =>
|
adamc@149
|
352 parenIf par (if !debug then
|
adamc@149
|
353 box [p_exp' true env e,
|
adamc@149
|
354 space,
|
adamc@149
|
355 string "--",
|
adamc@149
|
356 space,
|
adamc@149
|
357 p_con' true env c,
|
adamc@149
|
358 space,
|
adamc@149
|
359 string "[",
|
adamc@149
|
360 p_con env field,
|
adamc@149
|
361 space,
|
adamc@149
|
362 string " in ",
|
adamc@149
|
363 space,
|
adamc@149
|
364 p_con env rest,
|
adamc@149
|
365 string "]"]
|
adamc@149
|
366 else
|
adamc@149
|
367 box [p_exp' true env e,
|
adamc@149
|
368 space,
|
adamc@149
|
369 string "--",
|
adamc@149
|
370 space,
|
adamc@149
|
371 p_con' true env c])
|
adamc@493
|
372 | ECutMulti (e, c, {rest}) =>
|
adamc@493
|
373 parenIf par (if !debug then
|
adamc@493
|
374 box [p_exp' true env e,
|
adamc@493
|
375 space,
|
adamc@493
|
376 string "---",
|
adamc@493
|
377 space,
|
adamc@493
|
378 p_con' true env c,
|
adamc@493
|
379 space,
|
adamc@493
|
380 string "[",
|
adamc@493
|
381 p_con env rest,
|
adamc@493
|
382 string "]"]
|
adamc@493
|
383 else
|
adamc@493
|
384 box [p_exp' true env e,
|
adamc@493
|
385 space,
|
adamc@493
|
386 string "---",
|
adamc@493
|
387 space,
|
adamc@493
|
388 p_con' true env c])
|
adamc@16
|
389
|
adamc@288
|
390 | ECase (e, pes, {disc, result}) =>
|
adamc@288
|
391 parenIf par (box [string "case",
|
adamc@288
|
392 space,
|
adamc@288
|
393 p_exp env e,
|
adamc@288
|
394 space,
|
adamc@288
|
395 if !debug then
|
adamc@288
|
396 box [string "in",
|
adamc@288
|
397 space,
|
adamc@288
|
398 p_con env disc,
|
adamc@288
|
399 space,
|
adamc@288
|
400 string "return",
|
adamc@288
|
401 space,
|
adamc@288
|
402 p_con env result,
|
adamc@288
|
403 space]
|
adamc@288
|
404 else
|
adamc@288
|
405 box [],
|
adamc@288
|
406 string "of",
|
adamc@288
|
407 space,
|
adamc@288
|
408 p_list_sep (box [space, string "|", space])
|
adamc@288
|
409 (fn (p, e) => box [p_pat env p,
|
adamc@288
|
410 space,
|
adamc@288
|
411 string "=>",
|
adamc@288
|
412 space,
|
adamc@288
|
413 p_exp (E.patBinds env p) e]) pes])
|
adamc@177
|
414
|
adamc@102
|
415 | EWrite e => box [string "write(",
|
adamc@102
|
416 p_exp env e,
|
adamc@102
|
417 string ")"]
|
adamc@102
|
418
|
adamc@110
|
419 | EClosure (n, es) => box [string "CLOSURE(",
|
adamc@110
|
420 p_enamed env n,
|
adamc@110
|
421 p_list_sep (string "") (fn e => box [string ", ",
|
adamc@110
|
422 p_exp env e]) es,
|
adamc@110
|
423 string ")"]
|
adamc@110
|
424
|
adamc@450
|
425 | ELet (x, t, e1, e2) => box [string "let",
|
adamc@450
|
426 space,
|
adamc@450
|
427 string x,
|
adamc@450
|
428 space,
|
adamc@450
|
429 string ":",
|
adamc@450
|
430 p_con env t,
|
adamc@450
|
431 space,
|
adamc@450
|
432 string "=",
|
adamc@450
|
433 space,
|
adamc@450
|
434 p_exp env e1,
|
adamc@450
|
435 space,
|
adamc@450
|
436 string "in",
|
adamc@450
|
437 newline,
|
adamc@450
|
438 p_exp (E.pushERel env x t) e2]
|
adamc@450
|
439
|
adamc@609
|
440 | EServerCall (n, es, e, _) => box [string "Server(",
|
adamc@609
|
441 p_enamed env n,
|
adamc@609
|
442 string ",",
|
adamc@609
|
443 space,
|
adamc@609
|
444 p_list (p_exp env) es,
|
adamc@609
|
445 string ")[",
|
adamc@609
|
446 p_exp env e,
|
adamc@609
|
447 string "]"]
|
adamc@607
|
448
|
adamc@626
|
449 | EKAbs (x, e) => box [string x,
|
adamc@626
|
450 space,
|
adamc@626
|
451 string "==>",
|
adamc@626
|
452 space,
|
adamc@626
|
453 p_exp (E.pushKRel env x) e]
|
adamc@626
|
454 | EKApp (e, k) => box [p_exp env e,
|
adamc@626
|
455 string "[[",
|
adamc@626
|
456 p_kind env k,
|
adamc@626
|
457 string "]]"]
|
adamc@626
|
458
|
adamc@16
|
459 and p_exp env = p_exp' false env
|
adamc@16
|
460
|
adamc@247
|
461 fun p_named x n =
|
adamc@247
|
462 if !debug then
|
adamc@247
|
463 box [string x,
|
adamc@247
|
464 string "__",
|
adamc@247
|
465 string (Int.toString n)]
|
adamc@247
|
466 else
|
adamc@247
|
467 string x
|
adamc@247
|
468
|
adamc@125
|
469 fun p_vali env (x, n, t, e, s) =
|
adamc@125
|
470 let
|
adamc@247
|
471 val xp = p_named x n
|
adamc@125
|
472 in
|
adamc@125
|
473 box [xp,
|
adamc@125
|
474 space,
|
adamc@125
|
475 string "as",
|
adamc@125
|
476 space,
|
adamc@125
|
477 string s,
|
adamc@125
|
478 space,
|
adamc@125
|
479 string ":",
|
adamc@125
|
480 space,
|
adamc@125
|
481 p_con env t,
|
adamc@125
|
482 space,
|
adamc@125
|
483 string "=",
|
adamc@125
|
484 space,
|
adamc@125
|
485 p_exp env e]
|
adamc@125
|
486 end
|
adamc@125
|
487
|
adamc@192
|
488 fun p_datatype env (x, n, xs, cons) =
|
adamc@163
|
489 let
|
adamc@192
|
490 val k = (KType, ErrorMsg.dummySpan)
|
adamc@163
|
491 val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
|
adamc@192
|
492 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
|
adamc@193
|
493
|
adamc@193
|
494 val xp = if !debug then
|
adamc@193
|
495 string (x ^ "__" ^ Int.toString n)
|
adamc@193
|
496 else
|
adamc@193
|
497 string x
|
adamc@163
|
498 in
|
adamc@163
|
499 box [string "datatype",
|
adamc@163
|
500 space,
|
adamc@193
|
501 xp,
|
adamc@192
|
502 p_list_sep (box []) (fn x => box [space, string x]) xs,
|
adamc@163
|
503 space,
|
adamc@163
|
504 string "=",
|
adamc@163
|
505 space,
|
adamc@163
|
506 p_list_sep (box [space, string "|", space])
|
adamc@163
|
507 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@163
|
508 else string x
|
adamc@193
|
509 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@163
|
510 else string x, space, string "of", space, p_con env t])
|
adamc@163
|
511 cons]
|
adamc@163
|
512 end
|
adamc@163
|
513
|
adamc@125
|
514 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@16
|
515 case d of
|
adamc@16
|
516 DCon (x, n, k, c) =>
|
adamc@16
|
517 let
|
adamc@16
|
518 val xp = if !debug then
|
adamc@16
|
519 box [string x,
|
adamc@16
|
520 string "__",
|
adamc@16
|
521 string (Int.toString n)]
|
adamc@16
|
522 else
|
adamc@16
|
523 string x
|
adamc@16
|
524 in
|
adamc@16
|
525 box [string "con",
|
adamc@16
|
526 space,
|
adamc@16
|
527 xp,
|
adamc@16
|
528 space,
|
adamc@16
|
529 string "::",
|
adamc@16
|
530 space,
|
adamc@626
|
531 p_kind env k,
|
adamc@16
|
532 space,
|
adamc@16
|
533 string "=",
|
adamc@16
|
534 space,
|
adamc@16
|
535 p_con env c]
|
adamc@16
|
536 end
|
adamc@163
|
537 | DDatatype x => p_datatype env x
|
adamc@125
|
538 | DVal vi => box [string "val",
|
adamc@125
|
539 space,
|
adamc@125
|
540 p_vali env vi]
|
adamc@125
|
541 | DValRec vis =>
|
adamc@16
|
542 let
|
adamc@125
|
543 val env = E.declBinds env dAll
|
adamc@16
|
544 in
|
adamc@16
|
545 box [string "val",
|
adamc@16
|
546 space,
|
adamc@125
|
547 string "rec",
|
adamc@16
|
548 space,
|
adamc@125
|
549 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
|
adamc@16
|
550 end
|
adamc@144
|
551 | DExport (ek, n) => box [string "export",
|
adamc@144
|
552 space,
|
adamc@732
|
553 Export.p_export_kind ek,
|
adamc@144
|
554 space,
|
adamc@144
|
555 p_enamed env n,
|
adamc@144
|
556 space,
|
adamc@144
|
557 string "as",
|
adamc@144
|
558 space,
|
adamc@482
|
559 (p_con env (#2 (E.lookupENamed env n))
|
adamc@482
|
560 handle E.UnboundNamed _ => string "UNBOUND")]
|
adamc@707
|
561 | DTable (x, n, c, s, pe, _, ce, _) => box [string "table",
|
adamc@707
|
562 space,
|
adamc@707
|
563 p_named x n,
|
adamc@707
|
564 space,
|
adamc@707
|
565 string "as",
|
adamc@707
|
566 space,
|
adamc@707
|
567 string s,
|
adamc@707
|
568 space,
|
adamc@707
|
569 string ":",
|
adamc@707
|
570 space,
|
adamc@707
|
571 p_con env c,
|
adamc@707
|
572 space,
|
adamc@707
|
573 string "keys",
|
adamc@707
|
574 space,
|
adamc@707
|
575 p_exp env pe,
|
adamc@707
|
576 space,
|
adamc@707
|
577 string "constraints",
|
adamc@707
|
578 space,
|
adamc@707
|
579 p_exp env ce]
|
adamc@338
|
580 | DSequence (x, n, s) => box [string "sequence",
|
adamc@338
|
581 space,
|
adamc@338
|
582 p_named x n,
|
adamc@338
|
583 space,
|
adamc@338
|
584 string "as",
|
adamc@338
|
585 space,
|
adamc@338
|
586 string s]
|
adamc@754
|
587 | DView (x, n, s, e, _) => box [string "view",
|
adamc@754
|
588 space,
|
adamc@754
|
589 p_named x n,
|
adamc@754
|
590 space,
|
adamc@754
|
591 string "as",
|
adamc@754
|
592 space,
|
adamc@754
|
593 p_exp env e]
|
adamc@271
|
594 | DDatabase s => box [string "database",
|
adamc@271
|
595 space,
|
adamc@271
|
596 string s]
|
adamc@461
|
597 | DCookie (x, n, c, s) => box [string "cookie",
|
adamc@461
|
598 space,
|
adamc@461
|
599 p_named x n,
|
adamc@461
|
600 space,
|
adamc@461
|
601 string "as",
|
adamc@461
|
602 space,
|
adamc@461
|
603 string s,
|
adamc@461
|
604 space,
|
adamc@461
|
605 string ":",
|
adamc@461
|
606 space,
|
adamc@461
|
607 p_con env c]
|
adamc@720
|
608 | DStyle (x, n, s) => box [string "style",
|
adamc@720
|
609 space,
|
adamc@720
|
610 p_named x n,
|
adamc@720
|
611 space,
|
adamc@720
|
612 string "as",
|
adamc@720
|
613 space,
|
adamc@720
|
614 string s]
|
adamc@16
|
615
|
adamc@16
|
616 fun p_file env file =
|
adamc@16
|
617 let
|
adamc@31
|
618 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@31
|
619 (p_decl env d,
|
adamc@31
|
620 E.declBinds env d))
|
adamc@16
|
621 env file
|
adamc@16
|
622 in
|
adamc@16
|
623 p_list_sep newline (fn x => x) pds
|
adamc@16
|
624 end
|
adamc@16
|
625
|
adamc@16
|
626 end
|