-
Notifications
You must be signed in to change notification settings - Fork 0
/
pretty.ml
271 lines (258 loc) · 9.44 KB
/
pretty.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
open Types
open Printf
open Format
open Lexing
let rec intersperse (elts : 'a list) (sep : 'a) : 'a list =
match elts with
| [] -> []
| [elt] -> [elt]
| elt::rest -> elt::sep::(intersperse rest sep)
let string_of_op1 op =
match op with
| Add1 -> "add1"
| Sub1 -> "sub1"
| Print -> "print"
| PrintStack -> "printStack"
| Not -> "!"
| IsNum -> "isnum"
| IsBool -> "isbool"
| IsTuple -> "istuple"
let name_of_op1 op =
match op with
| Add1 -> "Add1"
| Sub1 -> "Sub1"
| Print -> "Print"
| PrintStack -> "PrintStack"
| Not -> "Not"
| IsNum -> "IsNum"
| IsBool -> "IsBool"
| IsTuple -> "IsTuple"
let string_of_op2 op =
match op with
| Plus -> "+"
| Minus -> "-"
| Times -> "*"
| And -> "&&"
| Or -> "||"
| Greater -> ">"
| Less -> "<"
| GreaterEq -> ">="
| LessEq -> "<="
| Eq -> "=="
let name_of_op2 op =
match op with
| Plus -> "Plus"
| Minus -> "Minus"
| Times -> "Times"
| And -> "And"
| Or -> "Or"
| Greater -> "Greater"
| Less -> "Less"
| GreaterEq -> "GreaterEq"
| LessEq -> "LessEq"
| Eq -> "Eq"
let rec string_of_expr (e : 'a expr) : string =
match e with
| ENumber(n, _) -> string_of_int n
| EBool(b, _) -> string_of_bool b
| EId(x, _) -> x
| EPrim1(op, e, _) ->
sprintf "%s(%s)" (string_of_op1 op) (string_of_expr e)
| EPrim2(op, left, right, _) ->
sprintf "(%s %s %s)" (string_of_expr left) (string_of_op2 op) (string_of_expr right)
| ELet(binds, body, _) ->
let binds_strs = List.map (fun (x, e, _) -> sprintf "%s = %s" x (string_of_expr e)) binds in
let binds_str = List.fold_left (^) "" (intersperse binds_strs ", ") in
sprintf "(let %s in %s)" binds_str (string_of_expr body)
| ELetRec(binds, body, _) ->
let binds_strs = List.map (fun (x, e, _) -> sprintf "%s = %s" x (string_of_expr e)) binds in
let binds_str = List.fold_left (^) "" (intersperse binds_strs ", ") in
sprintf "(let rec %s in %s)" binds_str (string_of_expr body)
| EIf(cond, thn, els, _) ->
sprintf "(if %s: %s else: %s)"
(string_of_expr cond)
(string_of_expr thn)
(string_of_expr els)
| EApp(func, args, _) ->
sprintf "(%s(%s))" (string_of_expr func) (ExtString.String.join ", " (List.map string_of_expr args))
| ETuple(vals, _) ->
sprintf "(%s)" (ExtString.String.join ", " (List.map string_of_expr vals))
| EGetItem(tup, idx, _) ->
sprintf "%s[%s]" (string_of_expr tup) (string_of_expr idx)
| ESetItem(tup, idx, rhs, _) ->
sprintf "%s[%s] := %s" (string_of_expr tup) (string_of_expr idx) (string_of_expr rhs)
| ELambda(args, body, _) ->
sprintf "(lambda(%s): %s)" (ExtString.String.join ", " (List.map fst args))
(string_of_expr body)
| ESeq(stmts, _) ->
sprintf "(%s)" (ExtString.String.join "; " (List.map string_of_expr stmts))
let string_of_pos ((pstart, pend) : (Lexing.position * Lexing.position)) : string =
sprintf "%s, %d:%d-%d:%d" pstart.pos_fname pstart.pos_lnum (pstart.pos_cnum - pstart.pos_bol)
pend.pos_lnum (pend.pos_cnum - pend.pos_bol)
let rec string_of_aexpr (e : 'a aexpr) : string =
match e with
| ASeq(fst, snd, _) ->
sprintf "(%s; %s)" (string_of_cexpr fst) (string_of_aexpr snd)
| ALet(x, e, b, _) -> sprintf "(alet %s = %s in %s)" x (string_of_cexpr e) (string_of_aexpr b)
| ALetRec(xes, b, _) ->
sprintf "(aletrec %s in %s)"
(ExtString.String.join
", "
(List.map (fun (x, e) -> sprintf "%s = %s" x (string_of_cexpr e)) xes))
(string_of_aexpr b)
| ACExpr c -> string_of_cexpr c
and string_of_cexpr c =
match c with
| CPrim1(op, e, _) ->
sprintf "%s(%s)" (string_of_op1 op) (string_of_immexpr e)
| CPrim2(op, left, right, _) ->
sprintf "(%s %s %s)" (string_of_immexpr left) (string_of_op2 op) (string_of_immexpr right)
| CIf(cond, thn, els, _) ->
sprintf "(if %s: %s else: %s)"
(string_of_immexpr cond)
(string_of_aexpr thn)
(string_of_aexpr els)
| CApp(func, args, _) ->
sprintf "(%s(%s))" (string_of_immexpr func) (ExtString.String.join ", " (List.map string_of_immexpr args))
| CTuple(vals, _) ->
sprintf "(%s)" (ExtString.String.join ", " (List.map string_of_immexpr vals))
| CGetItem(tup, idx, _) ->
sprintf "%s[%s]" (string_of_immexpr tup) (string_of_immexpr idx)
| CSetItem(tup, idx, rhs, _) ->
sprintf "%s[%s] := %s" (string_of_immexpr tup) (string_of_immexpr idx) (string_of_immexpr rhs)
| CLambda(args, body, _) ->
sprintf "(lambda(%s): %s)" (ExtString.String.join ", " args) (string_of_aexpr body)
| CImmExpr i -> string_of_immexpr i
and string_of_immexpr i =
match i with
| ImmNum(n, _) -> string_of_int n
| ImmBool(b, _) -> string_of_bool b
| ImmId(x, _) -> x
and string_of_aprogram p = string_of_aexpr p
let rec format_expr (e : 'a expr) (print_a : 'a -> string) : string =
let maybe_a a =
let astr = print_a a in
if astr = "" then "" else "<" ^ astr ^ ">" in
let indent = 2 in
let print_list fmt p_item items p_sep =
match items with
| [] -> ();
| [item] -> p_item item fmt
| first::rest ->
p_item first fmt;
List.iter (fun item -> p_sep fmt; p_item item fmt) rest in
let print_comma_sep fmt =
pp_print_string fmt ","; pp_print_space fmt () in
let print_semi_sep fmt =
pp_print_string fmt ";"; pp_print_space fmt () in
let open_label fmt label a =
pp_open_hvbox fmt indent; pp_print_string fmt label; pp_print_string fmt (maybe_a a);
pp_print_string fmt "("; pp_print_cut fmt () in
let open_paren fmt =
pp_open_box fmt 2; pp_print_string fmt "("; pp_print_cut fmt () in
let close_paren fmt =
pp_print_break fmt 0 (~-indent); pp_close_box fmt (); pp_print_string fmt ")" in
let quote x = "\"" ^ x ^ "\"" in
let rec help e fmt =
match e with
| ENumber(n, a) ->
open_label fmt "ENumber" a;
pp_print_int fmt n;
close_paren fmt
| EBool(b, a) ->
open_label fmt "EBool" a;
pp_print_bool fmt b;
close_paren fmt
| EId(x, a) ->
open_label fmt "EId" a;
pp_print_string fmt (quote x);
close_paren fmt
| EPrim1(op, e, a) ->
open_label fmt "EPrim1" a;
pp_print_string fmt (name_of_op1 op);
print_comma_sep fmt; help e fmt;
close_paren fmt
| EPrim2(op, e1, e2, a) ->
open_label fmt "EPrim2" a;
pp_print_string fmt (name_of_op2 op);
print_comma_sep fmt; help e1 fmt; print_comma_sep fmt; help e2 fmt;
close_paren fmt
| EIf(cond, thn, els, a) ->
open_label fmt "EIf" a;
help cond fmt; print_comma_sep fmt; help thn fmt; print_comma_sep fmt; help els fmt;
close_paren fmt
| EApp(func, args, a) ->
open_label fmt "EApp" a;
help func fmt;
print_comma_sep fmt;
(match args with
| [] -> ()
| [e] -> help e fmt
| e1::rest -> help e1 fmt; List.iter (fun e -> print_comma_sep fmt; help e fmt) rest);
close_paren fmt
| ETuple(vals, a) ->
open_label fmt "ETuple" a;
(match vals with
| [] -> ()
| [e] -> help e fmt
| e1::rest -> help e1 fmt; List.iter (fun e -> print_comma_sep fmt; help e fmt) rest);
close_paren fmt
| EGetItem(tup, idx, a) ->
open_label fmt "EGetItem" a;
help tup fmt;
print_comma_sep fmt; help idx fmt;
close_paren fmt
| ESetItem(tup, idx, rhs, a) ->
open_label fmt "ESetItem" a;
help tup fmt;
print_comma_sep fmt; help idx fmt;
print_comma_sep fmt; help rhs fmt;
close_paren fmt
| ESeq(stmts, a) ->
open_label fmt "ESeq" a;
print_list fmt help stmts print_semi_sep;
close_paren fmt
| ELet(binds, body, a) ->
let print_item (x, b, a) fmt =
open_paren fmt;
pp_print_string fmt (" " ^ (quote x)); pp_print_string fmt (maybe_a a); print_comma_sep fmt; help b fmt;
close_paren fmt in
open_label fmt "ELet" a;
open_paren fmt; print_list fmt print_item binds print_comma_sep; close_paren fmt;
print_comma_sep fmt;
help body fmt;
close_paren fmt
| ELetRec(binds, body, a) ->
let print_item (x, b, a) fmt =
open_paren fmt;
pp_print_string fmt (" " ^ (quote x)); pp_print_string fmt (maybe_a a); print_comma_sep fmt; help b fmt;
close_paren fmt in
open_label fmt "ELetRec" a;
open_paren fmt; print_list fmt print_item binds print_comma_sep; close_paren fmt;
print_comma_sep fmt;
help body fmt;
close_paren fmt
| ELambda(args, body, a) ->
let print_item (x, a) fmt =
open_paren fmt;
pp_print_string fmt (" " ^ (quote x)); pp_print_string fmt (maybe_a a); print_comma_sep fmt;
close_paren fmt in
open_label fmt "ELambda" a;
open_paren fmt; print_list fmt print_item args print_comma_sep; close_paren fmt;
print_comma_sep fmt;
ignore(format_expr body print_a);
close_paren fmt
in
help e str_formatter;
flush_str_formatter ()
and format_prog (p : 'a program) (print_a : 'a -> string) : string =
format_expr p print_a
;;
let ast_of_pos_prog (e : sourcespan program) : string =
format_prog e string_of_pos
let ast_of_prog (e : 'a program) : string =
format_prog e (fun _ -> "")
let rec ast_of_pos_expr (e : (Lexing.position * Lexing.position) expr) : string =
format_expr e string_of_pos
let rec ast_of_expr (e : 'a expr) : string =
format_expr e (fun _ -> "")