adamc@1
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@1
|
2 * All rights reserved.
|
adamc@1
|
3 *
|
adamc@1
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@1
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@1
|
6 *
|
adamc@1
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@1
|
8 * this list of conditions and the following disclaimer.
|
adamc@1
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@1
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@1
|
11 * and/or other materials provided with the distribution.
|
adamc@1
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@1
|
13 * derived from this software without specific prior written permission.
|
adamc@1
|
14 *
|
adamc@1
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@1
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@1
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@1
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@1
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@1
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@1
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@1
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@1
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@1
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@1
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@1
|
26 *)
|
adamc@1
|
27
|
adamc@1
|
28 (* Pretty-printing Laconic/Web *)
|
adamc@1
|
29
|
adamc@4
|
30 structure SourcePrint :> SOURCE_PRINT = struct
|
adamc@1
|
31
|
adamc@1
|
32 open Print.PD
|
adamc@1
|
33 open Print
|
adamc@1
|
34
|
adamc@4
|
35 open Source
|
adamc@1
|
36
|
adamc@1
|
37 fun p_kind' par (k, _) =
|
adamc@1
|
38 case k of
|
adamc@1
|
39 KType => string "Type"
|
adamc@1
|
40 | KArrow (k1, k2) => parenIf par (box [p_kind' true k1,
|
adamc@1
|
41 space,
|
adamc@1
|
42 string "->",
|
adamc@1
|
43 space,
|
adamc@1
|
44 p_kind k2])
|
adamc@1
|
45 | KName => string "Name"
|
adamc@1
|
46 | KRecord k => box [string "{", p_kind k, string "}"]
|
adamc@82
|
47 | KUnit => string "Unit"
|
adamc@18
|
48 | KWild => string "_"
|
adamc@1
|
49
|
adamc@1
|
50 and p_kind k = p_kind' false k
|
adamc@1
|
51
|
adamc@1
|
52 fun p_explicitness e =
|
adamc@1
|
53 case e of
|
adamc@1
|
54 Explicit => string "::"
|
adamc@1
|
55 | Implicit => string ":::"
|
adamc@1
|
56
|
adamc@1
|
57 fun p_con' par (c, _) =
|
adamc@1
|
58 case c of
|
adamc@1
|
59 CAnnot (c, k) => box [string "(",
|
adamc@1
|
60 p_con c,
|
adamc@1
|
61 space,
|
adamc@1
|
62 string "::",
|
adamc@1
|
63 space,
|
adamc@1
|
64 p_kind k,
|
adamc@1
|
65 string ")"]
|
adamc@1
|
66
|
adamc@1
|
67 | TFun (t1, t2) => parenIf par (box [p_con' true t1,
|
adamc@1
|
68 space,
|
adamc@1
|
69 string "->",
|
adamc@1
|
70 space,
|
adamc@1
|
71 p_con t2])
|
adamc@1
|
72 | TCFun (e, x, k, c) => parenIf par (box [string x,
|
adamc@1
|
73 space,
|
adamc@1
|
74 p_explicitness e,
|
adamc@1
|
75 space,
|
adamc@1
|
76 p_kind k,
|
adamc@1
|
77 space,
|
adamc@1
|
78 string "->",
|
adamc@1
|
79 space,
|
adamc@1
|
80 p_con c])
|
adamc@1
|
81 | TRecord (CRecord xcs, _) => box [string "{",
|
adamc@1
|
82 p_list (fn (x, c) =>
|
adamc@20
|
83 box [p_name x,
|
adamc@1
|
84 space,
|
adamc@1
|
85 string ":",
|
adamc@1
|
86 space,
|
adamc@1
|
87 p_con c]) xcs,
|
adamc@1
|
88 string "}"]
|
adamc@1
|
89 | TRecord c => box [string "$",
|
adamc@1
|
90 p_con' true c]
|
adamc@1
|
91
|
adamc@34
|
92 | CVar (ss, s) => p_list_sep (string ".") string (ss @ [s])
|
adamc@1
|
93 | CApp (c1, c2) => parenIf par (box [p_con c1,
|
adamc@1
|
94 space,
|
adamc@1
|
95 p_con' true c2])
|
adamc@67
|
96 | CAbs (x, NONE, c) => parenIf par (box [string "fn",
|
adamc@67
|
97 space,
|
adamc@67
|
98 string x,
|
adamc@67
|
99 space,
|
adamc@67
|
100 string "=>",
|
adamc@67
|
101 space,
|
adamc@67
|
102 p_con c])
|
adamc@67
|
103 | CAbs (x, SOME k, c) => parenIf par (box [string "fn",
|
adamc@67
|
104 space,
|
adamc@67
|
105 string x,
|
adamc@67
|
106 space,
|
adamc@67
|
107 string "::",
|
adamc@67
|
108 space,
|
adamc@67
|
109 p_kind k,
|
adamc@67
|
110 space,
|
adamc@67
|
111 string "=>",
|
adamc@67
|
112 space,
|
adamc@67
|
113 p_con c])
|
adamc@84
|
114 | CDisjoint (c1, c2, c3) => parenIf par (box [p_con c1,
|
adamc@84
|
115 space,
|
adamc@84
|
116 string "~",
|
adamc@84
|
117 space,
|
adamc@84
|
118 p_con c2,
|
adamc@84
|
119 space,
|
adamc@84
|
120 string "=>",
|
adamc@84
|
121 space,
|
adamc@84
|
122 p_con c3])
|
adamc@1
|
123
|
adamc@1
|
124 | CName s => box [string "#", string s]
|
adamc@1
|
125
|
adamc@1
|
126 | CRecord xcs => box [string "[",
|
adamc@1
|
127 p_list (fn (x, c) =>
|
adamc@1
|
128 box [p_con x,
|
adamc@1
|
129 space,
|
adamc@1
|
130 string "=",
|
adamc@1
|
131 space,
|
adamc@1
|
132 p_con c]) xcs,
|
adamc@1
|
133 string "]"]
|
adamc@1
|
134 | CConcat (c1, c2) => parenIf par (box [p_con' true c1,
|
adamc@1
|
135 space,
|
adamc@1
|
136 string "++",
|
adamc@1
|
137 space,
|
adamc@1
|
138 p_con c2])
|
adamc@67
|
139 | CFold => string "fold"
|
adamc@82
|
140
|
adamc@82
|
141 | CUnit => string "()"
|
adamc@82
|
142
|
adamc@18
|
143 | CWild k => box [string "(_",
|
adamc@18
|
144 space,
|
adamc@18
|
145 string "::",
|
adamc@18
|
146 space,
|
adamc@18
|
147 p_kind k]
|
adamc@1
|
148
|
adamc@1
|
149 and p_con c = p_con' false c
|
adamc@1
|
150
|
adamc@20
|
151 and p_name (all as (c, _)) =
|
adamc@20
|
152 case c of
|
adamc@20
|
153 CName s => string s
|
adamc@20
|
154 | _ => p_con all
|
adamc@20
|
155
|
adamc@8
|
156 fun p_exp' par (e, _) =
|
adamc@8
|
157 case e of
|
adamc@8
|
158 EAnnot (e, t) => box [string "(",
|
adamc@8
|
159 p_exp e,
|
adamc@8
|
160 space,
|
adamc@8
|
161 string ":",
|
adamc@8
|
162 space,
|
adamc@8
|
163 p_con t,
|
adamc@8
|
164 string ")"]
|
adamc@8
|
165
|
adamc@14
|
166 | EPrim p => Prim.p_t p
|
adamc@34
|
167 | EVar (ss, s) => p_list_sep (string ".") string (ss @ [s])
|
adamc@8
|
168 | EApp (e1, e2) => parenIf par (box [p_exp e1,
|
adamc@8
|
169 space,
|
adamc@8
|
170 p_exp' true e2])
|
adamc@8
|
171 | EAbs (x, NONE, e) => parenIf par (box [string "fn",
|
adamc@8
|
172 space,
|
adamc@8
|
173 string x,
|
adamc@8
|
174 space,
|
adamc@8
|
175 string "=>",
|
adamc@8
|
176 space,
|
adamc@8
|
177 p_exp e])
|
adamc@8
|
178 | EAbs (x, SOME t, e) => parenIf par (box [string "fn",
|
adamc@8
|
179 space,
|
adamc@8
|
180 string x,
|
adamc@8
|
181 space,
|
adamc@8
|
182 string ":",
|
adamc@8
|
183 space,
|
adamc@8
|
184 p_con t,
|
adamc@8
|
185 space,
|
adamc@8
|
186 string "=>",
|
adamc@8
|
187 space,
|
adamc@8
|
188 p_exp e])
|
adamc@8
|
189 | ECApp (e, c) => parenIf par (box [p_exp e,
|
adamc@8
|
190 space,
|
adamc@8
|
191 string "[",
|
adamc@8
|
192 p_con c,
|
adamc@8
|
193 string "]"])
|
adamc@8
|
194 | ECAbs (exp, x, k, e) => parenIf par (box [string "fn",
|
adamc@8
|
195 space,
|
adamc@8
|
196 string x,
|
adamc@8
|
197 space,
|
adamc@8
|
198 p_explicitness exp,
|
adamc@8
|
199 space,
|
adamc@8
|
200 p_kind k,
|
adamc@8
|
201 space,
|
adamc@8
|
202 string "=>",
|
adamc@8
|
203 space,
|
adamc@8
|
204 p_exp e])
|
adamc@8
|
205
|
adamc@12
|
206 | ERecord xes => box [string "{",
|
adamc@12
|
207 p_list (fn (x, e) =>
|
adamc@21
|
208 box [p_name x,
|
adamc@12
|
209 space,
|
adamc@12
|
210 string "=",
|
adamc@12
|
211 space,
|
adamc@12
|
212 p_exp e]) xes,
|
adamc@12
|
213 string "}"]
|
adamc@12
|
214 | EField (e, c) => box [p_exp' true e,
|
adamc@12
|
215 string ".",
|
adamc@12
|
216 p_con' true c]
|
adamc@71
|
217 | EFold => string "fold"
|
adamc@12
|
218
|
adamc@8
|
219 and p_exp e = p_exp' false e
|
adamc@8
|
220
|
adamc@30
|
221 fun p_sgn_item (sgi, _) =
|
adamc@30
|
222 case sgi of
|
adamc@30
|
223 SgiConAbs (x, k) => box [string "con",
|
adamc@30
|
224 space,
|
adamc@30
|
225 string x,
|
adamc@30
|
226 space,
|
adamc@30
|
227 string "::",
|
adamc@30
|
228 space,
|
adamc@30
|
229 p_kind k]
|
adamc@30
|
230 | SgiCon (x, NONE, c) => box [string "con",
|
adamc@30
|
231 space,
|
adamc@30
|
232 string x,
|
adamc@30
|
233 space,
|
adamc@30
|
234 string "=",
|
adamc@30
|
235 space,
|
adamc@30
|
236 p_con c]
|
adamc@30
|
237 | SgiCon (x, SOME k, c) => box [string "con",
|
adamc@30
|
238 space,
|
adamc@30
|
239 string x,
|
adamc@30
|
240 space,
|
adamc@30
|
241 string "::",
|
adamc@30
|
242 space,
|
adamc@30
|
243 p_kind k,
|
adamc@30
|
244 space,
|
adamc@30
|
245 string "=",
|
adamc@30
|
246 space,
|
adamc@30
|
247 p_con c]
|
adamc@30
|
248 | SgiVal (x, c) => box [string "val",
|
adamc@30
|
249 space,
|
adamc@30
|
250 string x,
|
adamc@30
|
251 space,
|
adamc@30
|
252 string ":",
|
adamc@30
|
253 space,
|
adamc@30
|
254 p_con c]
|
adamc@30
|
255 | SgiStr (x, sgn) => box [string "structure",
|
adamc@30
|
256 space,
|
adamc@30
|
257 string x,
|
adamc@30
|
258 space,
|
adamc@30
|
259 string ":",
|
adamc@30
|
260 space,
|
adamc@30
|
261 p_sgn sgn]
|
adamc@59
|
262 | SgiSgn (x, sgn) => box [string "signature",
|
adamc@59
|
263 space,
|
adamc@59
|
264 string x,
|
adamc@59
|
265 space,
|
adamc@59
|
266 string "=",
|
adamc@59
|
267 space,
|
adamc@59
|
268 p_sgn sgn]
|
adamc@58
|
269 | SgiInclude sgn => box [string "include",
|
adamc@58
|
270 space,
|
adamc@58
|
271 p_sgn sgn]
|
adamc@30
|
272
|
adamc@30
|
273 and p_sgn (sgn, _) =
|
adamc@30
|
274 case sgn of
|
adamc@30
|
275 SgnConst sgis => box [string "sig",
|
adamc@30
|
276 newline,
|
adamc@30
|
277 p_list_sep newline p_sgn_item sgis,
|
adamc@30
|
278 newline,
|
adamc@30
|
279 string "end"]
|
adamc@30
|
280 | SgnVar x => string x
|
adamc@40
|
281 | SgnFun (x, sgn, sgn') => box [string "functor",
|
adamc@40
|
282 space,
|
adamc@40
|
283 string "(",
|
adamc@40
|
284 string x,
|
adamc@40
|
285 space,
|
adamc@40
|
286 string ":",
|
adamc@40
|
287 p_sgn sgn,
|
adamc@40
|
288 string ")",
|
adamc@40
|
289 space,
|
adamc@40
|
290 string ":",
|
adamc@40
|
291 space,
|
adamc@40
|
292 p_sgn sgn']
|
adamc@42
|
293 | SgnWhere (sgn, x, c) => box [p_sgn sgn,
|
adamc@42
|
294 space,
|
adamc@42
|
295 string "where",
|
adamc@42
|
296 space,
|
adamc@42
|
297 string "con",
|
adamc@42
|
298 space,
|
adamc@42
|
299 string x,
|
adamc@42
|
300 space,
|
adamc@42
|
301 string "=",
|
adamc@42
|
302 space,
|
adamc@42
|
303 p_con c]
|
adamc@59
|
304 | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x])
|
adamc@59
|
305
|
adamc@42
|
306
|
adamc@1
|
307 fun p_decl ((d, _) : decl) =
|
adamc@1
|
308 case d of
|
adamc@1
|
309 DCon (x, NONE, c) => box [string "con",
|
adamc@1
|
310 space,
|
adamc@1
|
311 string x,
|
adamc@1
|
312 space,
|
adamc@1
|
313 string "=",
|
adamc@1
|
314 space,
|
adamc@1
|
315 p_con c]
|
adamc@1
|
316 | DCon (x, SOME k, c) => box [string "con",
|
adamc@1
|
317 space,
|
adamc@1
|
318 string x,
|
adamc@1
|
319 space,
|
adamc@1
|
320 string "::",
|
adamc@1
|
321 space,
|
adamc@1
|
322 p_kind k,
|
adamc@1
|
323 space,
|
adamc@1
|
324 string "=",
|
adamc@1
|
325 space,
|
adamc@1
|
326 p_con c]
|
adamc@8
|
327 | DVal (x, NONE, e) => box [string "val",
|
adamc@8
|
328 space,
|
adamc@8
|
329 string x,
|
adamc@8
|
330 space,
|
adamc@8
|
331 string "=",
|
adamc@8
|
332 space,
|
adamc@8
|
333 p_exp e]
|
adamc@8
|
334 | DVal (x, SOME t, e) => box [string "val",
|
adamc@8
|
335 space,
|
adamc@8
|
336 string x,
|
adamc@8
|
337 space,
|
adamc@8
|
338 string ":",
|
adamc@8
|
339 space,
|
adamc@8
|
340 p_con t,
|
adamc@8
|
341 space,
|
adamc@8
|
342 string "=",
|
adamc@8
|
343 space,
|
adamc@8
|
344 p_exp e]
|
adamc@1
|
345
|
adamc@30
|
346 | DSgn (x, sgn) => box [string "signature",
|
adamc@30
|
347 space,
|
adamc@30
|
348 string x,
|
adamc@30
|
349 space,
|
adamc@30
|
350 string "=",
|
adamc@30
|
351 space,
|
adamc@30
|
352 p_sgn sgn]
|
adamc@30
|
353 | DStr (x, NONE, str) => box [string "structure",
|
adamc@30
|
354 space,
|
adamc@30
|
355 string x,
|
adamc@30
|
356 space,
|
adamc@30
|
357 string "=",
|
adamc@30
|
358 space,
|
adamc@30
|
359 p_str str]
|
adamc@30
|
360 | DStr (x, SOME sgn, str) => box [string "structure",
|
adamc@30
|
361 space,
|
adamc@30
|
362 string x,
|
adamc@30
|
363 space,
|
adamc@30
|
364 string ":",
|
adamc@30
|
365 space,
|
adamc@30
|
366 p_sgn sgn,
|
adamc@30
|
367 space,
|
adamc@30
|
368 string "=",
|
adamc@30
|
369 space,
|
adamc@30
|
370 p_str str]
|
adamc@48
|
371 | DFfiStr (x, sgn) => box [string "extern",
|
adamc@48
|
372 space,
|
adamc@48
|
373 string "structure",
|
adamc@48
|
374 space,
|
adamc@48
|
375 string x,
|
adamc@48
|
376 space,
|
adamc@48
|
377 string ":",
|
adamc@48
|
378 space,
|
adamc@48
|
379 p_sgn sgn]
|
adamc@61
|
380 | DOpen (m, ms) => box [string "open",
|
adamc@61
|
381 space,
|
adamc@61
|
382 p_list_sep (string ".") string (m :: ms)]
|
adamc@30
|
383
|
adamc@30
|
384 and p_str (str, _) =
|
adamc@30
|
385 case str of
|
adamc@30
|
386 StrConst ds => box [string "struct",
|
adamc@30
|
387 newline,
|
adamc@30
|
388 p_list_sep newline p_decl ds,
|
adamc@30
|
389 newline,
|
adamc@30
|
390 string "end"]
|
adamc@30
|
391 | StrVar x => string x
|
adamc@34
|
392 | StrProj (str, x) => box [p_str str,
|
adamc@34
|
393 string ".",
|
adamc@34
|
394 string x]
|
adamc@40
|
395 | StrFun (x, sgn, NONE, str) => box [string "functor",
|
adamc@40
|
396 space,
|
adamc@40
|
397 string "(",
|
adamc@40
|
398 string x,
|
adamc@40
|
399 space,
|
adamc@40
|
400 string ":",
|
adamc@40
|
401 p_sgn sgn,
|
adamc@40
|
402 string ")",
|
adamc@40
|
403 space,
|
adamc@40
|
404 string "=>",
|
adamc@40
|
405 space,
|
adamc@40
|
406 p_str str]
|
adamc@40
|
407 | StrFun (x, sgn, SOME sgn', str) => box [string "functor",
|
adamc@40
|
408 space,
|
adamc@40
|
409 string "(",
|
adamc@40
|
410 string x,
|
adamc@40
|
411 space,
|
adamc@40
|
412 string ":",
|
adamc@40
|
413 p_sgn sgn,
|
adamc@40
|
414 string ")",
|
adamc@40
|
415 space,
|
adamc@40
|
416 string ":",
|
adamc@40
|
417 space,
|
adamc@40
|
418 p_sgn sgn',
|
adamc@40
|
419 space,
|
adamc@40
|
420 string "=>",
|
adamc@40
|
421 space,
|
adamc@40
|
422 p_str str]
|
adamc@44
|
423 | StrApp (str1, str2) => box [p_str str1,
|
adamc@44
|
424 string "(",
|
adamc@44
|
425 p_str str2,
|
adamc@44
|
426 string ")"]
|
adamc@30
|
427
|
adamc@1
|
428 val p_file = p_list_sep newline p_decl
|
adamc@1
|
429
|
adamc@1
|
430 end
|