Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* pp.sml |
2 | * 2005 Matthew Fluet (mfluet@acm.org) | |
3 | * Adapted for MLton. | |
4 | *) | |
5 | ||
6 | (* | |
7 | * pp.sml - Some simple pretty-printing infrastructure for the ml-ffigen | |
8 | * program. | |
9 | * | |
10 | * (C) 2001, Lucent Technologies, Bell Labs | |
11 | * | |
12 | * author: Matthias Blume (blume@research.bell-labs.com) | |
13 | *) | |
14 | structure PrettyPrint = struct | |
15 | ||
16 | structure PP = PPStreamFn (structure Token = StringToken | |
17 | structure Device = CPIFDev) | |
18 | ||
19 | datatype mltype = | |
20 | ARROW of mltype * mltype | |
21 | | TUPLE of mltype list | |
22 | | CON of string * mltype list | |
23 | | RECORD of (string * mltype) list | |
24 | ||
25 | val Unit = TUPLE [] | |
26 | fun Type t = CON (t, []) | |
27 | fun St tag = Type (concat ["ST_", tag, ".tag"]) | |
28 | fun Un tag = Type (concat ["UT_", tag, ".tag"]) | |
29 | fun En tag = Type (concat ["ET_", tag, ".tag"]) | |
30 | ||
31 | datatype tcontext = C_STAR | C_ARROW | C_COMMA | C_CON | |
32 | ||
33 | fun simplify (CON ("unit", [])) = Unit | |
34 | | simplify (TUPLE [t]) = simplify t | |
35 | | simplify (CON (k, tl)) = | |
36 | let | |
37 | fun doDefault () = CON (k, map simplify tl) | |
38 | fun doObj obj = | |
39 | case tl of | |
40 | [CON (k, tl), c] => | |
41 | if List.exists (fn k' => k = k') | |
42 | ["schar","uchar","sshort","ushort", | |
43 | "sint","uint","slong","ulong", | |
44 | "slonglong","ulonglong","float","double", | |
45 | "voidptr"] | |
46 | then CON (concat [k, "_", obj], [simplify c]) | |
47 | else if k = "fptr" | |
48 | then case tl of | |
49 | [f] => CON ("fptr_" ^ obj, [simplify f, simplify c]) | |
50 | | _ => doDefault () | |
51 | else if k = "su" | |
52 | then case tl of | |
53 | [su] => CON ("su_" ^ obj, [simplify su, simplify c]) | |
54 | | _ => doDefault () | |
55 | else doDefault () | |
56 | | _ => doDefault () | |
57 | fun doDim d = | |
58 | if d = "dim" | |
59 | then case tl of | |
60 | [n, CON (k', [])] => | |
61 | if k' = "Dim.nonzero" orelse k' = "nonzero" | |
62 | then CON ("dim", [simplify n]) | |
63 | else doDefault () | |
64 | | _ => doDefault () | |
65 | else if d = "dec" | |
66 | then case tl of | |
67 | [] => CON ("dec", []) | |
68 | | _ => doDefault () | |
69 | else if List.exists (fn d' => d = d') | |
70 | ["dg0","dg1","dg2","dg3","dg4", | |
71 | "dg5","dg6","dg7","dg8","dg9"] | |
72 | then case tl of | |
73 | [n] => CON (d, [simplify n]) | |
74 | | _ => doDefault () | |
75 | else doDefault () | |
76 | in | |
77 | if k = "obj" orelse k = "obj'" | |
78 | then doObj k | |
79 | else if String.isPrefix "Dim." k | |
80 | then doDim (String.extract(k,4,NONE)) | |
81 | else doDefault () | |
82 | end | |
83 | | simplify (ARROW (t1, t2)) = ARROW (simplify t1, simplify t2) | |
84 | | simplify (TUPLE tl) = TUPLE (map simplify tl) | |
85 | | simplify (RECORD ml) = RECORD (map (fn (n, t) => (n, simplify t)) ml) | |
86 | ||
87 | fun ppType0 s (t as ARROW _, c) = | |
88 | let fun loop (ARROW (x, y)) = | |
89 | (ppType0 s (x, C_ARROW); PP.string s " ->"; PP.space s 1; | |
90 | loop y) | |
91 | | loop t = ppType0 s (t, C_ARROW) | |
92 | val paren = not (c = C_COMMA) | |
93 | val indent = if paren then 5 else 4 | |
94 | in | |
95 | PP.openHOVBox s (PP.Rel indent); | |
96 | if paren then PP.string s "(" else (); | |
97 | loop t; | |
98 | if paren then PP.string s ")" else (); | |
99 | PP.closeBox s | |
100 | end | |
101 | | ppType0 s (TUPLE [], _) = PP.string s "unit" | |
102 | | ppType0 s (TUPLE [t], c) = ppType0 s (t, c) | |
103 | | ppType0 s (TUPLE tl, c) = let | |
104 | fun loop [] = () (* cannot happen *) | |
105 | | loop [t] = ppType0 s (t, C_STAR) | |
106 | | loop (h :: tl) = (ppType0 s (h, C_STAR); | |
107 | PP.string s " *"; | |
108 | PP.space s 1; | |
109 | loop tl) | |
110 | val paren = | |
111 | case c of (C_STAR) => true | |
112 | | (C_CON) => true | |
113 | | (C_ARROW) => false | |
114 | | (C_COMMA) => false | |
115 | val indent = if paren then 1 else 0 | |
116 | in | |
117 | PP.openHVBox s (PP.Rel indent); | |
118 | if paren then PP.string s "(" else (); | |
119 | loop tl; | |
120 | if paren then PP.string s ")" else (); | |
121 | PP.closeBox s | |
122 | end | |
123 | | ppType0 s (RECORD [], _) = PP.string s "{}" | |
124 | | ppType0 s (RECORD tl, _) = let | |
125 | fun loop [] = () (* cannot happen *) | |
126 | | loop [(n, t)] = (PP.string s (n ^ " : "); | |
127 | ppType0 s (t, C_COMMA)) | |
128 | | loop ((n, t) :: tl) = (PP.string s (n ^ " : "); | |
129 | ppType0 s (t, C_COMMA); | |
130 | PP.string s ","; | |
131 | PP.space s 1; | |
132 | loop tl) | |
133 | in | |
134 | PP.openHVBox s (PP.Rel 2); | |
135 | PP.string s "{ "; | |
136 | loop tl; | |
137 | PP.string s " }"; | |
138 | PP.closeBox s | |
139 | end | |
140 | | ppType0 s (CON (k, []), _) = PP.string s k | |
141 | | ppType0 s (CON (k, [t]), _) = | |
142 | (PP.openHBox s; | |
143 | ppType0 s (t, C_CON); | |
144 | PP.space s 1; | |
145 | PP.string s k; | |
146 | PP.closeBox s) | |
147 | | ppType0 s (CON (k, tl), _) = let | |
148 | fun loop [] = () (* cannot happen *) | |
149 | | loop [t] = ppType0 s (t, C_COMMA) | |
150 | | loop (h :: tl) = | |
151 | (ppType0 s (h, C_COMMA); PP.string s ","; PP.space s 1; loop tl) | |
152 | in | |
153 | PP.openHBox s; | |
154 | PP.openHVBox s (PP.Rel 1); | |
155 | PP.string s "("; | |
156 | loop tl; | |
157 | PP.string s ")"; | |
158 | PP.closeBox s; | |
159 | PP.space s 1; | |
160 | PP.string s k; | |
161 | PP.closeBox s | |
162 | end | |
163 | ||
164 | (* start with comma context *) | |
165 | fun ppType s t = ppType0 s (simplify t, C_COMMA) | |
166 | fun ppType' s (t, c) = ppType0 s (simplify t, c) | |
167 | ||
168 | datatype mlexp = | |
169 | ETUPLE of mlexp list | |
170 | | ERECORD of (string * mlexp) list | |
171 | | EVAR of string | |
172 | | EAPP of mlexp * mlexp | |
173 | | ECONSTR of mlexp * mltype | |
174 | | ESEQ of mlexp * mlexp | |
175 | | EPRIM of string * mltype | |
176 | | ELET of (string * mlexp) list * mlexp | |
177 | ||
178 | datatype econtext = EC_APP | EC_COMMA | |
179 | ||
180 | fun ppExp0 s (ETUPLE [], _) = PP.string s "()" | |
181 | | ppExp0 s (ETUPLE [x], c) = ppExp0 s (x, c) | |
182 | | ppExp0 s (ETUPLE xl, _) = let | |
183 | fun loop [] = () | |
184 | | loop [x] = ppExp0 s (x, EC_COMMA) | |
185 | | loop (x :: xl) = | |
186 | (ppExp0 s (x, EC_COMMA); PP.string s ","; PP.space s 1; | |
187 | loop xl) | |
188 | in | |
189 | PP.openHVBox s (PP.Rel 1); | |
190 | PP.string s "("; | |
191 | loop xl; | |
192 | PP.string s ")"; | |
193 | PP.closeBox s | |
194 | end | |
195 | | ppExp0 s (ERECORD [], _) = PP.string s "{}" | |
196 | | ppExp0 s (ERECORD xl, _) = let | |
197 | fun loop [] = () | |
198 | | loop [(n, x)] = (PP.string s (n ^ " ="); | |
199 | PP.space s 1; | |
200 | ppExp0 s (x, EC_COMMA)) | |
201 | | loop ((n, x) :: xl) = (PP.string s (n ^ " ="); | |
202 | PP.space s 1; | |
203 | ppExp0 s (x, EC_COMMA); | |
204 | PP.string s ","; | |
205 | PP.space s 1; | |
206 | loop xl) | |
207 | in | |
208 | PP.openHVBox s (PP.Rel 2); | |
209 | PP.string s "{ "; | |
210 | loop xl; | |
211 | PP.string s " }"; | |
212 | PP.closeBox s | |
213 | end | |
214 | | ppExp0 s (EVAR v, _) = PP.string s v | |
215 | | ppExp0 s (EAPP (x, y), c) = let | |
216 | fun loop (EAPP (x, y)) = | |
217 | (loop x; ppExp0 s (y, EC_APP); PP.space s 1) | |
218 | | loop x = (ppExp0 s (x, EC_APP); | |
219 | PP.space s 1; | |
220 | PP.openHOVBox s (PP.Rel 0)) | |
221 | val paren = c = EC_APP | |
222 | in | |
223 | PP.openHOVBox s (PP.Abs 4); | |
224 | if paren then PP.string s "(" else (); | |
225 | loop x; | |
226 | ppExp0 s (y, EC_APP); | |
227 | if paren then PP.string s ")" else (); | |
228 | PP.closeBox s; | |
229 | PP.closeBox s | |
230 | end | |
231 | | ppExp0 s (ECONSTR (x, t), c) = let | |
232 | val paren = c = EC_APP | |
233 | val indent = if paren then 5 else 4 | |
234 | val tc = if paren then C_CON else C_COMMA | |
235 | in | |
236 | PP.openHOVBox s (PP.Rel indent); | |
237 | if paren then PP.string s "(" else (); | |
238 | ppExp0 s (x, c); | |
239 | PP.nbSpace s 1; | |
240 | PP.string s ":"; | |
241 | PP.space s 1; | |
242 | ppType' s (t, tc); | |
243 | if paren then PP.string s ")" else (); | |
244 | PP.closeBox s | |
245 | end | |
246 | | ppExp0 s (ESEQ (x, y), c) = let | |
247 | in | |
248 | PP.string s "("; | |
249 | PP.openHVBox s (PP.Rel 0); | |
250 | ppExp0 s (x, EC_COMMA); | |
251 | PP.string s ";"; | |
252 | PP.space s 1; | |
253 | ppExp0 s (y, EC_COMMA); | |
254 | PP.string s ")"; | |
255 | PP.closeBox s | |
256 | end | |
257 | | ppExp0 s (EPRIM (p, t), c) = let | |
258 | val paren = c = EC_APP | |
259 | val indent = if paren then 5 else 4 | |
260 | val tc = if paren then C_CON else C_COMMA | |
261 | in | |
262 | PP.openHOVBox s (PP.Rel indent); | |
263 | if paren then PP.string s "(" else (); | |
264 | PP.string s p; | |
265 | PP.nbSpace s 1; | |
266 | PP.string s ":"; | |
267 | PP.space s 1; | |
268 | ppType' s (t, tc); | |
269 | PP.string s ";"; | |
270 | if paren then PP.string s ")" else (); | |
271 | PP.closeBox s | |
272 | end | |
273 | | ppExp0 s (ELET ([], e), c) = ppExp0 s (e, c) | |
274 | | ppExp0 s (ELET (bnds, e), c) = let | |
275 | fun loop [] = () | |
276 | | loop ((v, e) :: bnds) = (PP.newline s; | |
277 | PP.openHOVBox s (PP.Abs 4); | |
278 | PP.string s "val"; | |
279 | PP.nbSpace s 1; | |
280 | PP.string s v; | |
281 | PP.nbSpace s 1; | |
282 | PP.string s "="; | |
283 | PP.space s 1; | |
284 | ppExp0 s (e, EC_COMMA); | |
285 | PP.closeBox s; | |
286 | loop bnds) | |
287 | in | |
288 | PP.string s "let"; | |
289 | PP.openVBox s (PP.Abs 4); | |
290 | loop bnds; | |
291 | PP.closeBox s; | |
292 | PP.newline s; | |
293 | PP.string s "in"; | |
294 | PP.openVBox s (PP.Abs 4); | |
295 | PP.newline s; | |
296 | ppExp0 s (e, EC_COMMA); | |
297 | PP.closeBox s; | |
298 | PP.newline s; | |
299 | PP.string s "end" | |
300 | end | |
301 | ||
302 | fun ppExp s x = ppExp0 s (x, EC_COMMA) | |
303 | fun ppExp' s x = ppExp0 s (x, EC_APP) | |
304 | ||
305 | fun ppFun s (name, args, body) = | |
306 | (PP.openHOVBox s (PP.Rel 4); | |
307 | PP.string s ("fun " ^ name); | |
308 | PP.nbSpace s 1; | |
309 | app (fn a => (ppExp' s a; PP.space s 1)) args; | |
310 | PP.string s "="; | |
311 | PP.nbSpace s 1; | |
312 | PP.openBox s (PP.Rel 0); | |
313 | ppExp s body; | |
314 | PP.closeBox s; | |
315 | PP.closeBox s) | |
316 | end |