16 theory -> {intro: thm, axioms: thm list} * theory |
16 theory -> {intro: thm, axioms: thm list} * theory |
17 val add_classrel_thms: thm list -> theory -> theory |
17 val add_classrel_thms: thm list -> theory -> theory |
18 val add_arity_thms: thm list -> theory -> theory |
18 val add_arity_thms: thm list -> theory -> theory |
19 val add_inst_subclass: xstring * xstring -> tactic -> theory -> theory |
19 val add_inst_subclass: xstring * xstring -> tactic -> theory -> theory |
20 val add_inst_subclass_i: class * class -> tactic -> theory -> theory |
20 val add_inst_subclass_i: class * class -> tactic -> theory -> theory |
21 val add_inst_arity: xstring * string list * string -> tactic -> theory -> theory |
21 val add_inst_arity: (theory -> theory) -> xstring * string list * string -> tactic -> theory -> theory |
22 val add_inst_arity_i: string * sort list * sort -> tactic -> theory -> theory |
22 val add_inst_arity_i: (theory -> theory) -> string * sort list * sort -> tactic -> theory -> theory |
23 val instance_subclass: xstring * xstring -> theory -> Proof.state |
23 val instance_subclass: xstring * xstring -> theory -> Proof.state |
24 val instance_subclass_i: class * class -> theory -> Proof.state |
24 val instance_subclass_i: class * class -> theory -> Proof.state |
25 val instance_arity: (theory -> theory) -> xstring * string list * string -> theory -> Proof.state |
25 val instance_arity: (theory -> theory) -> xstring * string list * string -> theory -> Proof.state |
26 val instance_arity_i: (theory -> theory) -> string * sort list * sort -> theory -> Proof.state |
26 val instance_arity_i: (theory -> theory) -> string * sort list * sort -> theory -> Proof.state |
27 val read_arity: theory -> xstring * string list * string -> arity |
27 val read_arity: theory -> xstring * string list * string -> arity |
28 val cert_arity: theory -> string * sort list * sort -> arity |
28 val cert_arity: theory -> string * sort list * sort -> arity |
29 val intro_classes_tac: thm list -> tactic |
29 val class_axms: theory -> thm list |
30 val default_intro_classes_tac: thm list -> tactic |
|
31 end; |
30 end; |
32 |
31 |
33 structure AxClass: AX_CLASS = |
32 structure AxClass: AX_CLASS = |
34 struct |
33 struct |
35 |
34 |
276 val _ = message ("Proving class inclusion " ^ txt ^ " ..."); |
275 val _ = message ("Proving class inclusion " ^ txt ^ " ..."); |
277 val th = Goal.prove thy [] [] (mk_classrel (c1, c2)) (K tac) handle ERROR msg => |
276 val th = Goal.prove thy [] [] (mk_classrel (c1, c2)) (K tac) handle ERROR msg => |
278 cat_error msg ("The error(s) above occurred while trying to prove " ^ txt); |
277 cat_error msg ("The error(s) above occurred while trying to prove " ^ txt); |
279 in add_classrel_thms [th] thy end; |
278 in add_classrel_thms [th] thy end; |
280 |
279 |
281 fun ext_inst_arity prep_arity raw_arity tac thy = |
280 fun ext_inst_arity prep_arity (after_qed : theory -> theory) raw_arity tac thy = |
282 let |
281 let |
283 val arity = prep_arity thy raw_arity; |
282 val arity = prep_arity thy raw_arity; |
284 val txt = quote (Sign.string_of_arity thy arity); |
283 val txt = quote (Sign.string_of_arity thy arity); |
285 val _ = message ("Proving type arity " ^ txt ^ " ..."); |
284 val _ = message ("Proving type arity " ^ txt ^ " ..."); |
286 val props = (mk_arities arity); |
285 val props = (mk_arities arity); |
287 val ths = Goal.prove_multi thy [] [] props |
286 val ths = Goal.prove_multi thy [] [] props |
288 (fn _ => Tactic.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg => |
287 (fn _ => Tactic.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg => |
289 cat_error msg ("\nThe error(s) above occurred while trying to prove " ^ txt); |
288 cat_error msg ("\nThe error(s) above occurred while trying to prove " ^ txt); |
290 in add_arity_thms ths thy end; |
289 in |
|
290 thy |
|
291 |> add_arity_thms ths |
|
292 |> after_qed |
|
293 end; |
291 |
294 |
292 in |
295 in |
293 |
296 |
294 val add_inst_subclass = ext_inst_subclass read_classrel; |
297 val add_inst_subclass = ext_inst_subclass read_classrel; |
295 val add_inst_subclass_i = ext_inst_subclass cert_classrel; |
298 val add_inst_subclass_i = ext_inst_subclass cert_classrel; |
321 gen_instance (mk_arities oo cert_arity) add_arity_thms; |
324 gen_instance (mk_arities oo cert_arity) add_arity_thms; |
322 |
325 |
323 end; |
326 end; |
324 |
327 |
325 |
328 |
326 (* tactics and methods *) |
|
327 |
|
328 fun intro_classes_tac facts st = |
|
329 (ALLGOALS (Method.insert_tac facts THEN' |
|
330 REPEAT_ALL_NEW (resolve_tac (class_axms (Thm.theory_of_thm st)))) |
|
331 THEN Tactic.distinct_subgoals_tac) st; |
|
332 |
|
333 fun default_intro_classes_tac [] = intro_classes_tac [] |
|
334 | default_intro_classes_tac _ = Tactical.no_tac; (*no error message!*) |
|
335 |
|
336 fun default_tac rules ctxt facts = |
|
337 HEADGOAL (Method.some_rule_tac rules ctxt facts) ORELSE |
|
338 default_intro_classes_tac facts; |
|
339 |
|
340 val _ = Context.add_setup (Method.add_methods |
|
341 [("intro_classes", Method.no_args (Method.METHOD intro_classes_tac), |
|
342 "back-chain introduction rules of axiomatic type classes"), |
|
343 ("default", Method.thms_ctxt_args (Method.METHOD oo default_tac), "apply some intro/elim rule")]); |
|
344 |
|
345 |
|
346 |
329 |
347 (** outer syntax **) |
330 (** outer syntax **) |
348 |
331 |
349 local structure P = OuterParse and K = OuterKeyword in |
332 local structure P = OuterParse and K = OuterKeyword in |
350 |
333 |