changeset 18172 | 8ff5bcfae27a |
parent 18170 | 73ce773f12de |
child 18216 | db7d43b25c99 |
18171:c4f873d65603 | 18172:8ff5bcfae27a |
---|---|
9 sig |
9 sig |
10 type vname = string; |
10 type vname = string; |
11 datatype itype = |
11 datatype itype = |
12 IType of string * itype list |
12 IType of string * itype list |
13 | IFun of itype * itype |
13 | IFun of itype * itype |
14 | IVarT of vname * sort; |
14 | IVarT of vname * sort |
15 | IDictT of (string * itype) list; |
|
15 datatype ipat = |
16 datatype ipat = |
16 ICons of (string * ipat list) * itype |
17 ICons of (string * ipat list) * itype |
17 | IVarP of vname * itype; |
18 | IVarP of vname * itype; |
18 datatype iexpr = |
19 datatype iexpr = |
19 IConst of string * itype |
20 IConst of string * itype |
20 | IVarE of vname * itype |
21 | IVarE of vname * itype |
21 | IApp of iexpr * iexpr |
22 | IApp of iexpr * iexpr |
22 | IInst of iexpr * ClassPackage.sortlookup list list |
23 | IInst of iexpr * ClassPackage.sortlookup list list |
23 | IAbs of (vname * itype) * iexpr |
24 | IAbs of (vname * itype) * iexpr |
24 | ICase of iexpr * (ipat * iexpr) list; |
25 | ICase of iexpr * (ipat * iexpr) list |
26 | IDictE of (string * iexpr) list |
|
27 | ILookup of (string list * vname); |
|
25 val eq_itype: itype * itype -> bool |
28 val eq_itype: itype * itype -> bool |
26 val eq_ipat: ipat * ipat -> bool |
29 val eq_ipat: ipat * ipat -> bool |
27 val eq_iexpr: iexpr * iexpr -> bool |
30 val eq_iexpr: iexpr * iexpr -> bool |
28 val mk_funs: itype list * itype -> itype; |
31 val mk_funs: itype list * itype -> itype; |
29 val mk_apps: iexpr * iexpr list -> iexpr; |
32 val mk_apps: iexpr * iexpr list -> iexpr; |
36 val itype_of_iexpr: iexpr -> itype; |
39 val itype_of_iexpr: iexpr -> itype; |
37 val itype_of_ipat: ipat -> itype; |
40 val itype_of_ipat: ipat -> itype; |
38 val ipat_of_iexpr: iexpr -> ipat; |
41 val ipat_of_iexpr: iexpr -> ipat; |
39 val vars_of_ipats: ipat list -> vname list; |
42 val vars_of_ipats: ipat list -> vname list; |
40 val instant_itype: vname * itype -> itype -> itype; |
43 val instant_itype: vname * itype -> itype -> itype; |
41 val invent_tvar_names: itype list -> int -> vname list -> vname -> vname list; |
44 val invent_var_t_names: itype list -> int -> vname list -> vname -> vname list; |
42 val invent_evar_names: iexpr list -> int -> vname list -> vname -> vname list; |
45 val invent_var_e_names: iexpr list -> int -> vname list -> vname -> vname list; |
43 |
46 |
44 datatype def = |
47 datatype def = |
45 Nop |
48 Nop |
46 | Fun of (ipat list * iexpr) list * (ClassPackage.sortcontext * itype) |
49 | Fun of (ipat list * iexpr) list * (ClassPackage.sortcontext * itype) |
47 | Typsyn of (vname * string list) list * itype |
50 | Typesyn of (vname * string list) list * itype |
48 | Datatyp of (vname * string list) list * string list * string list |
51 | Datatype of (vname * string list) list * string list * string list |
49 | Datatypcons of string * itype list |
52 | Datatypecons of string * itype list |
50 | Class of string list * string list * string list |
53 | Class of string list * string list * string list |
51 | Classmember of string * vname * itype |
54 | Classmember of string * vname * itype |
52 | Classinst of string * (string * string list list) * (string * string) list; |
55 | Classinst of string * (string * string list list) * (string * string) list; |
53 type module; |
56 type module; |
54 type transact; |
57 type transact; |
58 val eq_def: def * def -> bool; |
61 val eq_def: def * def -> bool; |
59 val pretty_def: def -> Pretty.T; |
62 val pretty_def: def -> Pretty.T; |
60 val pretty_module: module -> Pretty.T; |
63 val pretty_module: module -> Pretty.T; |
61 val empty_module: module; |
64 val empty_module: module; |
62 val get_def: module -> string -> def; |
65 val get_def: module -> string -> def; |
63 val map_defs: (def -> def) -> module -> module; |
|
64 val add_deps: (string * def -> (string * string) list) -> module -> module; |
|
65 val fold_defs: (string * def -> 'a -> 'a) -> module -> 'a -> 'a; |
|
66 val fold_map_defs: (string * def -> 'a -> def * 'a) -> module -> 'a -> module * 'a; |
|
67 val merge_module: module * module -> module; |
66 val merge_module: module * module -> module; |
68 val partof: string list -> module -> module; |
67 val partof: string list -> module -> module; |
69 val succeed: 'a -> transact -> 'a transact_fin; |
68 val succeed: 'a -> transact -> 'a transact_fin; |
70 val fail: string -> transact -> 'a transact_fin; |
69 val fail: string -> transact -> 'a transact_fin; |
71 val gen_invoke: (string * ('src, 'dst) gen_codegen) list -> string |
70 val gen_invoke: (string * ('src, 'dst) gen_codegen) list -> string |
72 -> 'src -> transact -> 'dst * transact; |
71 -> 'src -> transact -> 'dst * transact; |
73 val gen_ensure_def: (string * gen_defgen) list -> string |
72 val gen_ensure_def: (string * gen_defgen) list -> string |
74 -> string -> transact -> transact; |
73 -> string -> transact -> transact; |
74 |
|
75 val prims: string list; |
|
76 val extract_defs: iexpr -> string list; |
|
77 val eta_expand: (string -> int) -> module -> module; |
|
78 val connect_datatypes_clsdecls: module -> module; |
|
79 val tupelize_cons: module -> module; |
|
80 val eliminate_dtconstr: module -> module; |
|
81 val eliminate_classes: module -> module; |
|
75 |
82 |
76 val debug_level : int ref; |
83 val debug_level : int ref; |
77 val debug : int -> ('a -> string) -> 'a -> 'a; |
84 val debug : int -> ('a -> string) -> 'a -> 'a; |
78 end; |
85 end; |
79 |
86 |
120 case dest x |
127 case dest x |
121 of NONE => ([], x) |
128 of NONE => ([], x) |
122 | SOME (x1, x2) => |
129 | SOME (x1, x2) => |
123 let val (xs', x') = unfoldr dest x2 in (x1::xs', x') end; |
130 let val (xs', x') = unfoldr dest x2 in (x1::xs', x') end; |
124 |
131 |
132 fun map_yield f [] = ([], []) |
|
133 | map_yield f (x::xs) = |
|
134 let |
|
135 val (y, x') = f x |
|
136 val (ys, xs') = map_yield f xs |
|
137 in (y::ys, x'::xs') end; |
|
138 |
|
125 fun get_prefix eq ([], ys) = ([], [], ys) |
139 fun get_prefix eq ([], ys) = ([], [], ys) |
126 | get_prefix eq (xs, []) = ([], xs, []) |
140 | get_prefix eq (xs, []) = ([], xs, []) |
127 | get_prefix eq (xs as x::xs', ys as y::ys') = |
141 | get_prefix eq (xs as x::xs', ys as y::ys') = |
128 if eq (x, y) then |
142 if eq (x, y) then |
129 let val (ps', xs'', ys'') = get_prefix eq (xs', ys') |
143 let val (ps', xs'', ys'') = get_prefix eq (xs', ys') |
144 type vname = string; |
158 type vname = string; |
145 |
159 |
146 datatype itype = |
160 datatype itype = |
147 IType of string * itype list |
161 IType of string * itype list |
148 | IFun of itype * itype |
162 | IFun of itype * itype |
149 | IVarT of vname * sort; |
163 | IVarT of vname * sort |
164 (*ML auxiliary*) |
|
165 | IDictT of (string * itype) list; |
|
150 |
166 |
151 datatype ipat = |
167 datatype ipat = |
152 ICons of (string * ipat list) * itype |
168 ICons of (string * ipat list) * itype |
153 | IVarP of vname * itype; |
169 | IVarP of vname * itype; |
154 |
170 |
156 IConst of string * itype |
172 IConst of string * itype |
157 | IVarE of vname * itype |
173 | IVarE of vname * itype |
158 | IApp of iexpr * iexpr |
174 | IApp of iexpr * iexpr |
159 | IInst of iexpr * ClassPackage.sortlookup list list |
175 | IInst of iexpr * ClassPackage.sortlookup list list |
160 | IAbs of (vname * itype) * iexpr |
176 | IAbs of (vname * itype) * iexpr |
161 | ICase of iexpr * (ipat * iexpr) list; |
177 | ICase of iexpr * (ipat * iexpr) list |
178 (*ML auxiliary*) |
|
179 | IDictE of (string * iexpr) list |
|
180 | ILookup of (string list * vname); |
|
162 |
181 |
163 val eq_itype = (op =); |
182 val eq_itype = (op =); |
164 val eq_ipat = (op =); |
183 val eq_ipat = (op =); |
165 val eq_iexpr = (op =); |
184 val eq_iexpr = (op =); |
166 |
185 |
182 | _ => NONE); |
201 | _ => NONE); |
183 |
202 |
184 val unfold_let = unfoldr |
203 val unfold_let = unfoldr |
185 (fn ICase (e, [(p, e')]) => SOME ((p, e), e') |
204 (fn ICase (e, [(p, e')]) => SOME ((p, e), e') |
186 | _ => NONE); |
205 | _ => NONE); |
206 |
|
207 fun map_itype f_itype (IType (tyco, tys)) = |
|
208 tyco `%% map f_itype tys |
|
209 | map_itype f_itype (IFun (t1, t2)) = |
|
210 f_itype t1 `-> f_itype t2 |
|
211 | map_itype _ (ty as IVarT _) = |
|
212 ty; |
|
213 |
|
214 fun map_ipat f_itype f_ipat (ICons ((c, ps), ty)) = |
|
215 ICons ((c, map f_ipat ps), f_itype ty) |
|
216 | map_ipat _ _ (p as IVarP _) = |
|
217 p; |
|
218 |
|
219 fun map_iexpr f_itype f_ipat f_iexpr (IApp (e1, e2)) = |
|
220 f_iexpr e1 `$ f_iexpr e2 |
|
221 | map_iexpr f_itype f_ipat f_iexpr (IInst (e, c)) = |
|
222 IInst (f_iexpr e, c) |
|
223 | map_iexpr f_itype f_ipat f_iexpr (IAbs (v, e)) = |
|
224 IAbs (v, f_iexpr e) |
|
225 | map_iexpr f_itype f_ipat f_iexpr (ICase (e, ps)) = |
|
226 ICase (f_iexpr e, map (fn (p, e) => (f_ipat p, f_iexpr e)) ps) |
|
227 | map_iexpr _ _ _ (e as IConst _) = |
|
228 e |
|
229 | map_iexpr _ _ _ (e as IVarE _) = |
|
230 e; |
|
231 |
|
232 fun fold_itype f_itype (IFun (t1, t2)) = |
|
233 f_itype t1 #> f_itype t2 |
|
234 | fold_itype _ (ty as IType _) = |
|
235 I |
|
236 | fold_itype _ (ty as IVarT _) = |
|
237 I; |
|
238 |
|
239 fun fold_ipat f_itype f_ipat (ICons ((_, ps), ty)) = |
|
240 f_itype ty #> fold f_ipat ps |
|
241 | fold_ipat f_itype f_ipat (p as IVarP _) = |
|
242 I; |
|
243 |
|
244 fun fold_iexpr f_itype f_ipat f_iexpr (IApp (e1, e2)) = |
|
245 f_iexpr e1 #> f_iexpr e2 |
|
246 | fold_iexpr f_itype f_ipat f_iexpr (IInst (e, c)) = |
|
247 f_iexpr e |
|
248 | fold_iexpr f_itype f_ipat f_iexpr (IAbs (v, e)) = |
|
249 f_iexpr e |
|
250 | fold_iexpr f_itype f_ipat f_iexpr (ICase (e, ps)) = |
|
251 f_iexpr e #> fold (fn (p, e) => f_ipat p #> f_iexpr e) ps |
|
252 | fold_iexpr _ _ _ (e as IConst _) = |
|
253 I |
|
254 | fold_iexpr _ _ _ (e as IVarE _) = |
|
255 I; |
|
187 |
256 |
188 |
257 |
189 (* simple diagnosis *) |
258 (* simple diagnosis *) |
190 |
259 |
191 fun pretty_itype (IType (tyco, tys)) = |
260 fun pretty_itype (IType (tyco, tys)) = |
263 instant ty1 `-> instant ty2 |
332 instant ty1 `-> instant ty2 |
264 | instant (w as (IVarT (u, _))) = |
333 | instant (w as (IVarT (u, _))) = |
265 if v = u then sty else w |
334 if v = u then sty else w |
266 in instant ty end; |
335 in instant ty end; |
267 |
336 |
268 fun invent_tvar_names tys n used a = |
337 fun invent_var_t_names tys n used a = |
269 let |
338 let |
270 fun invent (IType (_, tys)) = |
339 fun invent (IType (_, tys)) = |
271 fold invent tys |
340 fold invent tys |
272 | invent (IFun (ty1, ty2)) = |
341 | invent (IFun (ty1, ty2)) = |
273 invent ty1 #> invent ty2 |
342 invent ty1 #> invent ty2 |
274 | invent (IVarT (v, _)) = |
343 | invent (IVarT (v, _)) = |
275 cons v |
344 cons v |
276 in Term.invent_names (fold invent tys used) a n end; |
345 in Term.invent_names (fold invent tys used) a n end; |
277 |
346 |
278 fun invent_evar_names es n used a = |
347 fun invent_var_e_names es n used a = |
279 let |
348 let |
280 fun invent (IConst (f, _)) = |
349 fun invent (IConst (f, _)) = |
281 I |
350 I |
282 | invent (IVarE (v, _)) = |
351 | invent (IVarE (v, _)) = |
283 cons v |
352 cons v |
299 (* type definitions *) |
368 (* type definitions *) |
300 |
369 |
301 datatype def = |
370 datatype def = |
302 Nop |
371 Nop |
303 | Fun of (ipat list * iexpr) list * (ClassPackage.sortcontext * itype) |
372 | Fun of (ipat list * iexpr) list * (ClassPackage.sortcontext * itype) |
304 | Typsyn of (vname * string list) list * itype |
373 | Typesyn of (vname * string list) list * itype |
305 | Datatyp of (vname * string list) list * string list * string list |
374 | Datatype of (vname * string list) list * string list * string list |
306 | Datatypcons of string * itype list |
375 | Datatypecons of string * itype list |
307 | Class of string list * string list * string list |
376 | Class of string list * string list * string list |
308 | Classmember of string * string * itype |
377 | Classmember of string * string * itype |
309 | Classinst of string * (string * string list list) * (string * string) list; |
378 | Classinst of string * (string * string list list) * (string * string) list; |
310 |
379 |
311 datatype node = Def of def | Module of node Graph.T; |
380 datatype node = Def of def | Module of node Graph.T; |
333 pretty_iexpr body, |
402 pretty_iexpr body, |
334 Pretty.str "::", |
403 Pretty.str "::", |
335 pretty_itype ty |
404 pretty_itype ty |
336 ]) eqs |
405 ]) eqs |
337 ) |
406 ) |
338 | pretty_def (Typsyn (vs, ty)) = |
407 | pretty_def (Typesyn (vs, ty)) = |
339 Pretty.block [ |
408 Pretty.block [ |
340 Pretty.list "(" ")" (map (pretty_itype o IVarT) vs), |
409 Pretty.list "(" ")" (map (pretty_itype o IVarT) vs), |
341 Pretty.str " |=> ", |
410 Pretty.str " |=> ", |
342 pretty_itype ty |
411 pretty_itype ty |
343 ] |
412 ] |
344 | pretty_def (Datatyp (vs, cs, clss)) = |
413 | pretty_def (Datatype (vs, cs, clss)) = |
345 Pretty.block [ |
414 Pretty.block [ |
346 Pretty.list "(" ")" (map (pretty_itype o IVarT) vs), |
415 Pretty.list "(" ")" (map (pretty_itype o IVarT) vs), |
347 Pretty.str " |=> ", |
416 Pretty.str " |=> ", |
348 Pretty.gen_list " |" "" "" (map Pretty.str cs), |
417 Pretty.gen_list " |" "" "" (map Pretty.str cs), |
349 Pretty.str ", instance of ", |
418 Pretty.str ", instance of ", |
350 Pretty.gen_list "," "[" "]" (map Pretty.str clss) |
419 Pretty.gen_list "," "[" "]" (map Pretty.str clss) |
351 ] |
420 ] |
352 | pretty_def (Datatypcons (dtname, tys)) = |
421 | pretty_def (Datatypecons (dtname, tys)) = |
353 Pretty.block [ |
422 Pretty.block [ |
354 Pretty.str "cons ", |
423 Pretty.str "cons ", |
355 Pretty.gen_list " ->" "" "" (map pretty_itype tys @ [Pretty.str dtname]) |
424 Pretty.gen_list " ->" "" "" (map pretty_itype tys @ [Pretty.str dtname]) |
356 ] |
425 ] |
357 | pretty_def (Class (supcls, mems, insts)) = |
426 | pretty_def (Class (supcls, mems, insts)) = |
469 apfst Def o f (NameSpace.pack (prfix @ [name]), def) |
538 apfst Def o f (NameSpace.pack (prfix @ [name]), def) |
470 | foldmap prfix (name, Module modl) = |
539 | foldmap prfix (name, Module modl) = |
471 apfst Module o Graph.fold_map_nodes (foldmap (prfix @ [name])) modl |
540 apfst Module o Graph.fold_map_nodes (foldmap (prfix @ [name])) modl |
472 in Graph.fold_map_nodes (foldmap []) end; |
541 in Graph.fold_map_nodes (foldmap []) end; |
473 |
542 |
543 fun map_def_fun f_ipat f_iexpr (Fun (eqs, cty)) = |
|
544 Fun (map (fn (ps, rhs) => (map f_ipat ps, f_iexpr rhs)) eqs, cty) |
|
545 | map_def_fun _ _ def = def; |
|
546 |
|
547 fun transform_defs f_def f_ipat f_iexpr s modl = |
|
548 let |
|
549 val (modl', s') = fold_map_defs f_def modl s |
|
550 in |
|
551 modl' |
|
552 |> map_defs (map_def_fun (f_ipat s') (f_iexpr s')) |
|
553 end; |
|
554 |
|
474 fun merge_module modl12 = |
555 fun merge_module modl12 = |
475 let |
556 let |
476 fun join_module (Module m1, Module m2) = |
557 fun join_module (Module m1, Module m2) = |
477 (SOME o Module) (merge_module (m1, m2)) |
558 (SOME o Module) (merge_module (m1, m2)) |
478 | join_module (Def d1, Def d2) = |
559 | join_module (Def d1, Def d2) = |
482 in Graph.join (K join_module) modl12 end; |
563 in Graph.join (K join_module) modl12 end; |
483 |
564 |
484 fun partof names modl = |
565 fun partof names modl = |
485 let |
566 let |
486 datatype pathnode = PN of (string list * (string * pathnode) list); |
567 datatype pathnode = PN of (string list * (string * pathnode) list); |
487 fun mk_path ([], base) (PN (defs, modls)) = |
568 fun mk_ipath ([], base) (PN (defs, modls)) = |
488 PN (base :: defs, modls) |
569 PN (base :: defs, modls) |
489 | mk_path (n::ns, base) (PN (defs, modls)) = |
570 | mk_ipath (n::ns, base) (PN (defs, modls)) = |
490 modls |
571 modls |
491 |> AList.default (op =) (n, PN ([], [])) |
572 |> AList.default (op =) (n, PN ([], [])) |
492 |> AList.map_entry (op =) n (mk_path (ns, base)) |
573 |> AList.map_entry (op =) n (mk_ipath (ns, base)) |
493 |> (pair defs #> PN); |
574 |> (pair defs #> PN); |
494 fun select (PN (defs, modls)) (Module module) = |
575 fun select (PN (defs, modls)) (Module module) = |
495 module |
576 module |
496 |> Graph.subgraph (Graph.all_succs module (defs @ map fst modls)) |
577 |> Graph.subgraph (Graph.all_succs module (defs @ map fst modls)) |
497 |> fold (fn (name, modls) => Graph.map_node name (select modls)) modls |
578 |> fold (fn (name, modls) => Graph.map_node name (select modls)) modls |
498 |> Module; |
579 |> Module; |
499 in |
580 in |
500 Module modl |
581 Module modl |
501 |> select (fold (mk_path o dest_name) (filter NameSpace.is_qualified names) (PN ([], []))) |
582 |> select (fold (mk_ipath o dest_name) (filter NameSpace.is_qualified names) (PN ([], []))) |
502 |> dest_modl |
583 |> dest_modl |
503 end; |
584 end; |
504 |
585 |
505 fun add_check_transform (name, (Datatypcons (dtname, _))) = |
586 fun add_check_transform (name, (Datatypecons (dtname, _))) = |
506 ([([dtname], |
587 ([([dtname], |
507 fn [Datatyp (_, _, [])] => NONE | _ => "attempted to add constructor to already instantiating datatype" |> SOME)], |
588 fn [Datatype (_, _, [])] => NONE | _ => "attempted to add constructor to already instantiating datatype" |> SOME)], |
508 [(dtname, |
589 [(dtname, |
509 fn Datatyp (vs, cs, clss) => Datatyp (vs, name::cs, clss) |
590 fn Datatype (vs, cs, clss) => Datatype (vs, name::cs, clss) |
510 | def => "attempted to add datatype constructor to non-datatype: " |
591 | def => "attempted to add datatype constructor to non-datatype: " |
511 ^ (Pretty.output o pretty_def) def |> error)]) |
592 ^ (Pretty.output o pretty_def) def |> error)]) |
512 | add_check_transform (name, Classmember (clsname, v, ty)) = |
593 | add_check_transform (name, Classmember (clsname, v, ty)) = |
513 let |
594 let |
514 fun check_var (IType (tyco, tys)) s = |
595 fun check_var (IType (tyco, tys)) s = |
535 | add_check_transform (name, Classinst (clsname, (tyco, arity), memdefs)) = |
616 | add_check_transform (name, Classinst (clsname, (tyco, arity), memdefs)) = |
536 let |
617 let |
537 fun check [Classmember (_, v, mtyp_c), Fun (_, (_, mtyp_i))] = |
618 fun check [Classmember (_, v, mtyp_c), Fun (_, (_, mtyp_i))] = |
538 let |
619 let |
539 val mtyp_i' = instant_itype (v, tyco `%% |
620 val mtyp_i' = instant_itype (v, tyco `%% |
540 map2 IVarT ((invent_tvar_names [mtyp_c] (length arity) [] "a"), arity)) mtyp_c; |
621 map2 IVarT ((invent_var_t_names [mtyp_c] (length arity) [] "a"), arity)) mtyp_c; |
541 in if eq_itype (mtyp_i', mtyp_i) (*! PERHAPS TOO STRICT !*) |
622 in if eq_itype (mtyp_i', mtyp_i) (*! PERHAPS TOO STRICT !*) |
542 then NONE |
623 then NONE |
543 else "wrong type signature for class member: " |
624 else "wrong type signature for class member: " |
544 ^ (Pretty.output o pretty_itype) mtyp_i' ^ " expected," |
625 ^ (Pretty.output o pretty_itype) mtyp_i' ^ " expected," |
545 ^ (Pretty.output o pretty_itype) mtyp_i ^ " given" |> SOME end |
626 ^ (Pretty.output o pretty_itype) mtyp_i ^ " given" |> SOME end |
548 [(clsname, |
629 [(clsname, |
549 fn Class (supcs, mems, insts) => Class (supcs, mems, name::insts) |
630 fn Class (supcs, mems, insts) => Class (supcs, mems, name::insts) |
550 | def => "attempted to add class instance to non-class" |
631 | def => "attempted to add class instance to non-class" |
551 ^ (Pretty.output o pretty_def) def |> error), |
632 ^ (Pretty.output o pretty_def) def |> error), |
552 (tyco, |
633 (tyco, |
553 fn Datatyp (vs, cs, clss) => Datatyp (vs, cs, clsname::clss) |
634 fn Datatype (vs, cs, clss) => Datatype (vs, cs, clsname::clss) |
554 | Nop => Nop |
635 | Nop => Nop |
555 | def => "attempted to instantiate non-type to class instance" |
636 | def => "attempted to instantiate non-type to class instance" |
556 ^ (Pretty.output o pretty_def) def |> error)]) |
637 ^ (Pretty.output o pretty_def) def |> error)]) |
557 end |
638 end |
558 | add_check_transform _ = ([], []); |
639 | add_check_transform _ = ([], []); |
618 modl |
699 modl |
619 |> ensure_node name |
700 |> ensure_node name |
620 |-> (fn names => pair (names@deps)) |
701 |-> (fn names => pair (names@deps)) |
621 end; |
702 end; |
622 |
703 |
704 |
|
705 |
|
706 (** primitive language constructs **) |
|
707 |
|
708 val class_eq = "Eqtype"; (*defined for all primitve types and extensionally for all datatypes*) |
|
709 val type_bool = "Bool"; |
|
710 val type_integer = "Integer"; (*infinite!*) |
|
711 val type_float = "Float"; |
|
712 val type_pair = "Pair"; |
|
713 val type_list = "List"; |
|
714 val cons_true = "True"; |
|
715 val cons_false = "False"; |
|
716 val cons_not = "not"; |
|
717 val cons_pair = "Pair"; |
|
718 val cons_nil = "Nil"; |
|
719 val cons_cons = "Cons"; |
|
720 val fun_primeq = "primeq"; (*defined for all primitive types*) |
|
721 val fun_eq = "eq"; (*to class eq*) |
|
722 val fun_not = "not"; |
|
723 val fun_and = "and"; |
|
724 val fun_or = "or"; |
|
725 val fun_if = "if"; |
|
726 val fun_fst = "fst"; |
|
727 val fun_snd = "snd"; |
|
728 val fun_add = "add"; |
|
729 val fun_mult = "mult"; |
|
730 val fun_minus = "minus"; |
|
731 val fun_lt = "lt"; |
|
732 val fun_le = "le"; |
|
733 val fun_wfrec = "wfrec"; |
|
734 |
|
735 local |
|
736 |
|
737 val A = IVarT ("a", []); |
|
738 val B = IVarT ("b", []); |
|
739 val E = IVarT ("e", [class_eq]); |
|
740 |
|
741 in |
|
742 |
|
743 val Type_bool = type_bool `%% []; |
|
744 val Type_integer = type_integer `%% []; |
|
745 val Type_float = type_float `%% []; |
|
746 fun Type_pair a b = type_pair `%% [a, b]; |
|
747 fun Type_list a = type_list `%% [a]; |
|
748 val Cons_true = IConst (cons_true, Type_bool); |
|
749 val Cons_false = IConst (cons_false, Type_bool); |
|
750 val Cons_pair = IConst (cons_pair, A `-> B `-> Type_pair A B); |
|
751 val Cons_nil = IConst (cons_nil, Type_list A); |
|
752 val Cons_cons = IConst (cons_cons, A `-> Type_list A `-> Type_list A); |
|
753 val Fun_eq = IConst (fun_eq, E `-> E `-> Type_bool); |
|
754 val Fun_not = IConst (fun_not, Type_bool `-> Type_bool); |
|
755 val Fun_and = IConst (fun_and, Type_bool `-> Type_bool `-> Type_bool); |
|
756 val Fun_or = IConst (fun_or, Type_bool `-> Type_bool `-> Type_bool); |
|
757 val Fun_if = IConst (fun_if, Type_bool `-> A `-> A `-> A); |
|
758 val Fun_fst = IConst (fun_fst, Type_pair A B `-> A); |
|
759 val Fun_snd = IConst (fun_snd, Type_pair A B `-> B); |
|
760 val Fun_0 = IConst ("0", Type_integer); |
|
761 val Fun_1 = IConst ("1", Type_integer); |
|
762 val Fun_add = IConst (fun_add, Type_integer `-> Type_integer `-> Type_integer); |
|
763 val Fun_mult = IConst (fun_mult, Type_integer `-> Type_integer `-> Type_integer); |
|
764 val Fun_minus = IConst (fun_minus, Type_integer `-> Type_integer); |
|
765 val Fun_lt = IConst (fun_lt, Type_integer `-> Type_integer `-> Type_bool); |
|
766 val Fun_le = IConst (fun_le, Type_integer `-> Type_integer `-> Type_bool); |
|
767 val Fun_wfrec = IConst (fun_wfrec, ((A `-> B) `-> A `-> B) `-> A `-> B); |
|
768 |
|
769 infix 7 xx; |
|
770 infix 5 **; |
|
771 infix 5 &&; |
|
772 |
|
773 fun a xx b = Type_pair a b; |
|
774 fun a ** b = |
|
775 let |
|
776 val ty_a = itype_of_iexpr a; |
|
777 val ty_b = itype_of_iexpr b; |
|
778 in IConst (cons_pair, ty_a `-> ty_b `-> ty_a xx ty_b) `$ a `$ b end; |
|
779 fun a && b = |
|
780 let |
|
781 val ty_a = itype_of_ipat a; |
|
782 val ty_b = itype_of_ipat b; |
|
783 in ICons ((cons_pair, [a, b]), ty_a xx ty_b) end; |
|
784 |
|
785 end; (* local *) |
|
786 |
|
787 val prims = [class_eq, type_bool, type_integer, type_float, type_pair, type_list, |
|
788 cons_true, cons_false, cons_pair, cons_nil, cons_cons, fun_primeq, fun_eq, fun_not, fun_and, |
|
789 fun_or, fun_if, fun_fst, fun_snd, fun_add, fun_mult, fun_minus, fun_lt, fun_le, fun_wfrec]; |
|
790 |
|
791 fun extract_defs e = |
|
792 let |
|
793 fun extr_itype (ty as IType (tyco, _)) = |
|
794 cons tyco #> fold_itype extr_itype ty |
|
795 | extr_itype ty = |
|
796 fold_itype extr_itype ty |
|
797 fun extr_ipat (p as ICons ((c, _), _)) = |
|
798 cons c #> fold_ipat extr_itype extr_ipat p |
|
799 | extr_ipat p = |
|
800 fold_ipat extr_itype extr_ipat p |
|
801 fun extr_iexpr (e as IConst (f, _)) = |
|
802 cons f #> fold_iexpr extr_itype extr_ipat extr_iexpr e |
|
803 | extr_iexpr e = |
|
804 fold_iexpr extr_itype extr_ipat extr_iexpr e |
|
805 in extr_iexpr e [] end; |
|
806 |
|
807 |
|
808 |
|
809 (** generic transformation **) |
|
810 |
|
811 fun eta_expand query = |
|
812 let |
|
813 fun eta_app ((f, ty), es) = |
|
814 let |
|
815 val delta = query f - length es; |
|
816 val add_n = if delta < 0 then 0 else delta; |
|
817 val add_vars = |
|
818 invent_var_e_names es add_n [] "x" ~~ Library.drop (length es, (fst o unfold_fun) ty); |
|
819 in |
|
820 Library.foldr IAbs (add_vars, IConst (f, ty) `$$ es `$$ (map IVarE add_vars)) |
|
821 end; |
|
822 fun eta_iexpr' e = map_iexpr I I eta_iexpr e |
|
823 and eta_iexpr (IConst (f, ty)) = |
|
824 eta_app ((f, ty), []) |
|
825 | eta_iexpr (e as IApp _) = |
|
826 (case (unfold_app e) |
|
827 of (IConst (f, ty), es) => |
|
828 eta_app ((f, ty), map eta_iexpr es) |
|
829 | _ => eta_iexpr' e) |
|
830 | eta_iexpr e = eta_iexpr' e; |
|
831 in map_defs (map_def_fun I eta_iexpr) end; |
|
832 |
|
833 fun connect_datatypes_clsdecls module = |
|
834 let |
|
835 fun extract_dep (name, Datatypecons (dtname, _)) = |
|
836 [(dtname, name)] |
|
837 | extract_dep (name, Classmember (cls, _, _)) = |
|
838 [(cls, name)] |
|
839 | extract_dep (name, def) = [] |
|
840 in add_deps extract_dep module end; |
|
841 |
|
842 fun tupelize_cons module = |
|
843 let |
|
844 fun replace_def (_, (def as Datatypecons (_, []))) acc = |
|
845 (def, acc) |
|
846 | replace_def (_, (def as Datatypecons (_, [_]))) acc = |
|
847 (def, acc) |
|
848 | replace_def (name, (Datatypecons (tyco, tys))) acc = |
|
849 (Datatypecons (tyco, |
|
850 [foldl' (op xx) (NONE, tys)]), name::acc) |
|
851 | replace_def (_, def) acc = (def, acc); |
|
852 fun replace_app cs ((f, ty), es) = |
|
853 if member (op =) cs f |
|
854 then |
|
855 let |
|
856 val (tys, ty') = unfold_fun ty |
|
857 in IConst (f, foldr' (op xx) (tys, NONE) `-> ty') `$ foldl' (op **) (NONE, es) end |
|
858 else IConst (f, ty) `$$ es; |
|
859 fun replace_iexpr cs (IConst (f, ty)) = |
|
860 replace_app cs ((f, ty), []) |
|
861 | replace_iexpr cs (e as IApp _) = |
|
862 (case unfold_app e |
|
863 of (IConst fty, es) => replace_app cs (fty, map (replace_iexpr cs) es) |
|
864 | _ => map_iexpr I I (replace_iexpr cs) e) |
|
865 | replace_iexpr cs e = map_iexpr I I (replace_iexpr cs) e; |
|
866 fun replace_ipat cs (p as ICons ((c, ps), ty)) = |
|
867 if member (op =) cs c then |
|
868 ICons ((c, [(foldl' (op &&) (NONE, map (replace_ipat cs) ps))]), ty) |
|
869 else map_ipat I (replace_ipat cs) p |
|
870 | replace_ipat cs p = map_ipat I (replace_ipat cs) p; |
|
871 in |
|
872 transform_defs replace_def replace_ipat replace_iexpr [cons_cons] module |
|
873 end; |
|
874 |
|
875 fun eliminate_dtconstr module = |
|
876 let |
|
877 fun replace_def (name, (Datatype (vs, cs, is))) acc = |
|
878 (Datatype (map (fn (v, _) => (v, [])) vs, cs, is), (name, vs)::acc) |
|
879 | replace_def (_, def) acc = (def, acc); |
|
880 fun constrain (ty as IType _, _) = |
|
881 ty |
|
882 | constrain (IVarT (v, sort1), (_, sort2)) = |
|
883 IVarT (v, gen_union (op =) (sort1, sort2)); |
|
884 fun replace_ty tycos (ty as (IType (tyco, tys))) = |
|
885 (case AList.lookup (op =) tycos tyco |
|
886 of NONE => ty |
|
887 | SOME vs => IType (tyco, map2 constrain (tys, vs))) |
|
888 | replace_ty tycos ty = |
|
889 map_itype (replace_ty tycos) ty; |
|
890 in |
|
891 transform_defs replace_def |
|
892 (*! HIER FEHLT NOCH: ÄNDERN VON TYP UND SORTCTXT BEI FUNS !*) |
|
893 (fn tycos => map_ipat (replace_ty tycos) I) |
|
894 (fn tycos => map_iexpr (replace_ty tycos) (map_ipat (replace_ty tycos) I) I) [] module |
|
895 end; |
|
896 |
|
897 fun eliminate_classes module = |
|
898 let |
|
899 fun mk_cls_typ_map memberdecls ty_inst = |
|
900 map (fn (memname, (v, ty)) => |
|
901 (memname, ty |> instant_itype (v, ty_inst))) memberdecls; |
|
902 fun transform_dicts (Class (supcls, members, insts)) = |
|
903 let |
|
904 val memberdecls = AList.make |
|
905 ((fn Classmember (_, v, ty) => (v, ty)) o get_def module) members; |
|
906 val varname_cls = invent_var_t_names (map (snd o snd) memberdecls) 1 [] "a" |> hd; |
|
907 in |
|
908 Typesyn ([(varname_cls, [])], IDictT (mk_cls_typ_map memberdecls (IVarT (varname_cls, [])))) |
|
909 end |
|
910 | transform_dicts (Classinst (tyco, (cls, arity), memdefs)) = |
|
911 let |
|
912 val Class (_, members, _) = get_def module cls; |
|
913 val memberdecls = AList.make |
|
914 ((fn Classmember (_, v, ty) => (v, ty)) o get_def module) members; |
|
915 val ty_arity = tyco `%% map IVarT (invent_var_t_names (map (snd o snd) memberdecls) |
|
916 (length arity) [] "a" ~~ arity); |
|
917 val inst_typ_map = mk_cls_typ_map memberdecls ty_arity; |
|
918 val memdefs_ty = map (fn (memname, memprim) => |
|
919 (memname, (memprim, (the o AList.lookup (op =) inst_typ_map) memname))) memdefs; |
|
920 in |
|
921 Fun ([([], IDictE (map (apsnd IConst) memdefs_ty))], |
|
922 ([], IDictT inst_typ_map)) |
|
923 end |
|
924 | transform_dicts d = d |
|
925 fun transform_defs (Fun (ds, (sortctxt, ty))) = |
|
926 let |
|
927 fun reduce f xs = foldl' f (NONE, xs); |
|
928 val varnames_ctxt = |
|
929 sortctxt |
|
930 |> length o Library.flat o map snd |
|
931 |> (fn used => invent_var_e_names (map snd ds) used ((vars_of_ipats o fst o hd) ds) "d") |
|
932 |> unflat (map snd sortctxt); |
|
933 val vname_alist = map2 (fn ((vt, sort), vs) => (vt, vs ~~ sort)) (sortctxt, varnames_ctxt); |
|
934 fun add_typarms ty = |
|
935 map (reduce (op xx) o (fn (vt, vss) => map (fn (_, cls) => cls `%% [IVarT (vt, [])]) vss)) vname_alist |
|
936 `--> ty; |
|
937 fun add_parms ps = |
|
938 map (reduce (op &&) o (fn (vt, vss) => map (fn (v, cls) => IVarP (v, cls `%% [IVarT (vt, [])])) vss)) vname_alist |
|
939 @ ps; |
|
940 fun transform_itype (IVarT (v, s)) = |
|
941 IVarT (v, []) |
|
942 | transform_itype ty = |
|
943 map_itype transform_itype ty; |
|
944 fun transform_ipat p = |
|
945 map_ipat transform_itype transform_ipat p; |
|
946 fun transform_lookup (ClassPackage.Instance ((cdict, idict), ls)) = |
|
947 ls |
|
948 |> transform_lookups |
|
949 |-> (fn ty => |
|
950 curry mk_apps (IConst (idict, cdict `%% ty)) |
|
951 #> pair (cdict `%% ty)) |
|
952 | transform_lookup (ClassPackage.Lookup (deriv, (v, i))) = |
|
953 let |
|
954 val (v', cls) = |
|
955 (nth o the oo AList.lookup (op =)) vname_alist v i; |
|
956 fun mk_parm tyco = tyco `%% [IVarT (v, [])]; |
|
957 in (mk_parm (hd (deriv)), ILookup (rev deriv, v')) end |
|
958 and transform_lookups lss = |
|
959 map_yield (map_yield transform_lookup |
|
960 #> apfst (reduce (op xx)) |
|
961 #> apsnd (reduce (op **))) lss; |
|
962 fun transform_iexpr (IInst (e, ls)) = |
|
963 transform_iexpr e `$$ (snd o transform_lookups) ls |
|
964 | transform_iexpr e = |
|
965 map_iexpr transform_itype transform_ipat transform_iexpr e; |
|
966 fun transform_rhs (ps, rhs) = (add_parms ps, transform_iexpr rhs) |
|
967 in Fun (map transform_rhs ds, ([], add_typarms ty)) end |
|
968 | transform_defs d = d |
|
969 in |
|
970 module |
|
971 |> map_defs transform_dicts |
|
972 |> map_defs transform_defs |
|
973 end; |
|
974 |
|
623 end; (* struct *) |
975 end; (* struct *) |
624 |
976 |
625 |
977 |
626 structure CodegenThingol : CODEGEN_THINGOL = |
978 structure CodegenThingol : CODEGEN_THINGOL = |
627 struct |
979 struct |
628 |
980 |
629 open CodegenThingolOp; |
981 open CodegenThingolOp; |
630 |
982 |
631 end; (* struct *) |
983 end; (* struct *) |
632 |