100 |
100 |
101 val timing = ref false; |
101 val timing = ref false; |
102 |
102 |
103 local |
103 local |
104 |
104 |
105 exception INVALID of string list * string; |
105 exception CLASS_ERROR of string list * string; |
106 |
106 |
107 fun resort_thms algebra tap_typ [] = [] |
107 fun resort_thms algebra tap_typ [] = [] |
108 | resort_thms algebra tap_typ (thms as thm :: _) = |
108 | resort_thms algebra tap_typ (thms as thm :: _) = |
109 let |
109 let |
110 val thy = Thm.theory_of_thm thm; |
110 val thy = Thm.theory_of_thm thm; |
|
111 val pp = Sign.pp thy; |
111 val cs = fold_consts (insert (op =)) thms []; |
112 val cs = fold_consts (insert (op =)) thms []; |
|
113 fun class_error (c, ty_decl) e = |
|
114 error ; |
112 fun match_const c (ty, ty_decl) = |
115 fun match_const c (ty, ty_decl) = |
113 let |
116 let |
114 val tys = Sign.const_typargs thy (c, ty); |
117 val tys = Sign.const_typargs thy (c, ty); |
115 val sorts = map (snd o dest_TVar) (Sign.const_typargs thy (c, ty_decl)); |
118 val sorts = map (snd o dest_TVar) (Sign.const_typargs thy (c, ty_decl)); |
116 in fold2 (curry (CodeUnit.typ_sort_inst algebra)) tys sorts end; |
119 in fn tab => fold2 (Type.typ_of_sort algebra) tys sorts tab |
|
120 handle Sorts.CLASS_ERROR e => raise CLASS_ERROR ([c], Sorts.msg_class_error pp e ^ ",\n" |
|
121 ^ "for constant " ^ CodeUnit.string_of_const thy c |
|
122 ^ "\nin defining equations(s)\n" |
|
123 ^ (cat_lines o map string_of_thm) thms) |
|
124 end; |
117 fun match (c, ty) = |
125 fun match (c, ty) = |
118 case tap_typ c |
126 case tap_typ c |
119 of SOME ty_decl => match_const c (ty, ty_decl) |
127 of SOME ty_decl => match_const c (ty, ty_decl) |
120 | NONE => I; |
128 | NONE => I; |
121 val tvars = fold match cs Vartab.empty; |
129 val tvars = fold match cs Vartab.empty; |
122 in map (CodeUnit.inst_thm tvars) thms end; |
130 in map (CodeUnit.inst_thm tvars) thms end; |
123 |
131 |
124 fun resort_funcss thy algebra funcgr = |
132 fun resort_funcss thy algebra funcgr = |
125 let |
133 let |
126 val typ_funcgr = try (fst o Graph.get_node funcgr); |
134 val typ_funcgr = try (fst o Graph.get_node funcgr); |
127 fun resort_dep (const, thms) = (const, resort_thms algebra typ_funcgr thms) |
135 val resort_dep = apsnd (resort_thms algebra typ_funcgr); |
128 handle Sorts.CLASS_ERROR e => raise INVALID ([const], Sorts.msg_class_error (Sign.pp thy) e |
|
129 ^ ",\nfor constant " ^ CodeUnit.string_of_const thy const |
|
130 ^ "\nin defining equations\n" |
|
131 ^ (cat_lines o map string_of_thm) thms) |
|
132 fun resort_rec tap_typ (const, []) = (true, (const, [])) |
136 fun resort_rec tap_typ (const, []) = (true, (const, [])) |
133 | resort_rec tap_typ (const, thms as thm :: _) = |
137 | resort_rec tap_typ (const, thms as thm :: _) = |
134 let |
138 let |
135 val (_, ty) = CodeUnit.head_func thm; |
139 val (_, ty) = CodeUnit.head_func thm; |
136 val thms' as thm' :: _ = resort_thms algebra tap_typ thms |
140 val thms' as thm' :: _ = resort_thms algebra tap_typ thms |
218 val SOME class = AxClass.class_of_param thy c'; |
222 val SOME class = AxClass.class_of_param thy c'; |
219 val sorts_decl = Sorts.mg_domain algebra tyco [class]; |
223 val sorts_decl = Sorts.mg_domain algebra tyco [class]; |
220 val tys = Sign.const_typargs thy (c, ty); |
224 val tys = Sign.const_typargs thy (c, ty); |
221 val sorts = map (snd o dest_TVar) tys; |
225 val sorts = map (snd o dest_TVar) tys; |
222 in if sorts = sorts_decl then ty |
226 in if sorts = sorts_decl then ty |
223 else raise INVALID ([c], "Illegal instantation for class operation " |
227 else raise CLASS_ERROR ([c], "Illegal instantation for class operation " |
224 ^ CodeUnit.string_of_const thy c |
228 ^ CodeUnit.string_of_const thy c |
225 ^ "\nin defining equations\n" |
229 ^ "\nin defining equations\n" |
226 ^ (cat_lines o map string_of_thm) thms) |
230 ^ (cat_lines o map (string_of_thm o AxClass.overload thy)) thms) |
227 end |
231 end |
228 | NONE => (snd o CodeUnit.head_func) thm; |
232 | NONE => (snd o CodeUnit.head_func) thm; |
229 fun add_funcs (const, thms) = |
233 fun add_funcs (const, thms) = |
230 Graph.new_node (const, (typ_func const thms, thms)); |
234 Graph.new_node (const, (typ_func const thms, thms)); |
231 fun add_deps (funcs as (const, thms)) funcgr = |
235 fun add_deps (funcs as (const, thms)) funcgr = |
251 in |
255 in |
252 funcgr |
256 funcgr |
253 |> fold (merge_funcss thy algebra) |
257 |> fold (merge_funcss thy algebra) |
254 (map (AList.make (Graph.get_node auxgr)) |
258 (map (AList.make (Graph.get_node auxgr)) |
255 (rev (Graph.strong_conn auxgr))) |
259 (rev (Graph.strong_conn auxgr))) |
256 end handle INVALID (cs', msg) |
260 end handle CLASS_ERROR (cs', msg) |
257 => raise INVALID (fold (insert (op =)) cs' cs, msg); |
261 => raise CLASS_ERROR (fold (insert (op =)) cs' cs, msg); |
258 |
262 |
259 in |
263 in |
260 |
264 |
261 (** retrieval interfaces **) |
265 (** retrieval interfaces **) |
262 |
266 |
263 fun ensure_consts thy algebra consts funcgr = |
267 fun ensure_consts thy algebra consts funcgr = |
264 ensure_consts' thy algebra consts funcgr |
268 ensure_consts' thy algebra consts funcgr |
265 handle INVALID (cs', msg) => error (msg ^ ",\nwhile preprocessing equations for constant(s) " |
269 handle CLASS_ERROR (cs', msg) => error (msg ^ ",\nwhile preprocessing equations for constant(s) " |
266 ^ commas (map (CodeUnit.string_of_const thy) cs')); |
270 ^ commas (map (CodeUnit.string_of_const thy) cs')); |
267 |
271 |
268 fun check_consts thy consts funcgr = |
272 fun check_consts thy consts funcgr = |
269 let |
273 let |
270 val algebra = Code.coregular_algebra thy; |
274 val algebra = Code.coregular_algebra thy; |
271 fun try_const const funcgr = |
275 fun try_const const funcgr = |
272 (SOME const, ensure_consts' thy algebra [const] funcgr) |
276 (SOME const, ensure_consts' thy algebra [const] funcgr) |
273 handle INVALID (cs', msg) => (NONE, funcgr); |
277 handle CLASS_ERROR (cs', msg) => (NONE, funcgr); |
274 val (consts', funcgr') = fold_map try_const consts funcgr; |
278 val (consts', funcgr') = fold_map try_const consts funcgr; |
275 in (map_filter I consts', funcgr') end; |
279 in (map_filter I consts', funcgr') end; |
276 |
280 |
277 fun raw_eval thy f ct funcgr = |
281 fun raw_eval thy f ct funcgr = |
278 let |
282 let |
285 val ct' = Thm.rhs_of thm1; |
289 val ct' = Thm.rhs_of thm1; |
286 val cs = map fst (consts_of ct'); |
290 val cs = map fst (consts_of ct'); |
287 val funcgr' = ensure_consts thy algebra cs funcgr; |
291 val funcgr' = ensure_consts thy algebra cs funcgr; |
288 val (_, thm2) = Thm.varifyT' [] thm1; |
292 val (_, thm2) = Thm.varifyT' [] thm1; |
289 val thm3 = Thm.reflexive (Thm.rhs_of thm2); |
293 val thm3 = Thm.reflexive (Thm.rhs_of thm2); |
290 val [thm4] = resort_thms algebra (try (fst o Graph.get_node funcgr')) [thm3]; |
294 val [thm4] = resort_thms algebra (try (fst o Graph.get_node funcgr')) [thm3] |
|
295 handle CLASS_ERROR (_, msg) => error msg; |
291 val tfrees = Term.add_tfrees (Thm.prop_of thm1) []; |
296 val tfrees = Term.add_tfrees (Thm.prop_of thm1) []; |
292 fun inst thm = |
297 fun inst thm = |
293 let |
298 let |
294 val tvars = Term.add_tvars (Thm.prop_of thm) []; |
299 val tvars = Term.add_tvars (Thm.prop_of thm) []; |
295 val instmap = map2 (fn (v_i, sort) => fn (v, _) => pairself (Thm.ctyp_of thy) |
300 val instmap = map2 (fn (v_i, sort) => fn (v, _) => pairself (Thm.ctyp_of thy) |