208 f (transfer_ctr_sugar (Proof_Context.theory_of lthy) ctr_sugar) lthy); |
208 f (transfer_ctr_sugar (Proof_Context.theory_of lthy) ctr_sugar) lthy); |
209 |
209 |
210 val interpret_ctr_sugar = Ctr_Sugar_Plugin.data; |
210 val interpret_ctr_sugar = Ctr_Sugar_Plugin.data; |
211 |
211 |
212 fun register_ctr_sugar_raw (ctr_sugar as {T = Type (name, _), ...}) = |
212 fun register_ctr_sugar_raw (ctr_sugar as {T = Type (name, _), ...}) = |
213 Local_Theory.declaration {syntax = false, pervasive = true} |
213 Local_Theory.declaration {syntax = false, pervasive = true, pos = \<^here>} |
214 (fn phi => fn context => |
214 (fn phi => fn context => |
215 let val pos = Position.thread_data () |
215 let val pos = Position.thread_data () |
216 in Data.map (Symtab.update (name, (pos, morph_ctr_sugar phi ctr_sugar))) context end); |
216 in Data.map (Symtab.update (name, (pos, morph_ctr_sugar phi ctr_sugar))) context end); |
217 |
217 |
218 fun register_ctr_sugar plugins ctr_sugar = |
218 fun register_ctr_sugar plugins ctr_sugar = |
1070 Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => |
1070 Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => |
1071 mk_case_distrib_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm case_thms) |
1071 mk_case_distrib_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm case_thms) |
1072 |> Thm.close_derivation \<^here> |
1072 |> Thm.close_derivation \<^here> |
1073 end; |
1073 end; |
1074 |
1074 |
1075 val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); |
1075 val exhaust_case_names_attr = Attrib.internal \<^here> (K (Rule_Cases.case_names exhaust_cases)); |
1076 val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name)); |
1076 val cases_type_attr = Attrib.internal \<^here> (K (Induct.cases_type fcT_name)); |
1077 |
1077 |
1078 val nontriv_disc_eq_thmss = |
1078 val nontriv_disc_eq_thmss = |
1079 map (map (fn th => th RS @{thm eq_False[THEN iffD2]} |
1079 map (map (fn th => th RS @{thm eq_False[THEN iffD2]} |
1080 handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; |
1080 handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; |
1081 |
1081 |
1117 |> Spec_Rules.add Binding.empty Spec_Rules.equational [casex] case_thms |
1117 |> Spec_Rules.add Binding.empty Spec_Rules.equational [casex] case_thms |
1118 |> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
1118 |> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
1119 (AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) |
1119 (AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) |
1120 |> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
1120 |> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
1121 (filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |
1121 (filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |
1122 |> Local_Theory.declaration {syntax = false, pervasive = true} |
1122 |> Local_Theory.declaration {syntax = false, pervasive = true, pos = \<^here>} |
1123 (fn phi => Case_Translation.register |
1123 (fn phi => Case_Translation.register |
1124 (Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |
1124 (Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |
1125 |> plugins code_plugin ? |
1125 |> plugins code_plugin ? |
1126 (Code.declare_default_eqns (map (rpair true) (flat nontriv_disc_eq_thmss @ case_thms @ all_sel_thms)) |
1126 (Code.declare_default_eqns (map (rpair true) (flat nontriv_disc_eq_thmss @ case_thms @ all_sel_thms)) |
1127 #> Local_Theory.declaration {syntax = false, pervasive = false} |
1127 #> Local_Theory.declaration {syntax = false, pervasive = false, pos = \<^here>} |
1128 (fn phi => Context.mapping |
1128 (fn phi => Context.mapping |
1129 (add_ctr_code fcT_name (map (Morphism.typ phi) As) |
1129 (add_ctr_code fcT_name (map (Morphism.typ phi) As) |
1130 (map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) |
1130 (map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) |
1131 (Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) |
1131 (Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) |
1132 I)) |
1132 I)) |