author | haftmann |
Fri, 25 Nov 2005 17:41:52 +0100 | |
changeset 18247 | b17724cae935 |
parent 18231 | 2eea98bbf650 |
child 18282 | 98431741bda3 |
permissions | -rw-r--r-- |
18169
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
1 |
(* Title: Pure/Tools/codegen_serializer.ML |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
2 |
ID: $Id$ |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
3 |
Author: Florian Haftmann, TU Muenchen |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
4 |
|
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
5 |
Serializer from intermediate language ("Thin-gol") to |
18216 | 6 |
target languages (like ML or Haskell). |
18169
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
7 |
*) |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
8 |
|
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
9 |
signature CODEGEN_SERIALIZER = |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
10 |
sig |
18216 | 11 |
type primitives; |
12 |
val empty_prims: primitives; |
|
13 |
val add_prim: string * (string * string list) -> primitives -> primitives; |
|
14 |
val merge_prims: primitives * primitives -> primitives; |
|
15 |
val has_prim: primitives -> string -> bool; |
|
16 |
val mk_prims: primitives -> string; |
|
17 |
||
18 |
type 'a pretty_syntax = string -> Pretty.T list -> ('a -> Pretty.T) |
|
19 |
-> (string list * Pretty.T) option; |
|
20 |
type serializer = CodegenThingol.itype pretty_syntax -> CodegenThingol.iexpr pretty_syntax |
|
18217 | 21 |
-> primitives -> string list option -> CodegenThingol.module -> Pretty.T; |
18231 | 22 |
type parm_serializer = OuterParse.token list -> serializer * OuterParse.token list; |
18216 | 23 |
|
24 |
val ml_from_thingol: string list list -> string -> serializer; |
|
18169
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
25 |
end; |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
26 |
|
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
27 |
structure CodegenSerializer: CODEGEN_SERIALIZER = |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
28 |
struct |
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
29 |
|
18216 | 30 |
open CodegenThingol; |
31 |
||
32 |
||
33 |
(** target language primitives **) |
|
34 |
||
35 |
type primitives = string Graph.T; |
|
36 |
||
37 |
val empty_prims = Graph.empty; |
|
38 |
||
39 |
fun add_prim (f, (def, deps)) prims = |
|
40 |
prims |
|
41 |
|> Graph.new_node (f, def) |
|
42 |
|> fold (fn dep => Graph.add_edge (f, dep)) deps; |
|
43 |
||
44 |
val merge_prims = Graph.merge (op =) : primitives * primitives -> primitives; |
|
45 |
||
46 |
val has_prim : primitives -> string -> bool = can o Graph.get_node; |
|
47 |
||
48 |
fun get_prims prims defs = |
|
49 |
defs |
|
50 |
|> filter (can (Graph.get_node prims)) |
|
51 |
|> `I |
|
52 |
||> Graph.all_succs prims |
|
53 |
||> (fn gr => Graph.subgraph gr prims) |
|
54 |
||> Graph.strong_conn |
|
55 |
||> rev |
|
56 |
||> Library.flat |
|
57 |
||> map (Graph.get_node prims) |
|
58 |
||> separate "" |
|
59 |
||> cat_lines |
|
60 |
||> suffix "\n"; |
|
61 |
||
62 |
fun mk_prims prims = get_prims prims (Graph.keys prims) |> snd; |
|
63 |
||
64 |
||
65 |
(** generic serialization **) |
|
66 |
||
67 |
type 'a pretty_syntax = string -> Pretty.T list -> ('a -> Pretty.T) |
|
68 |
-> (string list * Pretty.T) option; |
|
69 |
type serializer = CodegenThingol.itype pretty_syntax -> CodegenThingol.iexpr pretty_syntax |
|
18217 | 70 |
-> primitives -> string list option -> CodegenThingol.module -> Pretty.T; |
18231 | 71 |
type parm_serializer = OuterParse.token list -> serializer * OuterParse.token list; |
18216 | 72 |
|
73 |
datatype lrx = L | R | X; |
|
74 |
||
75 |
datatype brack = |
|
76 |
BR |
|
77 |
| NOBR |
|
78 |
| INFX of (int * lrx); |
|
79 |
||
80 |
fun eval_lrx L L = false |
|
81 |
| eval_lrx R R = false |
|
82 |
| eval_lrx _ _ = true; |
|
83 |
||
84 |
fun eval_br BR _ = true |
|
85 |
| eval_br NOBR _ = false |
|
86 |
| eval_br (INFX (pr1, lr1)) (INFX (pr2, lr2)) = |
|
87 |
pr1 > pr2 |
|
88 |
orelse pr1 = pr2 |
|
89 |
andalso eval_lrx lr1 lr2 |
|
90 |
| eval_br (INFX _) _ = false; |
|
91 |
||
92 |
fun eval_br_postfix BR _ = false |
|
93 |
| eval_br_postfix NOBR _ = false |
|
94 |
| eval_br_postfix (INFX (pr1, lr1)) (INFX (pr2, lr2)) = |
|
95 |
pr1 > pr2 |
|
96 |
orelse pr1 = pr2 |
|
97 |
andalso eval_lrx lr1 lr2 |
|
98 |
| eval_br_postfix (INFX _) _ = false; |
|
99 |
||
100 |
fun brackify _ [p] = p |
|
101 |
| brackify true (ps as _::_) = Pretty.enclose "(" ")" (Pretty.breaks ps) |
|
102 |
| brackify false (ps as _::_) = Pretty.block (Pretty.breaks ps); |
|
103 |
||
104 |
fun postify [] f = [f] |
|
105 |
| postify [p] f = [p, Pretty.brk 1, f] |
|
106 |
| postify (ps as _::_) f = [Pretty.list "(" ")" ps, Pretty.brk 1, f]; |
|
107 |
||
108 |
fun praetify [] f = [f] |
|
109 |
| praetify [p] f = [f, Pretty.str " of ", p] |
|
110 |
||
111 |
||
112 |
(** ML serializer **) |
|
113 |
||
114 |
local |
|
115 |
||
116 |
fun ml_validator prims name = |
|
117 |
let |
|
118 |
fun replace_invalid c = |
|
119 |
if (Char.isAlphaNum o the o Char.fromString) c orelse c = "'" |
|
120 |
andalso not (NameSpace.separator = c) |
|
121 |
then c |
|
122 |
else "_" |
|
123 |
fun suffix_it name = |
|
124 |
name |
|
125 |
|> member (op =) ThmDatabase.ml_reserved ? suffix "'" |
|
126 |
|> member (op =) CodegenThingol.prims ? suffix "'" |
|
127 |
|> has_prim prims ? suffix "'" |
|
128 |
|> (fn name' => if name = name' then name else suffix_it name') |
|
129 |
in |
|
130 |
name |
|
131 |
|> translate_string replace_invalid |
|
132 |
|> suffix_it |
|
133 |
|> (fn name' => if name = name' then NONE else SOME name') |
|
134 |
end; |
|
135 |
||
136 |
val ml_label_uniq = translate_string (fn "'" => "''" | "." => "'" | c => c); |
|
18169
45def66f86cb
added modules for code generator generation two, not operational yet
haftmann
parents:
diff
changeset
|
137 |
|
18216 | 138 |
fun ml_from_defs styco sconst resolv ds = |
139 |
let |
|
140 |
fun chunk_defs ps = |
|
141 |
let |
|
142 |
val (p_init, p_last) = split_last ps |
|
143 |
in |
|
144 |
Pretty.chunks (p_init @ [Pretty.block ([p_last, Pretty.str ";"])]) |
|
145 |
end; |
|
146 |
fun ml_from_typ br (IType ("Pair", [t1, t2])) = |
|
147 |
brackify (eval_br_postfix br (INFX (2, L))) [ |
|
148 |
ml_from_typ (INFX (2, X)) t1, |
|
149 |
Pretty.str "*", |
|
150 |
ml_from_typ (INFX (2, X)) t2 |
|
151 |
] |
|
152 |
| ml_from_typ br (IType ("Bool", [])) = |
|
153 |
Pretty.str "bool" |
|
154 |
| ml_from_typ br (IType ("Integer", [])) = |
|
155 |
Pretty.str "IntInf.int" |
|
156 |
| ml_from_typ br (IType ("List", [ty])) = |
|
157 |
postify ([ml_from_typ BR ty]) (Pretty.str "list") |
|
158 |
|> Pretty.block |
|
159 |
| ml_from_typ br (IType (tyco, typs)) = |
|
160 |
let |
|
161 |
val tyargs = (map (ml_from_typ BR) typs) |
|
162 |
in |
|
163 |
case styco tyco tyargs (ml_from_typ BR) |
|
164 |
of NONE => |
|
165 |
postify tyargs ((Pretty.str o resolv) tyco) |
|
166 |
|> Pretty.block |
|
167 |
| SOME ([], p) => |
|
168 |
p |
|
169 |
| SOME (_, p) => |
|
170 |
error ("cannot serialize partial type application to ML, while serializing " |
|
171 |
^ quote (tyco ^ " " ^ Pretty.output (Pretty.list "(" ")" tyargs))) |
|
172 |
end |
|
173 |
| ml_from_typ br (IFun (t1, t2)) = |
|
174 |
brackify (eval_br_postfix br (INFX (1, R))) [ |
|
175 |
ml_from_typ (INFX (1, X)) t1, |
|
176 |
Pretty.str "->", |
|
177 |
ml_from_typ (INFX (1, R)) t2 |
|
178 |
] |
|
179 |
| ml_from_typ _ (IVarT (v, [])) = |
|
180 |
Pretty.str ("'" ^ v) |
|
181 |
| ml_from_typ _ (IVarT (_, sort)) = |
|
182 |
"cannot serialize sort constrained type variable to ML: " ^ commas sort |> error |
|
183 |
| ml_from_typ _ (IDictT fs) = |
|
184 |
(Pretty.enclose "{" "}" o Pretty.breaks) ( |
|
185 |
map (fn (f, ty) => |
|
186 |
Pretty.block [Pretty.str (ml_label_uniq f ^ ": "), ml_from_typ NOBR ty]) fs |
|
187 |
); |
|
188 |
fun ml_from_pat br (ICons (("True", []), _)) = |
|
189 |
Pretty.str "true" |
|
190 |
| ml_from_pat br (ICons (("False", []), _)) = |
|
191 |
Pretty.str "false" |
|
192 |
| ml_from_pat br (ICons (("Pair", ps), _)) = |
|
193 |
ps |
|
194 |
|> map (ml_from_pat NOBR) |
|
195 |
|> Pretty.list "(" ")" |
|
196 |
| ml_from_pat br (ICons (("Nil", []), _)) = |
|
197 |
Pretty.str "[]" |
|
198 |
| ml_from_pat br (p as ICons (("Cons", _), _)) = |
|
199 |
let |
|
200 |
fun dest_cons (ICons (("Cons", [ICons (("Pair", [p1, p2]), _)]), _)) = SOME (p1, p2) |
|
201 |
| dest_cons p = NONE |
|
202 |
in |
|
203 |
case unfoldr dest_cons p |
|
204 |
of (ps, (ICons (("Nil", []), _))) => |
|
205 |
ps |
|
206 |
|> map (ml_from_pat NOBR) |
|
207 |
|> Pretty.list "[" "]" |
|
208 |
| (ps, p) => |
|
209 |
(ps @ [p]) |
|
210 |
|> map (ml_from_pat (INFX (5, X))) |
|
211 |
|> separate (Pretty.str "::") |
|
212 |
|> brackify (eval_br br (INFX (5, R))) |
|
213 |
end |
|
214 |
| ml_from_pat br (ICons ((f, ps), ty)) = |
|
215 |
ps |
|
216 |
|> map (ml_from_pat BR) |
|
217 |
|> cons ((Pretty.str o resolv) f) |
|
218 |
|> brackify (eval_br br BR) |
|
219 |
| ml_from_pat br (IVarP (v, IType ("Integer", []))) = |
|
220 |
Pretty.str ("(" ^ v ^ ":IntInf.int)") |
|
221 |
| ml_from_pat br (IVarP (v, _)) = |
|
222 |
Pretty.str v; |
|
223 |
fun ml_from_iexpr br (e as (IApp (IConst ("Cons", _), _))) = |
|
224 |
let |
|
225 |
fun dest_cons (IApp (IConst ("Cons", _), |
|
226 |
IApp (IApp (IConst ("Pair", _), e1), e2))) = SOME (e1, e2) |
|
227 |
| dest_cons p = NONE |
|
228 |
in |
|
229 |
case unfoldr dest_cons e |
|
230 |
of (es, (IConst ("Nil", _))) => |
|
231 |
es |
|
232 |
|> map (ml_from_iexpr NOBR) |
|
233 |
|> Pretty.list "[" "]" |
|
234 |
| (es, e) => |
|
235 |
(es @ [e]) |
|
236 |
|> map (ml_from_iexpr (INFX (5, X))) |
|
237 |
|> separate (Pretty.str "::") |
|
238 |
|> brackify (eval_br br (INFX (5, R))) |
|
239 |
end |
|
240 |
| ml_from_iexpr br (e as IApp (e1, e2)) = |
|
241 |
(case (unfold_app e) |
|
242 |
of (e as (IConst (f, _)), es) => |
|
243 |
ml_from_app br (f, es) |
|
244 |
| _ => |
|
245 |
brackify (eval_br br BR) [ |
|
246 |
ml_from_iexpr NOBR e1, |
|
247 |
ml_from_iexpr BR e2 |
|
248 |
]) |
|
249 |
| ml_from_iexpr br (e as IConst (f, _)) = |
|
250 |
ml_from_app br (f, []) |
|
251 |
| ml_from_iexpr br (IVarE (v, _)) = |
|
252 |
Pretty.str v |
|
253 |
| ml_from_iexpr br (IAbs ((v, _), e)) = |
|
254 |
brackify (eval_br br BR) [ |
|
255 |
Pretty.str ("fn " ^ v ^ " =>"), |
|
256 |
ml_from_iexpr BR e |
|
257 |
] |
|
258 |
| ml_from_iexpr br (e as ICase (_, [_])) = |
|
259 |
let |
|
260 |
val (ps, e) = unfold_let e; |
|
261 |
fun mk_val (p, e) = Pretty.block [ |
|
262 |
Pretty.str "val ", |
|
263 |
ml_from_pat BR p, |
|
264 |
Pretty.str " =", |
|
265 |
Pretty.brk 1, |
|
266 |
ml_from_iexpr NOBR e, |
|
267 |
Pretty.str ";" |
|
268 |
] |
|
269 |
in Pretty.chunks [ |
|
270 |
[Pretty.str ("let"), Pretty.fbrk, map mk_val ps |> Pretty.chunks] |> Pretty.block, |
|
271 |
[Pretty.str ("in"), Pretty.fbrk, ml_from_iexpr NOBR e] |> Pretty.block, |
|
272 |
Pretty.str ("end") |
|
273 |
] end |
|
274 |
| ml_from_iexpr br (ICase (e, c::cs)) = |
|
275 |
let |
|
276 |
fun mk_clause definer (p, e) = |
|
277 |
Pretty.block [ |
|
278 |
Pretty.str definer, |
|
279 |
ml_from_pat NOBR p, |
|
280 |
Pretty.str " =>", |
|
281 |
Pretty.brk 1, |
|
282 |
ml_from_iexpr NOBR e |
|
283 |
] |
|
284 |
in brackify (eval_br br BR) ( |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
285 |
Pretty.str "case" |
18216 | 286 |
:: ml_from_iexpr NOBR e |
287 |
:: mk_clause "of " c |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
288 |
:: map (mk_clause "| ") cs |
18216 | 289 |
) end |
290 |
| ml_from_iexpr br (IInst _) = |
|
291 |
error "cannot serialize poly instant to ML" |
|
292 |
| ml_from_iexpr br (IDictE fs) = |
|
293 |
(Pretty.enclose "{" "}" o Pretty.breaks) ( |
|
294 |
map (fn (f, e) => |
|
295 |
Pretty.block [Pretty.str (ml_label_uniq f ^ " = "), ml_from_iexpr NOBR e]) fs |
|
296 |
) |
|
297 |
| ml_from_iexpr br (ILookup (ls, v)) = |
|
298 |
brackify (eval_br br BR) [ |
|
299 |
Pretty.str "(", |
|
300 |
ls |> map ((fn s => "#" ^ s) o ml_label_uniq) |> foldr1 (fn (l, e) => l ^ " o " ^ e) |> Pretty.str, |
|
301 |
Pretty.str ")", |
|
302 |
Pretty.str " ", |
|
303 |
Pretty.str v |
|
304 |
] |
|
305 |
and mk_app_p br p args = |
|
306 |
brackify (eval_br br BR) |
|
307 |
(p :: map (ml_from_iexpr BR) args) |
|
308 |
and ml_from_app br ("Nil", []) = |
|
309 |
Pretty.str "[]" |
|
310 |
| ml_from_app br ("True", []) = |
|
311 |
Pretty.str "true" |
|
312 |
| ml_from_app br ("False", []) = |
|
313 |
Pretty.str "false" |
|
314 |
| ml_from_app br ("primeq", [e1, e2]) = |
|
315 |
brackify (eval_br br (INFX (4, L))) [ |
|
316 |
ml_from_iexpr (INFX (4, L)) e1, |
|
317 |
Pretty.str "=", |
|
318 |
ml_from_iexpr (INFX (4, X)) e2 |
|
319 |
] |
|
320 |
| ml_from_app br ("Pair", [e1, e2]) = |
|
321 |
Pretty.list "(" ")" [ |
|
322 |
ml_from_iexpr NOBR e1, |
|
323 |
ml_from_iexpr NOBR e2 |
|
324 |
] |
|
325 |
| ml_from_app br ("and", [e1, e2]) = |
|
326 |
brackify (eval_br br (INFX (~1, L))) [ |
|
327 |
ml_from_iexpr (INFX (~1, L)) e1, |
|
328 |
Pretty.str "andalso", |
|
329 |
ml_from_iexpr (INFX (~1, X)) e2 |
|
330 |
] |
|
331 |
| ml_from_app br ("or", [e1, e2]) = |
|
332 |
brackify (eval_br br (INFX (~2, L))) [ |
|
333 |
ml_from_iexpr (INFX (~2, L)) e1, |
|
334 |
Pretty.str "orelse", |
|
335 |
ml_from_iexpr (INFX (~2, X)) e2 |
|
336 |
] |
|
337 |
| ml_from_app br ("if", [b, e1, e2]) = |
|
338 |
brackify (eval_br br BR) [ |
|
339 |
Pretty.str "if", |
|
340 |
ml_from_iexpr BR b, |
|
341 |
Pretty.str "then", |
|
342 |
ml_from_iexpr BR e1, |
|
343 |
Pretty.str "else", |
|
344 |
ml_from_iexpr BR e2 |
|
345 |
] |
|
346 |
| ml_from_app br ("add", [e1, e2]) = |
|
347 |
brackify (eval_br br (INFX (6, L))) [ |
|
348 |
ml_from_iexpr (INFX (6, L)) e1, |
|
349 |
Pretty.str "+", |
|
350 |
ml_from_iexpr (INFX (6, X)) e2 |
|
351 |
] |
|
352 |
| ml_from_app br ("mult", [e1, e2]) = |
|
353 |
brackify (eval_br br (INFX (7, L))) [ |
|
354 |
ml_from_iexpr (INFX (7, L)) e1, |
|
355 |
Pretty.str "+", |
|
356 |
ml_from_iexpr (INFX (7, X)) e2 |
|
357 |
] |
|
358 |
| ml_from_app br ("lt", [e1, e2]) = |
|
359 |
brackify (eval_br br (INFX (4, L))) [ |
|
360 |
ml_from_iexpr (INFX (4, L)) e1, |
|
361 |
Pretty.str "<", |
|
362 |
ml_from_iexpr (INFX (4, X)) e2 |
|
363 |
] |
|
364 |
| ml_from_app br ("le", [e1, e2]) = |
|
365 |
brackify (eval_br br (INFX (7, L))) [ |
|
366 |
ml_from_iexpr (INFX (4, L)) e1, |
|
367 |
Pretty.str "<=", |
|
368 |
ml_from_iexpr (INFX (4, X)) e2 |
|
369 |
] |
|
370 |
| ml_from_app br ("minus", es) = |
|
371 |
mk_app_p br (Pretty.str "~") es |
|
372 |
| ml_from_app br ("wfrec", es) = |
|
373 |
mk_app_p br (Pretty.str "wfrec") es |
|
374 |
| ml_from_app br (f, es) = |
|
375 |
let |
|
376 |
val args = map (ml_from_iexpr BR) es |
|
377 |
val brackify' = K (eval_br br BR) ? (single #> Pretty.enclose "(" ")") |
|
378 |
in |
|
379 |
case sconst f args (ml_from_iexpr BR) |
|
380 |
of NONE => |
|
381 |
brackify (eval_br br BR) (Pretty.str (resolv f) :: args) |
|
18231 | 382 |
| SOME (_, p) => |
18216 | 383 |
brackify' p |
384 |
end; |
|
385 |
fun ml_from_funs (ds as d::ds_tl) = |
|
386 |
let |
|
387 |
fun mk_definer [] = "val" |
|
388 |
| mk_definer _ = "fun" |
|
389 |
fun check_args (_, Fun ((pats, _)::_, _)) NONE = |
|
390 |
SOME (mk_definer pats) |
|
391 |
| check_args (_, Fun ((pats, _)::_, _)) (SOME definer) = |
|
392 |
if mk_definer pats = definer |
|
393 |
then SOME definer |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
394 |
else error ("mixing simultaneous vals and funs not implemented") |
18216 | 395 |
| check_args _ _ = |
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
396 |
error ("function definition block containing other definitions than functions") |
18216 | 397 |
val definer = the (fold check_args ds NONE); |
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
398 |
fun mk_eq definer f ty (pats, expr) = |
18216 | 399 |
let |
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
400 |
val lhs = [Pretty.str (definer ^ " " ^ f)] |
18216 | 401 |
@ (if null pats |
402 |
then [Pretty.str ":", ml_from_typ NOBR ty] |
|
403 |
else map (ml_from_pat BR) pats) |
|
404 |
val rhs = [Pretty.str "=", ml_from_iexpr NOBR expr] |
|
405 |
in |
|
406 |
Pretty.block (separate (Pretty.brk 1) (lhs @ rhs)) |
|
407 |
end |
|
408 |
fun mk_fun definer (f, Fun (eqs as eq::eq_tl, (_, ty))) = |
|
409 |
let |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
410 |
val (pats_hd::pats_tl) = (fst o split_list) eqs; |
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
411 |
val _ = fold (fn x => fn y => (x ~~ y; y)) pats_tl pats_hd; |
18216 | 412 |
(*check for equal length of argument lists*) |
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
413 |
val shift = if null eq_tl then I else map (Pretty.block o single); |
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
414 |
in (Pretty.block o Pretty.fbreaks o shift) ( |
18216 | 415 |
mk_eq definer f ty eq |
416 |
:: map (mk_eq "|" f ty) eq_tl |
|
417 |
) |
|
418 |
end |
|
419 |
in |
|
420 |
chunk_defs ( |
|
421 |
mk_fun definer d |
|
422 |
:: map (mk_fun "and") ds_tl |
|
423 |
) |
|
424 |
end; |
|
425 |
fun ml_from_datatypes ds = |
|
426 |
let |
|
427 |
fun check_typ_dup ty xs = |
|
428 |
if AList.defined (op =) xs ty |
|
429 |
then error ("double datatype definition: " ^ quote ty) |
|
430 |
else xs |
|
431 |
fun check_typ_miss ty xs = |
|
432 |
if AList.defined (op =) xs ty |
|
433 |
then xs |
|
434 |
else error ("missing datatype definition: " ^ quote ty) |
|
435 |
fun group (name, Datatype (vs, _, _)) ts = |
|
436 |
(map (fn (_, []) => () | _ => error "can't serialize sort constrained datatype declaration to ML") vs; |
|
437 |
ts |
|
438 |
|> apsnd (check_typ_dup name) |
|
439 |
|> apsnd (AList.update (op =) (name, (vs, [])))) |
|
440 |
| group (_, Datatypecons (_, _::_::_)) _ = |
|
441 |
error ("Datatype constructor containing more than one parameter") |
|
442 |
| group (name, Datatypecons (ty, tys)) ts = |
|
443 |
ts |
|
444 |
|> apfst (AList.default (op =) (resolv ty, [])) |
|
445 |
|> apfst (AList.map_entry (op =) (resolv ty) (cons (name, tys))) |
|
446 |
| group _ _ = |
|
447 |
error ("Datatype block containing other statements than datatype or constructor definitions") |
|
448 |
fun group_cons (ty, co) ts = |
|
449 |
ts |
|
450 |
|> check_typ_miss ty |
|
451 |
|> AList.map_entry (op =) ty (rpair co o fst) |
|
452 |
fun mk_datatypes (ds as d::ds_tl) = |
|
453 |
let |
|
454 |
fun mk_cons (co, typs) = |
|
455 |
(Pretty.block oo praetify) |
|
456 |
(map (ml_from_typ NOBR) typs) |
|
457 |
(Pretty.str (resolv co)) |
|
458 |
fun mk_datatype definer (t, (vs, cs)) = |
|
459 |
Pretty.block ( |
|
460 |
[Pretty.str definer] |
|
461 |
@ postify (map (ml_from_typ BR o IVarT) vs) |
|
462 |
(Pretty.str t) |
|
463 |
@ [Pretty.str " =", |
|
464 |
Pretty.brk 1] |
|
465 |
@ separate (Pretty.block [Pretty.brk 1, Pretty.str "| "]) (map mk_cons cs) |
|
466 |
) |
|
467 |
in |
|
468 |
chunk_defs ( |
|
469 |
mk_datatype "datatype " d |
|
470 |
:: map (mk_datatype "and ") ds_tl |
|
471 |
) |
|
472 |
end; |
|
473 |
in |
|
474 |
([], []) |
|
475 |
|> fold group ds |
|
476 |
|-> (fn cons => fold group_cons cons) |
|
477 |
|> mk_datatypes |
|
478 |
end; |
|
479 |
fun ml_from_def (name, Typesyn (vs, ty)) = |
|
480 |
(map (fn (vname, []) => () | _ => error "can't serialize sort constrained type declaration to ML") vs; |
|
481 |
Pretty.block ( |
|
482 |
Pretty.str "type " |
|
483 |
:: postify (map (Pretty.str o fst) vs) (Pretty.str name) |
|
484 |
@ [Pretty.str " =", |
|
485 |
Pretty.brk 1, |
|
486 |
ml_from_typ NOBR ty, |
|
487 |
Pretty.str ";" |
|
488 |
])) |
|
489 |
| ml_from_def (name, Nop) = |
|
490 |
if exists (fn query => (is_some o query) name) |
|
491 |
[(fn name => styco name [] (ml_from_typ NOBR)), |
|
492 |
(fn name => sconst name [] (ml_from_iexpr NOBR))] |
|
493 |
then Pretty.str "" |
|
494 |
else error ("empty statement during serialization: " ^ quote name) |
|
495 |
| ml_from_def (name, Class _) = |
|
496 |
error ("can't serialize class declaration " ^ quote name ^ " to ML") |
|
497 |
| ml_from_def (name, Classinst _) = |
|
498 |
error ("can't serialize instance declaration " ^ quote name ^ " to ML") |
|
499 |
in case (snd o hd) ds |
|
500 |
of Fun _ => ml_from_funs ds |
|
501 |
| Datatypecons _ => ml_from_datatypes ds |
|
502 |
| Datatype _ => ml_from_datatypes ds |
|
503 |
| _ => (case ds of [d] => ml_from_def d) |
|
504 |
end; |
|
505 |
||
506 |
in |
|
507 |
||
18217 | 508 |
fun ml_from_thingol nspgrp name_root styco sconst prims select module = |
18216 | 509 |
let |
510 |
fun ml_from_module (name, ps) = |
|
511 |
Pretty.chunks ([ |
|
512 |
Pretty.str ("structure " ^ name ^ " = "), |
|
513 |
Pretty.str "struct", |
|
514 |
Pretty.str "" |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
515 |
] @ separate (Pretty.str "") ps @ [ |
18216 | 516 |
Pretty.str "", |
517 |
Pretty.str ("end; (* struct " ^ name ^ " *)") |
|
518 |
]); |
|
519 |
fun eta_expander "Pair" = 2 |
|
520 |
| eta_expander "Cons" = 2 |
|
521 |
| eta_expander "primeq" = 2 |
|
522 |
| eta_expander "and" = 2 |
|
523 |
| eta_expander "or" = 2 |
|
524 |
| eta_expander "if" = 3 |
|
525 |
| eta_expander "add" = 2 |
|
526 |
| eta_expander "mult" = 2 |
|
527 |
| eta_expander "lt" = 2 |
|
528 |
| eta_expander "le" = 2 |
|
529 |
| eta_expander s = |
|
530 |
if NameSpace.is_qualified s |
|
531 |
then case get_def module s |
|
532 |
of Datatypecons (_ , tys) => |
|
533 |
if length tys >= 2 then length tys else 0 |
|
534 |
| _ => |
|
535 |
(case sconst s [] (K (Pretty.str "")) |
|
536 |
of NONE => 0 |
|
537 |
| SOME (xs, _) => length xs) |
|
538 |
else 0 |
|
539 |
in |
|
540 |
module |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
541 |
|> debug 12 (Pretty.output o pretty_module) |
18216 | 542 |
|> debug 3 (fn _ => "connecting datatypes and classdecls...") |
543 |
|> connect_datatypes_clsdecls |
|
544 |
|> debug 3 (fn _ => "selecting submodule...") |
|
18217 | 545 |
|> (if is_some select then (partof o the) select else I) |
18216 | 546 |
|> debug 3 (fn _ => "eta-expanding...") |
547 |
|> eta_expand eta_expander |
|
18231 | 548 |
|> debug 3 (fn _ => "eta-expanding polydefs...") |
549 |
|> eta_expand_poly |
|
18247
b17724cae935
code generator: case expressions, improved name resolving
haftmann
parents:
18231
diff
changeset
|
550 |
|> debug 12 (Pretty.output o pretty_module) |
18216 | 551 |
|> debug 3 (fn _ => "tupelizing datatypes...") |
552 |
|> tupelize_cons |
|
553 |
|> debug 3 (fn _ => "eliminating classes...") |
|
554 |
|> eliminate_classes |
|
555 |
|> debug 3 (fn _ => "generating...") |
|
556 |
|> serialize (ml_from_defs styco sconst) ml_from_module (ml_validator prims) nspgrp name_root |
|
557 |
end; |
|
558 |
||
18231 | 559 |
fun ml_from_thingol' nspgrp name_root = |
560 |
Scan.optional ( |
|
561 |
OuterParse.$$$ "(" |-- OuterParse.list1 OuterParse.text --| OuterParse.$$$ ")" |
|
562 |
) [] |
|
563 |
>> (fn _ => ml_from_thingol nspgrp name_root); |
|
564 |
||
18216 | 565 |
(* ML infix precedence |
566 |
7 / * div mod |
|
567 |
6 + - ^ |
|
568 |
5 :: @ |
|
569 |
4 = <> < > <= >= |
|
570 |
3 := o *) |
|
571 |
||
572 |
end; (* local *) |
|
573 |
||
574 |
end; (* struct *) |
|
575 |