src/Pure/axclass.ML
changeset 19110 4bda27adcd2e
parent 18964 67f572e03236
child 19123 a278d1e65c1d
equal deleted inserted replaced
19109:9804aa8d5756 19110:4bda27adcd2e
    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