Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlnlffigen / pp.sml
CommitLineData
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 *)
14structure 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)
316end