248 val safe_elim_attrs = @{attributes [elim!]}; |
248 val safe_elim_attrs = @{attributes [elim!]}; |
249 val iff_attrs = @{attributes [iff]}; |
249 val iff_attrs = @{attributes [iff]}; |
250 val inductsimp_attrs = @{attributes [induct_simp]}; |
250 val inductsimp_attrs = @{attributes [induct_simp]}; |
251 val nitpicksimp_attrs = @{attributes [nitpick_simp]}; |
251 val nitpicksimp_attrs = @{attributes [nitpick_simp]}; |
252 val simp_attrs = @{attributes [simp]}; |
252 val simp_attrs = @{attributes [simp]}; |
253 val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs; |
|
254 val code_nitpicksimp_simp_attrs = code_nitpicksimp_attrs @ simp_attrs; |
|
255 |
253 |
256 fun unflat_lookup eq xs ys = map (fn xs' => permute_like_unique eq xs xs' ys); |
254 fun unflat_lookup eq xs ys = map (fn xs' => permute_like_unique eq xs xs' ys); |
257 |
255 |
258 fun mk_half_pairss' _ ([], []) = [] |
256 fun mk_half_pairss' _ ([], []) = [] |
259 | mk_half_pairss' indent (x :: xs, _ :: ys) = |
257 | mk_half_pairss' indent (x :: xs, _ :: ys) = |
976 end; |
974 end; |
977 |
975 |
978 val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); |
976 val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); |
979 val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name)); |
977 val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name)); |
980 |
978 |
|
979 val code_attrs = if plugins code_plugin then [Code.add_default_eqn_attrib] else []; |
|
980 |
981 val nontriv_disc_eq_thmss = |
981 val nontriv_disc_eq_thmss = |
982 map (map (fn th => th RS @{thm eq_False[THEN iffD2]} |
982 map (map (fn th => th RS @{thm eq_False[THEN iffD2]} |
983 handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; |
983 handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; |
984 |
984 |
985 val anonymous_notes = |
985 val anonymous_notes = |
986 [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs), |
986 [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs), |
987 (flat nontriv_disc_eq_thmss, code_nitpicksimp_attrs)] |
987 (flat nontriv_disc_eq_thmss, code_attrs @ nitpicksimp_attrs)] |
988 |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); |
988 |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); |
989 |
989 |
990 val notes = |
990 val notes = |
991 [(caseN, case_thms, code_nitpicksimp_simp_attrs), |
991 [(caseN, case_thms, code_attrs @ nitpicksimp_attrs @ simp_attrs), |
992 (case_congN, [case_cong_thm], []), |
992 (case_congN, [case_cong_thm], []), |
993 (case_cong_weak_thmsN, [case_cong_weak_thm], cong_attrs), |
993 (case_cong_weak_thmsN, [case_cong_weak_thm], cong_attrs), |
994 (case_eq_ifN, case_eq_if_thms, []), |
994 (case_eq_ifN, case_eq_if_thms, []), |
995 (collapseN, safe_collapse_thms, if ms = [0] then [] else simp_attrs), |
995 (collapseN, safe_collapse_thms, if ms = [0] then [] else simp_attrs), |
996 (discN, flat nontriv_disc_thmss, simp_attrs), |
996 (discN, flat nontriv_disc_thmss, simp_attrs), |
1001 (exhaust_discN, exhaust_disc_thms, [exhaust_case_names_attr]), |
1001 (exhaust_discN, exhaust_disc_thms, [exhaust_case_names_attr]), |
1002 (exhaust_selN, exhaust_sel_thms, [exhaust_case_names_attr]), |
1002 (exhaust_selN, exhaust_sel_thms, [exhaust_case_names_attr]), |
1003 (expandN, expand_thms, []), |
1003 (expandN, expand_thms, []), |
1004 (injectN, inject_thms, iff_attrs @ inductsimp_attrs), |
1004 (injectN, inject_thms, iff_attrs @ inductsimp_attrs), |
1005 (nchotomyN, [nchotomy_thm], []), |
1005 (nchotomyN, [nchotomy_thm], []), |
1006 (selN, all_sel_thms, code_nitpicksimp_simp_attrs), |
1006 (selN, all_sel_thms, code_attrs @ nitpicksimp_attrs @ simp_attrs), |
1007 (splitN, [split_thm], []), |
1007 (splitN, [split_thm], []), |
1008 (split_asmN, [split_asm_thm], []), |
1008 (split_asmN, [split_asm_thm], []), |
1009 (split_selN, split_sel_thms, []), |
1009 (split_selN, split_sel_thms, []), |
1010 (split_sel_asmN, split_sel_asm_thms, []), |
1010 (split_sel_asmN, split_sel_asm_thms, []), |
1011 (split_selsN, split_sel_thms @ split_sel_asm_thms, []), |
1011 (split_selsN, split_sel_thms @ split_sel_asm_thms, []), |
1020 |> fold (Spec_Rules.add Spec_Rules.Equational) |
1020 |> fold (Spec_Rules.add Spec_Rules.Equational) |
1021 (AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) |
1021 (AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) |
1022 |> fold (Spec_Rules.add Spec_Rules.Equational) |
1022 |> fold (Spec_Rules.add Spec_Rules.Equational) |
1023 (filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |
1023 (filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |
1024 |> Local_Theory.declaration {syntax = false, pervasive = true} |
1024 |> Local_Theory.declaration {syntax = false, pervasive = true} |
1025 (fn phi => Case_Translation.register |
1025 (fn phi => Case_Translation.register |
1026 (Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |
1026 (Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |
1027 |> Local_Theory.background_theory (fold (fold Code.del_eqn) [disc_defs, sel_defs]) |
1027 |> Local_Theory.background_theory (fold (fold Code.del_eqn) [disc_defs, sel_defs]) |
1028 |> plugins code_plugin ? |
1028 |> plugins code_plugin ? |
1029 Local_Theory.declaration {syntax = false, pervasive = false} |
1029 Local_Theory.declaration {syntax = false, pervasive = false} |
1030 (fn phi => Context.mapping |
1030 (fn phi => Context.mapping |
1031 (add_ctr_code fcT_name (map (Morphism.typ phi) As) |
1031 (add_ctr_code fcT_name (map (Morphism.typ phi) As) |
1032 (map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) |
1032 (map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) |
1033 (Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) |
1033 (Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) |
1034 I) |
1034 I) |
1035 |> Local_Theory.notes (anonymous_notes @ notes) |
1035 |> Local_Theory.notes (anonymous_notes @ notes) |
1036 (* for "datatype_realizer.ML": *) |
1036 (* for "datatype_realizer.ML": *) |
1037 |>> name_noted_thms fcT_name exhaustN; |
1037 |>> name_noted_thms fcT_name exhaustN; |
1038 |
1038 |
1039 val ctr_sugar = |
1039 val ctr_sugar = |