adamc@1278
|
1 (* Copyright (c) 2008-2010, Adam Chlipala
|
adamc@38
|
2 * All rights reserved.
|
adamc@38
|
3 *
|
adamc@38
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@38
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@38
|
6 *
|
adamc@38
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@38
|
8 * this list of conditions and the following disclaimer.
|
adamc@38
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@38
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@38
|
11 * and/or other materials provided with the distribution.
|
adamc@38
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@38
|
13 * derived from this software without specific prior written permission.
|
adamc@38
|
14 *
|
adamc@38
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@38
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@38
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@38
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@38
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@38
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@38
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@38
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@38
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@38
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@38
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@38
|
26 *)
|
adamc@38
|
27
|
adamc@244
|
28 (* Pretty-printing elaborated Ur/Web *)
|
adamc@38
|
29
|
adamc@38
|
30 structure ExplPrint :> EXPL_PRINT = struct
|
adamc@38
|
31
|
adamc@38
|
32 open Print.PD
|
adamc@38
|
33 open Print
|
adamc@38
|
34
|
adamc@38
|
35 open Expl
|
adamc@38
|
36
|
adamc@38
|
37 structure E = ExplEnv
|
adamc@38
|
38
|
adamc@38
|
39 val debug = ref false
|
adamc@38
|
40
|
adamc@624
|
41 fun p_kind' par env (k, _) =
|
adamc@38
|
42 case k of
|
adamc@38
|
43 KType => string "Type"
|
adamc@624
|
44 | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
|
adamc@38
|
45 space,
|
adamc@38
|
46 string "->",
|
adamc@38
|
47 space,
|
adamc@624
|
48 p_kind env k2])
|
adamc@38
|
49 | KName => string "Name"
|
adamc@624
|
50 | KRecord k => box [string "{", p_kind env k, string "}"]
|
adamc@87
|
51 | KUnit => string "Unit"
|
adamc@213
|
52 | KTuple ks => box [string "(",
|
adamc@624
|
53 p_list_sep (box [space, string "*", space]) (p_kind env) ks,
|
adamc@213
|
54 string ")"]
|
adamc@38
|
55
|
adamc@624
|
56 | KRel n => ((if !debug then
|
adamc@624
|
57 string (E.lookupKRel env n ^ "_" ^ Int.toString n)
|
adamc@624
|
58 else
|
adamc@624
|
59 string (E.lookupKRel env n))
|
adamc@624
|
60 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
|
adamc@624
|
61 | KFun (x, k) => box [string x,
|
adamc@624
|
62 space,
|
adamc@624
|
63 string "-->",
|
adamc@624
|
64 space,
|
adamc@624
|
65 p_kind (E.pushKRel env x) k]
|
adamc@624
|
66
|
adamc@624
|
67 and p_kind env = p_kind' false env
|
adamc@38
|
68
|
adamc@38
|
69 fun p_con' par env (c, _) =
|
adamc@38
|
70 case c of
|
adamc@38
|
71 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
|
adamc@38
|
72 space,
|
adamc@38
|
73 string "->",
|
adamc@38
|
74 space,
|
adamc@38
|
75 p_con env t2])
|
adamc@38
|
76 | TCFun (x, k, c) => parenIf par (box [string x,
|
adamc@38
|
77 space,
|
adamc@38
|
78 string "::",
|
adamc@38
|
79 space,
|
adamc@624
|
80 p_kind env k,
|
adamc@38
|
81 space,
|
adamc@38
|
82 string "->",
|
adamc@38
|
83 space,
|
adamc@38
|
84 p_con (E.pushCRel env x k) c])
|
adamc@38
|
85 | TRecord (CRecord (_, xcs), _) => box [string "{",
|
adamc@38
|
86 p_list (fn (x, c) =>
|
adamc@38
|
87 box [p_name env x,
|
adamc@38
|
88 space,
|
adamc@38
|
89 string ":",
|
adamc@38
|
90 space,
|
adamc@38
|
91 p_con env c]) xcs,
|
adamc@38
|
92 string "}"]
|
adamc@38
|
93 | TRecord c => box [string "$",
|
adamc@38
|
94 p_con' true env c]
|
adamc@38
|
95
|
adamc@38
|
96 | CRel n =>
|
adamc@449
|
97 ((if !debug then
|
adamc@449
|
98 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
|
adamc@449
|
99 else
|
adamc@449
|
100 string (#1 (E.lookupCRel env n)))
|
adamc@449
|
101 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
|
adamc@38
|
102 | CNamed n =>
|
adamc@38
|
103 ((if !debug then
|
adamc@38
|
104 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
|
adamc@38
|
105 else
|
adamc@38
|
106 string (#1 (E.lookupCNamed env n)))
|
adamc@38
|
107 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
|
adamc@38
|
108 | CModProj (m1, ms, x) =>
|
adamc@38
|
109 let
|
adamc@109
|
110 val m1x = #1 (E.lookupStrNamed env m1)
|
adamc@480
|
111 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString m1
|
adamc@38
|
112
|
adamc@38
|
113 val m1s = if !debug then
|
adamc@38
|
114 m1x ^ "__" ^ Int.toString m1
|
adamc@38
|
115 else
|
adamc@38
|
116 m1x
|
adamc@38
|
117 in
|
adamc@146
|
118 p_list_sep (string ".") string (m1s :: ms @ [x])
|
adamc@38
|
119 end
|
adamc@38
|
120
|
adamc@38
|
121 | CApp (c1, c2) => parenIf par (box [p_con env c1,
|
adamc@38
|
122 space,
|
adamc@38
|
123 p_con' true env c2])
|
adamc@38
|
124 | CAbs (x, k, c) => parenIf par (box [string "fn",
|
adamc@38
|
125 space,
|
adamc@38
|
126 string x,
|
adamc@38
|
127 space,
|
adamc@38
|
128 string "::",
|
adamc@38
|
129 space,
|
adamc@624
|
130 p_kind env k,
|
adamc@38
|
131 space,
|
adamc@38
|
132 string "=>",
|
adamc@38
|
133 space,
|
adamc@38
|
134 p_con (E.pushCRel env x k) c])
|
adamc@38
|
135
|
adamc@38
|
136 | CName s => box [string "#", string s]
|
adamc@38
|
137
|
adamc@38
|
138 | CRecord (k, xcs) =>
|
adamc@38
|
139 if !debug then
|
adamc@38
|
140 parenIf par (box [string "[",
|
adamc@38
|
141 p_list (fn (x, c) =>
|
adamc@38
|
142 box [p_con env x,
|
adamc@38
|
143 space,
|
adamc@38
|
144 string "=",
|
adamc@38
|
145 space,
|
adamc@38
|
146 p_con env c]) xcs,
|
adamc@38
|
147 string "]::",
|
adamc@624
|
148 p_kind env k])
|
adamc@38
|
149 else
|
adamc@38
|
150 parenIf par (box [string "[",
|
adamc@38
|
151 p_list (fn (x, c) =>
|
adamc@38
|
152 box [p_con env x,
|
adamc@38
|
153 space,
|
adamc@38
|
154 string "=",
|
adamc@38
|
155 space,
|
adamc@38
|
156 p_con env c]) xcs,
|
adamc@38
|
157 string "]"])
|
adamc@38
|
158 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
|
adamc@38
|
159 space,
|
adamc@38
|
160 string "++",
|
adamc@38
|
161 space,
|
adamc@38
|
162 p_con env c2])
|
adamc@621
|
163 | CMap _ => string "map"
|
adamc@87
|
164 | CUnit => string "()"
|
adamc@213
|
165
|
adamc@213
|
166 | CTuple cs => box [string "(",
|
adamc@213
|
167 p_list (p_con env) cs,
|
adamc@213
|
168 string ")"]
|
adamc@213
|
169 | CProj (c, n) => box [p_con env c,
|
adamc@213
|
170 string ".",
|
adamc@213
|
171 string (Int.toString n)]
|
adamc@624
|
172
|
adamc@624
|
173 | CKAbs (x, c) => box [string x,
|
adamc@624
|
174 space,
|
adamc@624
|
175 string "==>",
|
adamc@624
|
176 space,
|
adamc@624
|
177 p_con (E.pushKRel env x) c]
|
adamc@624
|
178 | CKApp (c, k) => box [p_con env c,
|
adamc@624
|
179 string "[[",
|
adamc@624
|
180 p_kind env k,
|
adamc@624
|
181 string "]]"]
|
adamc@624
|
182 | TKFun (x, c) => box [string x,
|
adamc@624
|
183 space,
|
adamc@624
|
184 string "-->",
|
adamc@624
|
185 space,
|
adamc@624
|
186 p_con (E.pushKRel env x) c]
|
adamc@38
|
187
|
adamc@38
|
188 and p_con env = p_con' false env
|
adamc@38
|
189
|
adamc@38
|
190 and p_name env (all as (c, _)) =
|
adamc@38
|
191 case c of
|
adamc@38
|
192 CName s => string s
|
adamc@38
|
193 | _ => p_con env all
|
adamc@38
|
194
|
adamc@176
|
195 fun p_patCon env pc =
|
adamc@176
|
196 case pc of
|
adamc@176
|
197 PConVar n =>
|
adamc@176
|
198 ((if !debug then
|
adamc@176
|
199 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
|
adamc@176
|
200 else
|
adamc@176
|
201 string (#1 (E.lookupENamed env n)))
|
adamc@449
|
202 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
|
adamc@176
|
203 | PConProj (m1, ms, x) =>
|
adamc@176
|
204 let
|
adamc@176
|
205 val m1x = #1 (E.lookupStrNamed env m1)
|
adamc@176
|
206 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
|
adamc@176
|
207
|
adamc@176
|
208 val m1s = if !debug then
|
adamc@176
|
209 m1x ^ "__" ^ Int.toString m1
|
adamc@176
|
210 else
|
adamc@176
|
211 m1x
|
adamc@176
|
212 in
|
adamc@176
|
213 p_list_sep (string ".") string (m1x :: ms @ [x])
|
adamc@176
|
214 end
|
adamc@176
|
215
|
adamc@176
|
216 fun p_pat' par env (p, _) =
|
adamc@176
|
217 case p of
|
adamc@176
|
218 PWild => string "_"
|
adamc@182
|
219 | PVar (s, _) => string s
|
adamc@176
|
220 | PPrim p => Prim.p_t p
|
adamc@191
|
221 | PCon (_, pc, _, NONE) => p_patCon env pc
|
adamc@796
|
222 | PCon (_, pc, cs, SOME p) =>
|
adamc@796
|
223 if !debug then
|
adamc@796
|
224 parenIf par (box [p_patCon env pc,
|
adamc@796
|
225 string "[",
|
adamc@796
|
226 p_list (p_con env) cs,
|
adamc@796
|
227 string "]",
|
adamc@796
|
228 space,
|
adamc@796
|
229 p_pat' true env p])
|
adamc@796
|
230 else
|
adamc@796
|
231 parenIf par (box [p_patCon env pc,
|
adamc@796
|
232 space,
|
adamc@796
|
233 p_pat' true env p])
|
adamc@796
|
234
|
adamc@176
|
235 | PRecord xps =>
|
adamc@176
|
236 box [string "{",
|
adamc@1272
|
237 p_list_sep (box [string ",", space]) (fn (x, p, t) =>
|
adamc@176
|
238 box [string x,
|
adamc@176
|
239 space,
|
adamc@176
|
240 string "=",
|
adamc@176
|
241 space,
|
adamc@1272
|
242 p_pat env p,
|
adamc@1272
|
243 if !debug then
|
adamc@1272
|
244 box [space,
|
adamc@1272
|
245 string ":",
|
adamc@1272
|
246 space,
|
adamc@1272
|
247 p_con env t]
|
adamc@1272
|
248 else
|
adamc@1272
|
249 box []]) xps,
|
adamc@176
|
250 string "}"]
|
adamc@176
|
251
|
adamc@176
|
252 and p_pat x = p_pat' false x
|
adamc@176
|
253
|
adamc@146
|
254 fun p_exp' par env (e, loc) =
|
adamc@38
|
255 case e of
|
adamc@38
|
256 EPrim p => Prim.p_t p
|
adamc@38
|
257 | ERel n =>
|
adamc@449
|
258 ((if !debug then
|
adamc@449
|
259 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
|
adamc@449
|
260 else
|
adamc@449
|
261 string (#1 (E.lookupERel env n)))
|
adamc@449
|
262 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
|
adamc@38
|
263 | ENamed n =>
|
adamc@449
|
264 ((if !debug then
|
adamc@449
|
265 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
|
adamc@449
|
266 else
|
adamc@449
|
267 string (#1 (E.lookupENamed env n)))
|
adamc@449
|
268 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
|
adamc@38
|
269 | EModProj (m1, ms, x) =>
|
adamc@38
|
270 let
|
adamc@38
|
271 val (m1x, sgn) = E.lookupStrNamed env m1
|
adamc@480
|
272 handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
|
adamc@38
|
273
|
adamc@38
|
274 val m1s = if !debug then
|
adamc@38
|
275 m1x ^ "__" ^ Int.toString m1
|
adamc@38
|
276 else
|
adamc@38
|
277 m1x
|
adamc@38
|
278 in
|
adamc@146
|
279 p_list_sep (string ".") string (m1s :: ms @ [x])
|
adamc@38
|
280 end
|
adamc@38
|
281
|
adamc@38
|
282 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
|
adamc@38
|
283 space,
|
adamc@38
|
284 p_exp' true env e2])
|
adamc@38
|
285 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
|
adamc@38
|
286 space,
|
adamc@38
|
287 string x,
|
adamc@38
|
288 space,
|
adamc@38
|
289 string ":",
|
adamc@38
|
290 space,
|
adamc@38
|
291 p_con env t,
|
adamc@38
|
292 space,
|
adamc@38
|
293 string "=>",
|
adamc@38
|
294 space,
|
adamc@38
|
295 p_exp (E.pushERel env x t) e])
|
adamc@38
|
296 | ECApp (e, c) => parenIf par (box [p_exp env e,
|
adamc@38
|
297 space,
|
adamc@38
|
298 string "[",
|
adamc@38
|
299 p_con env c,
|
adamc@38
|
300 string "]"])
|
adamc@38
|
301 | ECAbs (x, k, e) => parenIf par (box [string "fn",
|
adamc@38
|
302 space,
|
adamc@38
|
303 string x,
|
adamc@38
|
304 space,
|
adamc@38
|
305 string "::",
|
adamc@38
|
306 space,
|
adamc@624
|
307 p_kind env k,
|
adamc@38
|
308 space,
|
adamc@38
|
309 string "=>",
|
adamc@38
|
310 space,
|
adamc@38
|
311 p_exp (E.pushCRel env x k) e])
|
adamc@38
|
312
|
adamc@38
|
313 | ERecord xes => box [string "{",
|
adamc@38
|
314 p_list (fn (x, e, _) =>
|
adamc@38
|
315 box [p_name env x,
|
adamc@38
|
316 space,
|
adamc@38
|
317 string "=",
|
adamc@38
|
318 space,
|
adamc@38
|
319 p_exp env e]) xes,
|
adamc@38
|
320 string "}"]
|
adamc@38
|
321 | EField (e, c, {field, rest}) =>
|
adamc@38
|
322 if !debug then
|
adamc@38
|
323 box [p_exp' true env e,
|
adamc@38
|
324 string ".",
|
adamc@38
|
325 p_con' true env c,
|
adamc@38
|
326 space,
|
adamc@38
|
327 string "[",
|
adamc@38
|
328 p_con env field,
|
adamc@38
|
329 space,
|
adamc@38
|
330 string " in ",
|
adamc@38
|
331 space,
|
adamc@38
|
332 p_con env rest,
|
adamc@38
|
333 string "]"]
|
adamc@38
|
334 else
|
adamc@38
|
335 box [p_exp' true env e,
|
adamc@38
|
336 string ".",
|
adamc@38
|
337 p_con' true env c]
|
adamc@445
|
338 | EConcat (e1, c1, e2, c2) =>
|
adamc@339
|
339 parenIf par (if !debug then
|
adamc@445
|
340 box [p_exp' true env e1,
|
adamc@445
|
341 space,
|
adamc@445
|
342 string ":",
|
adamc@445
|
343 space,
|
adamc@445
|
344 p_con env c1,
|
adamc@445
|
345 space,
|
adamc@445
|
346 string "++",
|
adamc@445
|
347 space,
|
adamc@445
|
348 p_exp' true env e2,
|
adamc@445
|
349 space,
|
adamc@445
|
350 string ":",
|
adamc@445
|
351 space,
|
adamc@445
|
352 p_con env c2]
|
adamc@445
|
353 else
|
adamc@445
|
354 box [p_exp' true env e1,
|
adamc@339
|
355 space,
|
adamc@339
|
356 string "with",
|
adamc@339
|
357 space,
|
adamc@339
|
358 p_exp' true env e2])
|
adamc@149
|
359 | ECut (e, c, {field, rest}) =>
|
adamc@149
|
360 parenIf par (if !debug then
|
adamc@149
|
361 box [p_exp' true env e,
|
adamc@149
|
362 space,
|
adamc@149
|
363 string "--",
|
adamc@149
|
364 space,
|
adamc@149
|
365 p_con' true env c,
|
adamc@149
|
366 space,
|
adamc@149
|
367 string "[",
|
adamc@149
|
368 p_con env field,
|
adamc@149
|
369 space,
|
adamc@149
|
370 string " in ",
|
adamc@149
|
371 space,
|
adamc@149
|
372 p_con env rest,
|
adamc@149
|
373 string "]"]
|
adamc@149
|
374 else
|
adamc@149
|
375 box [p_exp' true env e,
|
adamc@149
|
376 space,
|
adamc@149
|
377 string "--",
|
adamc@149
|
378 space,
|
adamc@149
|
379 p_con' true env c])
|
adamc@493
|
380 | ECutMulti (e, c, {rest}) =>
|
adamc@493
|
381 parenIf par (if !debug then
|
adamc@493
|
382 box [p_exp' true env e,
|
adamc@493
|
383 space,
|
adamc@493
|
384 string "---",
|
adamc@493
|
385 space,
|
adamc@493
|
386 p_con' true env c,
|
adamc@493
|
387 space,
|
adamc@493
|
388 string "[",
|
adamc@493
|
389 p_con env rest,
|
adamc@493
|
390 string "]"]
|
adamc@493
|
391 else
|
adamc@493
|
392 box [p_exp' true env e,
|
adamc@493
|
393 space,
|
adamc@493
|
394 string "---",
|
adamc@493
|
395 space,
|
adamc@493
|
396 p_con' true env c])
|
adamc@38
|
397
|
adamc@109
|
398 | EWrite e => box [string "write(",
|
adamc@109
|
399 p_exp env e,
|
adamc@109
|
400 string ")"]
|
adamc@109
|
401
|
adamc@288
|
402 | ECase (e, pes, {disc, result}) =>
|
adamc@288
|
403 parenIf par (box [string "case",
|
adamc@288
|
404 space,
|
adamc@288
|
405 p_exp env e,
|
adamc@288
|
406 space,
|
adamc@288
|
407 if !debug then
|
adamc@288
|
408 box [string "in",
|
adamc@288
|
409 space,
|
adamc@288
|
410 p_con env disc,
|
adamc@288
|
411 space,
|
adamc@288
|
412 string "return",
|
adamc@288
|
413 space,
|
adamc@288
|
414 p_con env result,
|
adamc@288
|
415 space]
|
adamc@288
|
416 else
|
adamc@288
|
417 box [],
|
adamc@288
|
418 string "of",
|
adamc@288
|
419 space,
|
adamc@288
|
420 p_list_sep (box [space, string "|", space])
|
adamc@288
|
421 (fn (p, e) => box [p_pat env p,
|
adamc@288
|
422 space,
|
adamc@288
|
423 string "=>",
|
adamc@288
|
424 space,
|
adamc@1278
|
425 p_exp (E.patBinds env p) e]) pes])
|
adamc@176
|
426
|
adamc@449
|
427 | ELet (x, t, e1, e2) => box [string "let",
|
adamc@449
|
428 space,
|
adamc@449
|
429 string x,
|
adamc@449
|
430 space,
|
adamc@449
|
431 string ":",
|
adamc@453
|
432 space,
|
adamc@449
|
433 p_con env t,
|
adamc@449
|
434 space,
|
adamc@449
|
435 string "=",
|
adamc@449
|
436 space,
|
adamc@449
|
437 p_exp env e1,
|
adamc@449
|
438 space,
|
adamc@449
|
439 string "in",
|
adamc@449
|
440 newline,
|
adamc@449
|
441 p_exp (E.pushERel env x t) e2]
|
adamc@449
|
442
|
adamc@624
|
443 | EKAbs (x, e) => box [string x,
|
adamc@624
|
444 space,
|
adamc@624
|
445 string "==>",
|
adamc@624
|
446 space,
|
adamc@624
|
447 p_exp (E.pushKRel env x) e]
|
adamc@624
|
448 | EKApp (e, k) => box [p_exp env e,
|
adamc@624
|
449 string "[[",
|
adamc@624
|
450 p_kind env k,
|
adamc@624
|
451 string "]]"]
|
adamc@449
|
452
|
adamc@449
|
453
|
adamc@38
|
454 and p_exp env = p_exp' false env
|
adamc@38
|
455
|
adamc@38
|
456 fun p_named x n =
|
adamc@38
|
457 if !debug then
|
adamc@38
|
458 box [string x,
|
adamc@38
|
459 string "__",
|
adamc@38
|
460 string (Int.toString n)]
|
adamc@38
|
461 else
|
adamc@38
|
462 string x
|
adamc@38
|
463
|
adamc@191
|
464 fun p_datatype env (x, n, xs, cons) =
|
adamc@162
|
465 let
|
adamc@191
|
466 val k = (KType, ErrorMsg.dummySpan)
|
adamc@191
|
467 val env = E.pushCNamed env x n k NONE
|
adamc@191
|
468 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
|
adamc@162
|
469 in
|
adamc@806
|
470 box [string x,
|
adamc@191
|
471 p_list_sep (box []) (fn x => box [space, string x]) xs,
|
adamc@162
|
472 space,
|
adamc@162
|
473 string "=",
|
adamc@162
|
474 space,
|
adamc@162
|
475 p_list_sep (box [space, string "|", space])
|
adamc@163
|
476 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@163
|
477 else string x
|
adamc@193
|
478 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@163
|
479 else string x, space, string "of", space, p_con env t])
|
adamc@162
|
480 cons]
|
adamc@162
|
481 end
|
adamc@162
|
482
|
adamc@806
|
483 fun p_sgn_item env (sgiAll as (sgi, _)) =
|
adamc@38
|
484 case sgi of
|
adamc@38
|
485 SgiConAbs (x, n, k) => box [string "con",
|
adamc@38
|
486 space,
|
adamc@38
|
487 p_named x n,
|
adamc@38
|
488 space,
|
adamc@38
|
489 string "::",
|
adamc@38
|
490 space,
|
adamc@624
|
491 p_kind env k]
|
adamc@38
|
492 | SgiCon (x, n, k, c) => box [string "con",
|
adamc@38
|
493 space,
|
adamc@38
|
494 p_named x n,
|
adamc@38
|
495 space,
|
adamc@38
|
496 string "::",
|
adamc@38
|
497 space,
|
adamc@624
|
498 p_kind env k,
|
adamc@38
|
499 space,
|
adamc@38
|
500 string "=",
|
adamc@38
|
501 space,
|
adamc@38
|
502 p_con env c]
|
adamc@806
|
503 | SgiDatatype x => box [string "datatype",
|
adamc@806
|
504 space,
|
adamc@806
|
505 p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
|
adamc@191
|
506 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
|
adamc@162
|
507 let
|
adamc@162
|
508 val m1x = #1 (E.lookupStrNamed env m1)
|
adamc@162
|
509 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
|
adamc@162
|
510 in
|
adamc@162
|
511 box [string "datatype",
|
adamc@162
|
512 space,
|
adamc@162
|
513 string x,
|
adamc@162
|
514 space,
|
adamc@162
|
515 string "=",
|
adamc@162
|
516 space,
|
adamc@162
|
517 string "datatype",
|
adamc@162
|
518 space,
|
adamc@162
|
519 p_list_sep (string ".") string (m1x :: ms @ [x'])]
|
adamc@162
|
520 end
|
adamc@38
|
521 | SgiVal (x, n, c) => box [string "val",
|
adamc@38
|
522 space,
|
adamc@38
|
523 p_named x n,
|
adamc@38
|
524 space,
|
adamc@38
|
525 string ":",
|
adamc@38
|
526 space,
|
adamc@38
|
527 p_con env c]
|
adamc@38
|
528 | SgiStr (x, n, sgn) => box [string "structure",
|
adamc@38
|
529 space,
|
adamc@38
|
530 p_named x n,
|
adamc@38
|
531 space,
|
adamc@38
|
532 string ":",
|
adamc@38
|
533 space,
|
adamc@38
|
534 p_sgn env sgn]
|
adamc@64
|
535 | SgiSgn (x, n, sgn) => box [string "signature",
|
adamc@64
|
536 space,
|
adamc@64
|
537 p_named x n,
|
adamc@64
|
538 space,
|
adamc@64
|
539 string "=",
|
adamc@64
|
540 space,
|
adamc@64
|
541 p_sgn env sgn]
|
adamc@38
|
542
|
adamc@146
|
543 and p_sgn env (sgn, loc) =
|
adamc@38
|
544 case sgn of
|
adamc@38
|
545 SgnConst sgis => box [string "sig",
|
adamc@38
|
546 newline,
|
adamc@38
|
547 let
|
adamc@38
|
548 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
|
adamc@38
|
549 (p_sgn_item env sgi,
|
adamc@38
|
550 E.sgiBinds env sgi))
|
adamc@38
|
551 env sgis
|
adamc@38
|
552 in
|
adamc@38
|
553 p_list_sep newline (fn x => x) psgis
|
adamc@38
|
554 end,
|
adamc@38
|
555 newline,
|
adamc@38
|
556 string "end"]
|
adamc@146
|
557 | SgnVar n => string ((#1 (E.lookupSgnNamed env n))
|
adamc@480
|
558 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n)
|
adamc@45
|
559 | SgnFun (x, n, sgn, sgn') => box [string "functor",
|
adamc@45
|
560 space,
|
adamc@45
|
561 string "(",
|
adamc@480
|
562 p_named x n,
|
adamc@45
|
563 space,
|
adamc@45
|
564 string ":",
|
adamc@45
|
565 space,
|
adamc@45
|
566 p_sgn env sgn,
|
adamc@45
|
567 string ")",
|
adamc@45
|
568 space,
|
adamc@45
|
569 string ":",
|
adamc@45
|
570 space,
|
adamc@45
|
571 p_sgn (E.pushStrNamed env x n sgn) sgn']
|
adam@1864
|
572 | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
|
adamc@45
|
573 space,
|
adamc@45
|
574 string "where",
|
adamc@45
|
575 space,
|
adamc@45
|
576 string "con",
|
adamc@45
|
577 space,
|
adam@1864
|
578 p_list_sep (string ".") string (ms @ [x]),
|
adamc@45
|
579 space,
|
adamc@45
|
580 string "=",
|
adamc@45
|
581 space,
|
adamc@45
|
582 p_con env c]
|
adamc@64
|
583 | SgnProj (m1, ms, x) =>
|
adamc@64
|
584 let
|
adamc@64
|
585 val (m1x, sgn) = E.lookupStrNamed env m1
|
adamc@480
|
586 handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
|
adamc@64
|
587
|
adamc@64
|
588 val m1s = if !debug then
|
adamc@64
|
589 m1x ^ "__" ^ Int.toString m1
|
adamc@64
|
590 else
|
adamc@64
|
591 m1x
|
adamc@64
|
592 in
|
adamc@64
|
593 p_list_sep (string ".") string (m1x :: ms @ [x])
|
adamc@64
|
594 end
|
adamc@38
|
595
|
adamc@124
|
596 fun p_vali env (x, n, t, e) = box [p_named x n,
|
adamc@124
|
597 space,
|
adamc@124
|
598 string ":",
|
adamc@124
|
599 space,
|
adamc@124
|
600 p_con env t,
|
adamc@124
|
601 space,
|
adamc@124
|
602 string "=",
|
adamc@124
|
603 space,
|
adamc@124
|
604 p_exp env e]
|
adamc@124
|
605
|
adamc@124
|
606 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@38
|
607 case d of
|
adamc@38
|
608 DCon (x, n, k, c) => box [string "con",
|
adamc@38
|
609 space,
|
adamc@38
|
610 p_named x n,
|
adamc@38
|
611 space,
|
adamc@38
|
612 string "::",
|
adamc@38
|
613 space,
|
adamc@624
|
614 p_kind env k,
|
adamc@38
|
615 space,
|
adamc@38
|
616 string "=",
|
adamc@38
|
617 space,
|
adamc@38
|
618 p_con env c]
|
adamc@806
|
619 | DDatatype x => box [string "datatype",
|
adamc@806
|
620 space,
|
adamc@806
|
621 p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
|
adamc@191
|
622 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
|
adamc@162
|
623 let
|
adamc@162
|
624 val m1x = #1 (E.lookupStrNamed env m1)
|
adamc@162
|
625 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
|
adamc@162
|
626 in
|
adamc@162
|
627 box [string "datatype",
|
adamc@162
|
628 space,
|
adamc@162
|
629 string x,
|
adamc@162
|
630 space,
|
adamc@162
|
631 string "=",
|
adamc@162
|
632 space,
|
adamc@162
|
633 string "datatype",
|
adamc@162
|
634 space,
|
adamc@162
|
635 p_list_sep (string ".") string (m1x :: ms @ [x'])]
|
adamc@162
|
636 end
|
adamc@124
|
637 | DVal vi => box [string "val",
|
adamc@124
|
638 space,
|
adamc@124
|
639 p_vali env vi]
|
adamc@124
|
640 | DValRec vis =>
|
adamc@124
|
641 let
|
adamc@124
|
642 val env = E.declBinds env dAll
|
adamc@124
|
643 in
|
adamc@124
|
644 box [string "val",
|
adamc@124
|
645 space,
|
adamc@124
|
646 string "rec",
|
adamc@124
|
647 space,
|
adamc@124
|
648 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
|
adamc@124
|
649 end
|
adamc@38
|
650
|
adamc@38
|
651 | DSgn (x, n, sgn) => box [string "signature",
|
adamc@38
|
652 space,
|
adamc@38
|
653 p_named x n,
|
adamc@38
|
654 space,
|
adamc@38
|
655 string "=",
|
adamc@38
|
656 space,
|
adamc@38
|
657 p_sgn env sgn]
|
adamc@38
|
658 | DStr (x, n, sgn, str) => box [string "structure",
|
adamc@38
|
659 space,
|
adamc@38
|
660 p_named x n,
|
adamc@38
|
661 space,
|
adamc@38
|
662 string ":",
|
adamc@38
|
663 space,
|
adamc@38
|
664 p_sgn env sgn,
|
adamc@38
|
665 space,
|
adamc@38
|
666 string "=",
|
adamc@38
|
667 space,
|
adamc@38
|
668 p_str env str]
|
adamc@48
|
669 | DFfiStr (x, n, sgn) => box [string "extern",
|
adamc@48
|
670 space,
|
adamc@48
|
671 string "structure",
|
adamc@48
|
672 space,
|
adamc@48
|
673 p_named x n,
|
adamc@48
|
674 space,
|
adamc@48
|
675 string ":",
|
adamc@48
|
676 space,
|
adamc@48
|
677 p_sgn env sgn]
|
adamc@109
|
678 | DExport (_, sgn, str) => box [string "export",
|
adamc@109
|
679 space,
|
adamc@109
|
680 p_str env str,
|
adamc@109
|
681 space,
|
adamc@109
|
682 string ":",
|
adamc@109
|
683 space,
|
adamc@109
|
684 p_sgn env sgn]
|
adamc@707
|
685 | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
|
adamc@707
|
686 space,
|
adamc@707
|
687 p_named x n,
|
adamc@707
|
688 space,
|
adamc@707
|
689 string ":",
|
adamc@707
|
690 space,
|
adamc@707
|
691 p_con env c,
|
adamc@707
|
692 space,
|
adamc@707
|
693 string "keys",
|
adamc@707
|
694 space,
|
adamc@707
|
695 p_exp env pe,
|
adamc@707
|
696 space,
|
adamc@707
|
697 string "constraints",
|
adamc@707
|
698 space,
|
adamc@707
|
699 p_exp env ce]
|
adamc@338
|
700 | DSequence (_, x, n) => box [string "sequence",
|
adamc@338
|
701 space,
|
adamc@338
|
702 p_named x n]
|
adamc@754
|
703 | DView (_, x, n, e, _) => box [string "view",
|
adamc@754
|
704 space,
|
adamc@754
|
705 p_named x n,
|
adamc@754
|
706 space,
|
adamc@754
|
707 string "as",
|
adamc@754
|
708 space,
|
adamc@754
|
709 p_exp env e]
|
adamc@271
|
710 | DDatabase s => box [string "database",
|
adamc@271
|
711 space,
|
adamc@271
|
712 string s]
|
adamc@460
|
713 | DCookie (_, x, n, c) => box [string "cookie",
|
adamc@460
|
714 space,
|
adamc@460
|
715 p_named x n,
|
adamc@460
|
716 space,
|
adamc@460
|
717 string ":",
|
adamc@460
|
718 space,
|
adamc@460
|
719 p_con env c]
|
adamc@720
|
720 | DStyle (_, x, n) => box [string "style",
|
adamc@720
|
721 space,
|
adamc@720
|
722 p_named x n]
|
adamc@1075
|
723 | DTask (e1, e2) => box [string "task",
|
adamc@1073
|
724 space,
|
adamc@1075
|
725 p_exp env e1,
|
adamc@1075
|
726 space,
|
adamc@1075
|
727 string "=",
|
adamc@1075
|
728 space,
|
adamc@1075
|
729 p_exp env e2]
|
adamc@1199
|
730 | DPolicy e1 => box [string "policy",
|
adamc@1199
|
731 space,
|
adamc@1199
|
732 p_exp env e1]
|
adam@1294
|
733 | DOnError _ => string "ONERROR"
|
adamc@38
|
734
|
adamc@38
|
735 and p_str env (str, _) =
|
adamc@38
|
736 case str of
|
adamc@38
|
737 StrConst ds => box [string "struct",
|
adamc@38
|
738 newline,
|
adamc@38
|
739 p_file env ds,
|
adamc@38
|
740 newline,
|
adamc@38
|
741 string "end"]
|
adamc@146
|
742 | StrVar n =>
|
adamc@146
|
743 let
|
adamc@146
|
744 val x = #1 (E.lookupStrNamed env n)
|
adamc@480
|
745 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n
|
adamc@146
|
746
|
adamc@146
|
747 val s = if !debug then
|
adamc@146
|
748 x ^ "__" ^ Int.toString n
|
adamc@146
|
749 else
|
adamc@146
|
750 x
|
adamc@146
|
751 in
|
adamc@146
|
752 string s
|
adamc@146
|
753 end
|
adamc@38
|
754 | StrProj (str, s) => box [p_str env str,
|
adamc@38
|
755 string ".",
|
adamc@38
|
756 string s]
|
adamc@45
|
757 | StrFun (x, n, sgn, sgn', str) =>
|
adamc@45
|
758 let
|
adamc@45
|
759 val env' = E.pushStrNamed env x n sgn
|
adamc@45
|
760 in
|
adamc@45
|
761 box [string "functor",
|
adamc@45
|
762 space,
|
adamc@45
|
763 string "(",
|
adamc@480
|
764 p_named x n,
|
adamc@45
|
765 space,
|
adamc@45
|
766 string ":",
|
adamc@45
|
767 space,
|
adamc@45
|
768 p_sgn env sgn,
|
adamc@45
|
769 string ")",
|
adamc@45
|
770 space,
|
adamc@45
|
771 string ":",
|
adamc@45
|
772 space,
|
adamc@45
|
773 p_sgn env' sgn',
|
adamc@45
|
774 space,
|
adamc@45
|
775 string "=>",
|
adamc@45
|
776 space,
|
adamc@45
|
777 p_str env' str]
|
adamc@45
|
778 end
|
adamc@45
|
779 | StrApp (str1, str2) => box [p_str env str1,
|
adamc@45
|
780 string "(",
|
adamc@45
|
781 p_str env str2,
|
adamc@45
|
782 string ")"]
|
adamc@38
|
783
|
adamc@38
|
784 and p_file env file =
|
adamc@38
|
785 let
|
adamc@38
|
786 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@38
|
787 (p_decl env d,
|
adamc@38
|
788 E.declBinds env d))
|
adamc@38
|
789 env file
|
adamc@38
|
790 in
|
adamc@38
|
791 p_list_sep newline (fn x => x) pds
|
adamc@38
|
792 end
|
adamc@38
|
793
|
adamc@38
|
794 end
|