2 * 2005 Matthew
Fluet (mfluet@acm
.org
)
7 * pp
.sml
- Some simple pretty
-printing infrastructure for the ml
-ffigen
10 * (C
) 2001, Lucent Technologies
, Bell Labs
12 * author
: Matthias
Blume (blume@research
.bell
-labs
.com
)
14 structure PrettyPrint
= struct
16 structure PP
= PPStreamFn (structure Token
= StringToken
17 structure Device
= CPIFDev
)
20 ARROW
of mltype
* mltype
21 | TUPLE
of mltype list
22 | CON
of string * mltype list
23 | RECORD
of (string * mltype
) list
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"])
31 datatype tcontext
= C_STAR | C_ARROW | C_COMMA | C_CON
33 fun simplify (CON ("unit", [])) = Unit
34 |
simplify (TUPLE
[t
]) = simplify t
35 |
simplify (CON (k
, tl
)) =
37 fun doDefault () = CON (k
, map simplify tl
)
41 if List.exists (fn k
' => k
= k
')
42 ["schar","uchar","sshort","ushort",
43 "sint","uint","slong","ulong",
44 "slonglong","ulonglong","float","double",
46 then CON (concat
[k
, "_", obj
], [simplify c
])
49 [f
] => CON ("fptr_" ^ obj
, [simplify f
, simplify c
])
53 [su
] => CON ("su_" ^ obj
, [simplify su
, simplify c
])
61 if k
' = "Dim.nonzero" orelse k
' = "nonzero"
62 then CON ("dim", [simplify n
])
69 else if List.exists (fn d
' => d
= d
')
70 ["dg0","dg1","dg2","dg3","dg4",
71 "dg5","dg6","dg7","dg8","dg9"]
73 [n
] => CON (d
, [simplify n
])
77 if k
= "obj" orelse k
= "obj'"
79 else if String.isPrefix
"Dim." k
80 then doDim (String.extract(k
,4,NONE
))
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
)
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;
91 | loop t
= ppType0
s (t
, C_ARROW
)
92 val paren
= not (c
= C_COMMA
)
93 val indent
= if paren
then 5 else 4
95 PP
.openHOVBox
s (PP
.Rel indent
);
96 if paren
then PP
.string s
"(" else ();
98 if paren
then PP
.string s
")" else ();
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
);
111 case c
of (C_STAR
) => true
115 val indent
= if paren
then 1 else 0
117 PP
.openHVBox
s (PP
.Rel indent
);
118 if paren
then PP
.string s
"(" else ();
120 if paren
then PP
.string s
")" else ();
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
);
134 PP
.openHVBox
s (PP
.Rel
2);
140 | ppType0
s (CON (k
, []), _
) = PP
.string s k
141 | ppType0
s (CON (k
, [t
]), _
) =
143 ppType0
s (t
, C_CON
);
147 | ppType0
s (CON (k
, tl
), _
) = let
148 fun loop
[] = () (* cannot happen
*)
149 | loop
[t
] = ppType0
s (t
, C_COMMA
)
151 (ppType0
s (h
, C_COMMA
); PP
.string s
","; PP
.space s
1; loop tl
)
154 PP
.openHVBox
s (PP
.Rel
1);
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
)
170 | ERECORD
of (string * mlexp
) list
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
178 datatype econtext
= EC_APP | EC_COMMA
180 fun ppExp0
s (ETUPLE
[], _
) = PP
.string s
"()"
181 | ppExp0
s (ETUPLE
[x
], c
) = ppExp0
s (x
, c
)
182 | ppExp0
s (ETUPLE xl
, _
) = let
184 | loop
[x
] = ppExp0
s (x
, EC_COMMA
)
186 (ppExp0
s (x
, EC_COMMA
); PP
.string s
","; PP
.space s
1;
189 PP
.openHVBox
s (PP
.Rel
1);
195 | ppExp0
s (ERECORD
[], _
) = PP
.string s
"{}"
196 | ppExp0
s (ERECORD xl
, _
) = let
198 | loop
[(n
, x
)] = (PP
.string s (n ^
" =");
200 ppExp0
s (x
, EC_COMMA
))
201 |
loop ((n
, x
) :: xl
) = (PP
.string s (n ^
" =");
203 ppExp0
s (x
, EC_COMMA
);
208 PP
.openHVBox
s (PP
.Rel
2);
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
);
220 PP
.openHOVBox
s (PP
.Rel
0))
221 val paren
= c
= EC_APP
223 PP
.openHOVBox
s (PP
.Abs
4);
224 if paren
then PP
.string s
"(" else ();
226 ppExp0
s (y
, EC_APP
);
227 if paren
then PP
.string s
")" else ();
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
236 PP
.openHOVBox
s (PP
.Rel indent
);
237 if paren
then PP
.string s
"(" else ();
243 if paren
then PP
.string s
")" else ();
246 | ppExp0
s (ESEQ (x
, y
), c
) = let
249 PP
.openHVBox
s (PP
.Rel
0);
250 ppExp0
s (x
, EC_COMMA
);
253 ppExp0
s (y
, EC_COMMA
);
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
262 PP
.openHOVBox
s (PP
.Rel indent
);
263 if paren
then PP
.string s
"(" else ();
270 if paren
then PP
.string s
")" else ();
273 | ppExp0
s (ELET ([], e
), c
) = ppExp0
s (e
, c
)
274 | ppExp0
s (ELET (bnds
, e
), c
) = let
276 |
loop ((v
, e
) :: bnds
) = (PP
.newline s
;
277 PP
.openHOVBox
s (PP
.Abs
4);
284 ppExp0
s (e
, EC_COMMA
);
289 PP
.openVBox
s (PP
.Abs
4);
294 PP
.openVBox
s (PP
.Abs
4);
296 ppExp0
s (e
, EC_COMMA
);
302 fun ppExp s x
= ppExp0
s (x
, EC_COMMA
)
303 fun ppExp
' s x
= ppExp0
s (x
, EC_APP
)
305 fun ppFun
s (name
, args
, body
) =
306 (PP
.openHOVBox
s (PP
.Rel
4);
307 PP
.string s ("fun " ^ name
);
309 app (fn a
=> (ppExp
' s a
; PP
.space s
1)) args
;
312 PP
.openBox
s (PP
.Rel
0);