18168
|
1 |
(* Title: Pure/Tools/class_package.ML
|
|
2 |
ID: $Id$
|
|
3 |
Author: Florian Haftmann, TU Muenchen
|
|
4 |
|
|
5 |
Haskell98-like operational view on type classes.
|
|
6 |
*)
|
|
7 |
|
|
8 |
signature CLASS_PACKAGE =
|
|
9 |
sig
|
18335
|
10 |
val add_classentry: class -> string list -> string list -> theory -> theory
|
18168
|
11 |
val the_consts: theory -> class -> string list
|
|
12 |
val the_tycos: theory -> class -> (string * string) list
|
|
13 |
|
|
14 |
val is_class: theory -> class -> bool
|
|
15 |
val get_arities: theory -> sort -> string -> sort list
|
|
16 |
val get_superclasses: theory -> class -> class list
|
18304
|
17 |
val get_const_sign: theory -> string -> string -> typ
|
18168
|
18 |
val get_inst_consts_sign: theory -> string * class -> (string * typ) list
|
|
19 |
val lookup_const_class: theory -> string -> class option
|
|
20 |
val get_classtab: theory -> (string list * (string * string) list) Symtab.table
|
|
21 |
|
|
22 |
type sortcontext = (string * sort) list
|
|
23 |
datatype sortlookup = Instance of (class * string) * sortlookup list list
|
|
24 |
| Lookup of class list * (string * int)
|
|
25 |
val extract_sortctxt: theory -> typ -> sortcontext
|
|
26 |
val extract_sortlookup: theory -> typ * typ -> sortlookup list list
|
|
27 |
end;
|
|
28 |
|
|
29 |
structure ClassPackage: CLASS_PACKAGE =
|
|
30 |
struct
|
|
31 |
|
|
32 |
|
|
33 |
(* data kind 'Pure/classes' *)
|
|
34 |
|
|
35 |
type class_data = {
|
|
36 |
locale_name: string,
|
|
37 |
axclass_name: string,
|
|
38 |
consts: string list,
|
|
39 |
tycos: (string * string) list
|
|
40 |
};
|
|
41 |
|
|
42 |
structure ClassesData = TheoryDataFun (
|
|
43 |
struct
|
|
44 |
val name = "Pure/classes";
|
|
45 |
type T = class_data Symtab.table * class Symtab.table;
|
|
46 |
val empty = (Symtab.empty, Symtab.empty);
|
|
47 |
val copy = I;
|
|
48 |
val extend = I;
|
|
49 |
fun merge _ ((t1, r1), (t2, r2))=
|
|
50 |
(Symtab.merge (op =) (t1, t2),
|
|
51 |
Symtab.merge (op =) (r1, r2));
|
|
52 |
fun print _ (tab, _) = (Pretty.writeln o Pretty.chunks) (map Pretty.str (Symtab.keys tab));
|
|
53 |
end
|
|
54 |
);
|
|
55 |
|
|
56 |
val lookup_class_data = Symtab.lookup o fst o ClassesData.get;
|
|
57 |
val lookup_const_class = Symtab.lookup o snd o ClassesData.get;
|
|
58 |
|
|
59 |
fun get_class_data thy class =
|
|
60 |
case lookup_class_data thy class
|
|
61 |
of NONE => error ("undeclared class " ^ quote class)
|
|
62 |
| SOME data => data;
|
|
63 |
|
|
64 |
fun put_class_data class data =
|
|
65 |
ClassesData.map (apfst (Symtab.update (class, data)));
|
|
66 |
fun add_const class const =
|
|
67 |
ClassesData.map (apsnd (Symtab.update (const, class)));
|
|
68 |
|
|
69 |
|
|
70 |
(* name mangling *)
|
|
71 |
|
|
72 |
fun get_locale_for_class thy class =
|
|
73 |
#locale_name (get_class_data thy class);
|
|
74 |
|
|
75 |
fun get_axclass_for_class thy class =
|
|
76 |
#axclass_name (get_class_data thy class);
|
|
77 |
|
|
78 |
|
|
79 |
(* assign consts to type classes *)
|
|
80 |
|
|
81 |
local
|
|
82 |
|
|
83 |
fun gen_add_consts prep_class prep_const (raw_class, raw_consts_new) thy =
|
|
84 |
let
|
|
85 |
val class = prep_class thy raw_class;
|
|
86 |
val consts_new = map (prep_const thy) raw_consts_new;
|
|
87 |
val {locale_name, axclass_name, consts, tycos} =
|
|
88 |
get_class_data thy class;
|
|
89 |
in
|
|
90 |
thy
|
|
91 |
|> put_class_data class {
|
|
92 |
locale_name = locale_name,
|
|
93 |
axclass_name = axclass_name,
|
|
94 |
consts = consts @ consts_new,
|
|
95 |
tycos = tycos
|
|
96 |
}
|
|
97 |
|> fold (add_const class) consts_new
|
|
98 |
end;
|
|
99 |
|
|
100 |
in
|
|
101 |
|
|
102 |
val add_consts = gen_add_consts Sign.intern_class Sign.intern_const;
|
|
103 |
val add_consts_i = gen_add_consts (K I) (K I);
|
|
104 |
|
|
105 |
end; (* local *)
|
|
106 |
|
|
107 |
val the_consts = #consts oo get_class_data;
|
|
108 |
|
|
109 |
|
|
110 |
(* assign type constructors to type classes *)
|
|
111 |
|
|
112 |
local
|
|
113 |
|
|
114 |
fun gen_add_tycos prep_class prep_type (raw_class, raw_tycos_new) thy =
|
|
115 |
let
|
|
116 |
val class = prep_class thy raw_class
|
|
117 |
val tycos_new = map (prep_type thy) raw_tycos_new
|
|
118 |
val {locale_name, axclass_name, consts, tycos} =
|
|
119 |
get_class_data thy class
|
|
120 |
in
|
|
121 |
thy
|
|
122 |
|> put_class_data class {
|
|
123 |
locale_name = locale_name,
|
|
124 |
axclass_name = axclass_name,
|
|
125 |
consts = consts,
|
|
126 |
tycos = tycos @ tycos_new
|
|
127 |
}
|
|
128 |
end;
|
|
129 |
|
|
130 |
in
|
|
131 |
|
|
132 |
fun add_tycos xs thy =
|
|
133 |
gen_add_tycos Sign.intern_class (rpair (Context.theory_name thy) oo Sign.intern_type) xs thy;
|
|
134 |
val add_tycos_i = gen_add_tycos (K I) (K I);
|
|
135 |
|
|
136 |
end; (* local *)
|
|
137 |
|
|
138 |
val the_tycos = #tycos oo get_class_data;
|
|
139 |
|
|
140 |
|
|
141 |
(* class queries *)
|
|
142 |
|
|
143 |
fun is_class thy = is_some o lookup_class_data thy;
|
|
144 |
|
|
145 |
fun filter_class thy = filter (is_class thy);
|
|
146 |
|
|
147 |
fun assert_class thy class =
|
|
148 |
if is_class thy class then class
|
|
149 |
else error ("not a class: " ^ quote class);
|
|
150 |
|
|
151 |
fun get_arities thy sort tycon =
|
|
152 |
Sorts.mg_domain (Sign.classes_arities_of thy) tycon sort
|
|
153 |
|> (map o map) (assert_class thy);
|
|
154 |
|
|
155 |
fun get_superclasses thy class =
|
|
156 |
Sorts.superclasses (Sign.classes_of thy) class
|
|
157 |
|> filter_class thy;
|
|
158 |
|
|
159 |
|
|
160 |
(* instance queries *)
|
|
161 |
|
18304
|
162 |
fun get_const_sign thy tvar const =
|
18168
|
163 |
let
|
|
164 |
val class = (the o lookup_const_class thy) const;
|
18335
|
165 |
val (ty, thaw) = (Type.freeze_thaw_type o Sign.the_const_constraint thy) const;
|
18304
|
166 |
val tvars_used = Term.add_tfreesT ty [];
|
|
167 |
val tvar_rename = hd (Term.invent_names (map fst tvars_used) tvar 1);
|
|
168 |
in
|
|
169 |
ty
|
|
170 |
|> map_type_tfree (fn (tvar', sort) =>
|
|
171 |
if Sorts.sort_eq (Sign.classes_of thy) ([class], sort)
|
|
172 |
then TFree (tvar, [])
|
|
173 |
else if tvar' = tvar
|
18335
|
174 |
then TVar ((tvar_rename, 0), sort)
|
18304
|
175 |
else TFree (tvar', sort))
|
18335
|
176 |
|> thaw
|
18304
|
177 |
end;
|
18168
|
178 |
|
|
179 |
fun get_inst_consts_sign thy (tyco, class) =
|
|
180 |
let
|
|
181 |
val consts = the_consts thy class;
|
|
182 |
val arities = get_arities thy [class] tyco;
|
18304
|
183 |
val const_signs = map (get_const_sign thy "'a") consts;
|
|
184 |
val vars_used = fold (fn ty => curry (gen_union (op =))
|
|
185 |
(map fst (typ_tfrees ty) |> remove (op =) "'a")) const_signs [];
|
18168
|
186 |
val vars_new = Term.invent_names vars_used "'a" (length arities);
|
18330
|
187 |
val typ_arity = Type (tyco, map2 (curry TFree) vars_new arities);
|
18168
|
188 |
val instmem_signs =
|
18335
|
189 |
map (typ_subst_TVars [(("'a", 0), typ_arity)]) const_signs;
|
18168
|
190 |
in consts ~~ instmem_signs end;
|
|
191 |
|
|
192 |
fun get_classtab thy =
|
|
193 |
Symtab.fold
|
|
194 |
(fn (class, { consts = consts, tycos = tycos, ... }) =>
|
|
195 |
Symtab.update_new (class, (consts, tycos)))
|
|
196 |
(fst (ClassesData.get thy)) Symtab.empty;
|
|
197 |
|
|
198 |
|
|
199 |
(* extracting dictionary obligations from types *)
|
|
200 |
|
|
201 |
type sortcontext = (string * sort) list;
|
|
202 |
|
18335
|
203 |
fun extract_sortctxt thy ty =
|
|
204 |
(typ_tfrees o Type.no_tvars) ty
|
18168
|
205 |
|> map (apsnd (filter_class thy))
|
|
206 |
|> filter (not o null o snd);
|
|
207 |
|
|
208 |
datatype sortlookup = Instance of (class * string) * sortlookup list list
|
|
209 |
| Lookup of class list * (string * int)
|
|
210 |
|
|
211 |
fun extract_sortlookup thy (raw_typ_def, raw_typ_use) =
|
|
212 |
let
|
|
213 |
val typ_def = Type.varifyT raw_typ_def;
|
|
214 |
val typ_use = Type.varifyT raw_typ_use;
|
|
215 |
val match_tab = Sign.typ_match thy (typ_def, typ_use) Vartab.empty;
|
|
216 |
fun tab_lookup vname = (the o Vartab.lookup match_tab) (vname, 0);
|
|
217 |
fun get_superclass_derivation (subclasses, superclass) =
|
|
218 |
(the oo get_first) (fn subclass =>
|
|
219 |
Sorts.class_le_path (Sign.classes_of thy) (subclass, superclass)
|
|
220 |
) subclasses;
|
|
221 |
fun mk_class_deriv thy subclasses superclass =
|
|
222 |
case get_superclass_derivation (subclasses, superclass)
|
|
223 |
of (subclass::deriv) => (rev deriv, find_index_eq subclass subclasses);
|
|
224 |
fun mk_lookup (sort_def, (Type (tycon, tys))) =
|
|
225 |
let
|
18330
|
226 |
val arity_lookup = map2 (curry mk_lookup)
|
|
227 |
(map (filter_class thy) (Sorts.mg_domain (Sign.classes_arities_of thy) tycon sort_def)) tys
|
18168
|
228 |
in map (fn class => Instance ((class, tycon), arity_lookup)) sort_def end
|
|
229 |
| mk_lookup (sort_def, TVar ((vname, _), sort_use)) =
|
|
230 |
let
|
|
231 |
fun mk_look class =
|
|
232 |
let val (deriv, classindex) = mk_class_deriv thy sort_use class
|
|
233 |
in Lookup (deriv, (vname, classindex)) end;
|
|
234 |
in map mk_look sort_def end;
|
|
235 |
in
|
18335
|
236 |
extract_sortctxt thy ((fst o Type.freeze_thaw_type) raw_typ_def)
|
18168
|
237 |
|> map (tab_lookup o fst)
|
|
238 |
|> map (apfst (filter_class thy))
|
|
239 |
|> filter (not o null o fst)
|
|
240 |
|> map mk_lookup
|
|
241 |
end;
|
|
242 |
|
|
243 |
|
18335
|
244 |
(* intermediate auxiliary *)
|
18168
|
245 |
|
18335
|
246 |
fun add_classentry raw_class raw_consts raw_tycos thy =
|
18168
|
247 |
let
|
|
248 |
val class = Sign.intern_class thy raw_class;
|
|
249 |
in
|
|
250 |
thy
|
|
251 |
|> put_class_data class {
|
|
252 |
locale_name = "",
|
|
253 |
axclass_name = class,
|
|
254 |
consts = [],
|
|
255 |
tycos = []
|
|
256 |
}
|
|
257 |
|> add_consts (class, raw_consts)
|
|
258 |
|> add_tycos (class, raw_tycos)
|
18335
|
259 |
end;
|
|
260 |
|
18168
|
261 |
|
|
262 |
(* setup *)
|
|
263 |
|
|
264 |
val _ = Context.add_setup [ClassesData.init];
|
|
265 |
|
|
266 |
end; (* struct *)
|