107 Binding.qualify true (Long_Name.base_name fcT_name) o Binding.qualify true eqN o Binding.name; |
107 Binding.qualify true (Long_Name.base_name fcT_name) o Binding.qualify true eqN o Binding.name; |
108 in |
108 in |
109 Class.instantiation ([fcT_name], map dest_TFree As, [HOLogic.class_equal]) |
109 Class.instantiation ([fcT_name], map dest_TFree As, [HOLogic.class_equal]) |
110 #> add_def |
110 #> add_def |
111 #-> Class.prove_instantiation_exit_result (map o Morphism.thm) tac o single |
111 #-> Class.prove_instantiation_exit_result (map o Morphism.thm) tac o single |
112 #-> fold Code.del_eqn |
112 #> snd |
113 #> `(mk_free_ctr_equations fcT ctrs inject_thms distinct_thms) |
113 #> `(mk_free_ctr_equations fcT ctrs inject_thms distinct_thms) |
114 #-> (fn (thms, thm) => Global_Theory.note_thmss Thm.theoremK |
114 #-> (fn (thms, thm) => Global_Theory.note_thmss Thm.theoremK |
115 [((qualify reflN, [Code.add_default_eqn_attribute Code.Nbe]), [([thm], [])]), |
115 [((qualify reflN, []), [([thm], [])]), |
116 ((qualify simpsN, [Code.add_default_eqn_attribute Code.Equation]), [(rev thms, [])])]) |
116 ((qualify simpsN, []), [(rev thms, [])])]) |
117 #> snd |
117 #-> (fn [(_, [thm]), (_, thms)] => |
|
118 Code.declare_default_eqns_global ((thm, false) :: map (rpair true) thms)) |
118 end; |
119 end; |
119 |
120 |
120 fun add_ctr_code fcT_name raw_As raw_ctrs inject_thms distinct_thms case_thms thy = |
121 fun add_ctr_code fcT_name raw_As raw_ctrs inject_thms distinct_thms case_thms thy = |
121 let |
122 let |
122 val As = map (perhaps (try Logic.unvarifyT_global)) raw_As; |
123 val As = map (perhaps (try Logic.unvarifyT_global)) raw_As; |
124 val fcT = Type (fcT_name, As); |
125 val fcT = Type (fcT_name, As); |
125 val unover_ctrs = map (fn ctr as (_, fcT) => (Axclass.unoverload_const thy ctr, fcT)) ctrs; |
126 val unover_ctrs = map (fn ctr as (_, fcT) => (Axclass.unoverload_const thy ctr, fcT)) ctrs; |
126 in |
127 in |
127 if can (Code.constrset_of_consts thy) unover_ctrs then |
128 if can (Code.constrset_of_consts thy) unover_ctrs then |
128 thy |
129 thy |
129 |> Code.add_datatype ctrs |
130 |> Code.declare_datatype_global ctrs |
130 |> fold_rev (Code.add_eqn (Code.Equation, true)) case_thms |
131 |> Code.declare_default_eqns_global (map (rpair true) (rev case_thms)) |
131 |> Code.add_case (mk_case_certificate (Proof_Context.init_global thy) case_thms) |
132 |> Code.declare_case_global (mk_case_certificate (Proof_Context.init_global thy) case_thms) |
132 |> not (Sorts.has_instance (Sign.classes_of thy) fcT_name [HOLogic.class_equal]) |
133 |> not (Sorts.has_instance (Sign.classes_of thy) fcT_name [HOLogic.class_equal]) |
133 ? add_equality fcT fcT_name As ctrs inject_thms distinct_thms |
134 ? add_equality fcT fcT_name As ctrs inject_thms distinct_thms |
134 else |
135 else |
135 thy |
136 thy |
136 end; |
137 end; |