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@25
|
28 (* Pretty-printing monomorphic Laconic/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@25
|
41 fun p_typ' par env (t, _) =
|
adamc@25
|
42 case t of
|
adamc@25
|
43 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
|
adamc@25
|
44 space,
|
adamc@25
|
45 string "->",
|
adamc@25
|
46 space,
|
adamc@25
|
47 p_typ env t2])
|
adamc@25
|
48 | TRecord xcs => box [string "{",
|
adamc@25
|
49 p_list (fn (x, t) =>
|
adamc@25
|
50 box [string x,
|
adamc@25
|
51 space,
|
adamc@25
|
52 string ":",
|
adamc@25
|
53 space,
|
adamc@25
|
54 p_typ env t]) xcs,
|
adamc@25
|
55 string "}"]
|
adamc@196
|
56 | TDatatype (n, _) =>
|
adamc@178
|
57 ((if !debug then
|
adamc@178
|
58 string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
59 else
|
adamc@178
|
60 string (#1 (E.lookupDatatype env n)))
|
adamc@178
|
61 handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
|
adamc@51
|
62 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@25
|
63
|
adamc@25
|
64 and p_typ env = p_typ' false env
|
adamc@25
|
65
|
adamc@109
|
66 fun p_enamed env n =
|
adamc@178
|
67 (if !debug then
|
adamc@178
|
68 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
69 else
|
adamc@178
|
70 string (#1 (E.lookupENamed env n)))
|
adamc@178
|
71 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
|
adamc@178
|
72
|
adamc@178
|
73 fun p_con_named env n =
|
adamc@178
|
74 (if !debug then
|
adamc@178
|
75 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
|
adamc@178
|
76 else
|
adamc@178
|
77 string (#1 (E.lookupConstructor env n)))
|
adamc@178
|
78 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
|
adamc@178
|
79
|
adamc@178
|
80 fun p_patCon env pc =
|
adamc@178
|
81 case pc of
|
adamc@178
|
82 PConVar n => p_con_named env n
|
adamc@186
|
83 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
|
adamc@185
|
84 string m,
|
adamc@185
|
85 string ".",
|
adamc@185
|
86 string con,
|
adamc@185
|
87 string ")"]
|
adamc@178
|
88
|
adamc@178
|
89 fun p_pat' par env (p, _) =
|
adamc@178
|
90 case p of
|
adamc@178
|
91 PWild => string "_"
|
adamc@182
|
92 | PVar (s, _) => string s
|
adamc@178
|
93 | PPrim p => Prim.p_t p
|
adamc@188
|
94 | PCon (_, n, NONE) => p_patCon env n
|
adamc@188
|
95 | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
|
adamc@178
|
96 space,
|
adamc@178
|
97 p_pat' true env p])
|
adamc@178
|
98 | PRecord xps =>
|
adamc@178
|
99 box [string "{",
|
adamc@182
|
100 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
|
adamc@178
|
101 box [string x,
|
adamc@178
|
102 space,
|
adamc@178
|
103 string "=",
|
adamc@178
|
104 space,
|
adamc@178
|
105 p_pat env p]) xps,
|
adamc@178
|
106 string "}"]
|
adamc@178
|
107
|
adamc@178
|
108 and p_pat x = p_pat' false x
|
adamc@109
|
109
|
adamc@25
|
110 fun p_exp' par env (e, _) =
|
adamc@25
|
111 case e of
|
adamc@25
|
112 EPrim p => Prim.p_t p
|
adamc@25
|
113 | ERel n =>
|
adamc@178
|
114 ((if !debug then
|
adamc@178
|
115 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
|
adamc@178
|
116 else
|
adamc@178
|
117 string (#1 (E.lookupERel env n)))
|
adamc@178
|
118 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
|
adamc@109
|
119 | ENamed n => p_enamed env n
|
adamc@188
|
120 | ECon (_, pc, NONE) => p_patCon env pc
|
adamc@188
|
121 | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
|
adamc@188
|
122 space,
|
adamc@188
|
123 p_exp' true env e])
|
adamc@109
|
124
|
adamc@51
|
125 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
|
adamc@51
|
126 | EFfiApp (m, x, es) => box [string "FFI(",
|
adamc@51
|
127 string m,
|
adamc@51
|
128 string ".",
|
adamc@51
|
129 string x,
|
adamc@51
|
130 string "(",
|
adamc@51
|
131 p_list (p_exp env) es,
|
adamc@51
|
132 string "))"]
|
adamc@25
|
133 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
|
adamc@25
|
134 space,
|
adamc@25
|
135 p_exp' true env e2])
|
adamc@26
|
136 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
|
adamc@26
|
137 space,
|
adamc@26
|
138 string x,
|
adamc@26
|
139 space,
|
adamc@26
|
140 string ":",
|
adamc@26
|
141 space,
|
adamc@26
|
142 p_typ env t,
|
adamc@26
|
143 space,
|
adamc@26
|
144 string "=>",
|
adamc@26
|
145 space,
|
adamc@183
|
146 p_exp (E.pushERel env x t NONE) e])
|
adamc@25
|
147
|
adamc@25
|
148 | ERecord xes => box [string "{",
|
adamc@29
|
149 p_list (fn (x, e, _) =>
|
adamc@25
|
150 box [string x,
|
adamc@25
|
151 space,
|
adamc@25
|
152 string "=",
|
adamc@25
|
153 space,
|
adamc@25
|
154 p_exp env e]) xes,
|
adamc@25
|
155 string "}"]
|
adamc@25
|
156 | EField (e, x) =>
|
adamc@25
|
157 box [p_exp' true env e,
|
adamc@25
|
158 string ".",
|
adamc@25
|
159 string x]
|
adamc@25
|
160
|
adamc@178
|
161 | ECase (e, pes, _) => parenIf par (box [string "case",
|
adamc@178
|
162 space,
|
adamc@178
|
163 p_exp env e,
|
adamc@178
|
164 space,
|
adamc@178
|
165 string "of",
|
adamc@178
|
166 space,
|
adamc@178
|
167 p_list_sep (box [space, string "|", space])
|
adamc@178
|
168 (fn (p, e) => box [p_pat env p,
|
adamc@178
|
169 space,
|
adamc@178
|
170 string "=>",
|
adamc@178
|
171 space,
|
adamc@179
|
172 p_exp (E.patBinds env p) e]) pes])
|
adamc@94
|
173
|
adamc@94
|
174 | EStrcat (e1, e2) => box [p_exp' true env e1,
|
adamc@94
|
175 space,
|
adamc@102
|
176 string "^",
|
adamc@94
|
177 space,
|
adamc@94
|
178 p_exp' true env e2]
|
adamc@94
|
179
|
adamc@102
|
180 | EWrite e => box [string "write(",
|
adamc@102
|
181 p_exp env e,
|
adamc@102
|
182 string ")"]
|
adamc@102
|
183
|
adamc@106
|
184 | ESeq (e1, e2) => box [p_exp env e1,
|
adamc@106
|
185 string ";",
|
adamc@106
|
186 space,
|
adamc@106
|
187 p_exp env e2]
|
adamc@106
|
188
|
adamc@111
|
189 | EClosure (n, es) => box [string "CLOSURE(",
|
adamc@111
|
190 p_enamed env n,
|
adamc@111
|
191 p_list_sep (string "") (fn e => box [string ", ",
|
adamc@111
|
192 p_exp env e]) es,
|
adamc@111
|
193 string ")"]
|
adamc@111
|
194
|
adamc@25
|
195 and p_exp env = p_exp' false env
|
adamc@25
|
196
|
adamc@126
|
197 fun p_vali env (x, n, t, e, s) =
|
adamc@126
|
198 let
|
adamc@126
|
199 val xp = if !debug then
|
adamc@126
|
200 box [string x,
|
adamc@126
|
201 string "__",
|
adamc@126
|
202 string (Int.toString n)]
|
adamc@126
|
203 else
|
adamc@126
|
204 string x
|
adamc@126
|
205 in
|
adamc@126
|
206 box [xp,
|
adamc@126
|
207 space,
|
adamc@126
|
208 string "as",
|
adamc@126
|
209 space,
|
adamc@126
|
210 string s,
|
adamc@126
|
211 space,
|
adamc@126
|
212 string ":",
|
adamc@126
|
213 space,
|
adamc@126
|
214 p_typ env t,
|
adamc@126
|
215 space,
|
adamc@126
|
216 string "=",
|
adamc@126
|
217 space,
|
adamc@126
|
218 p_exp env e]
|
adamc@126
|
219 end
|
adamc@126
|
220
|
adamc@164
|
221 fun p_datatype env (x, n, cons) =
|
adamc@164
|
222 let
|
adamc@168
|
223 val env = E.pushDatatype env x n cons
|
adamc@164
|
224 in
|
adamc@164
|
225 box [string "datatype",
|
adamc@164
|
226 space,
|
adamc@164
|
227 string x,
|
adamc@164
|
228 space,
|
adamc@164
|
229 string "=",
|
adamc@164
|
230 space,
|
adamc@164
|
231 p_list_sep (box [space, string "|", space])
|
adamc@164
|
232 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
233 else string x
|
adamc@164
|
234 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
|
adamc@164
|
235 else string x, space, string "of", space, p_typ env t])
|
adamc@164
|
236 cons]
|
adamc@164
|
237 end
|
adamc@164
|
238
|
adamc@126
|
239 fun p_decl env (dAll as (d, _) : decl) =
|
adamc@25
|
240 case d of
|
adamc@164
|
241 DDatatype x => p_datatype env x
|
adamc@164
|
242 | DVal vi => box [string "val",
|
adamc@126
|
243 space,
|
adamc@126
|
244 p_vali env vi]
|
adamc@126
|
245 | DValRec vis =>
|
adamc@25
|
246 let
|
adamc@126
|
247 val env = E.declBinds env dAll
|
adamc@25
|
248 in
|
adamc@25
|
249 box [string "val",
|
adamc@25
|
250 space,
|
adamc@126
|
251 string "rec",
|
adamc@25
|
252 space,
|
adamc@126
|
253 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
|
adamc@25
|
254 end
|
adamc@109
|
255
|
adamc@144
|
256 | DExport (ek, s, n, ts) => box [string "export",
|
adamc@144
|
257 space,
|
adamc@144
|
258 CorePrint.p_export_kind ek,
|
adamc@144
|
259 space,
|
adamc@144
|
260 p_enamed env n,
|
adamc@144
|
261 space,
|
adamc@144
|
262 string "as",
|
adamc@144
|
263 space,
|
adamc@144
|
264 string s,
|
adamc@144
|
265 p_list_sep (string "") (fn t => box [space,
|
adamc@144
|
266 string "(",
|
adamc@144
|
267 p_typ env t,
|
adamc@144
|
268 string ")"]) ts]
|
adamc@100
|
269
|
adamc@25
|
270 fun p_file env file =
|
adamc@25
|
271 let
|
adamc@31
|
272 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
|
adamc@31
|
273 (p_decl env d,
|
adamc@31
|
274 E.declBinds env d))
|
adamc@25
|
275 env file
|
adamc@25
|
276 in
|
adamc@25
|
277 p_list_sep newline (fn x => x) pds
|
adamc@25
|
278 end
|
adamc@25
|
279
|
adamc@25
|
280 end
|