src/HOL/BNF/Tools/ctr_sugar.ML
changeset 54145 297d1c603999
parent 54008 b15cfc2864de
child 54151 71dc4e6c001c
equal deleted inserted replaced
54144:0fadd32e8d50 54145:297d1c603999
   172 
   172 
   173 val cong_attrs = @{attributes [cong]};
   173 val cong_attrs = @{attributes [cong]};
   174 val dest_attrs = @{attributes [dest]};
   174 val dest_attrs = @{attributes [dest]};
   175 val safe_elim_attrs = @{attributes [elim!]};
   175 val safe_elim_attrs = @{attributes [elim!]};
   176 val iff_attrs = @{attributes [iff]};
   176 val iff_attrs = @{attributes [iff]};
   177 val induct_simp_attrs = @{attributes [induct_simp]};
   177 val inductsimp_attrs = @{attributes [induct_simp]};
   178 val nitpick_attrs = @{attributes [nitpick_simp]};
   178 val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   179 val simp_attrs = @{attributes [simp]};
   179 val simp_attrs = @{attributes [simp]};
   180 val code_nitpick_simp_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
   180 val code_nitpicksimp_simp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs @ simp_attrs;
   181 
   181 
   182 fun unflat_lookup eq xs ys = map (fn xs' => permute_like eq xs xs' ys);
   182 fun unflat_lookup eq xs ys = map (fn xs' => permute_like eq xs xs' ys);
   183 
   183 
   184 fun mk_half_pairss' _ ([], []) = []
   184 fun mk_half_pairss' _ ([], []) = []
   185   | mk_half_pairss' indent (x :: xs, _ :: ys) =
   185   | mk_half_pairss' indent (x :: xs, _ :: ys) =
   868 
   868 
   869         val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
   869         val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
   870         val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name));
   870         val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name));
   871 
   871 
   872         val notes =
   872         val notes =
   873           [(caseN, case_thms, code_nitpick_simp_simp_attrs),
   873           [(caseN, case_thms, code_nitpicksimp_simp_attrs),
   874            (case_congN, [case_cong_thm], []),
   874            (case_congN, [case_cong_thm], []),
   875            (case_conv_ifN, case_conv_if_thms, []),
   875            (case_conv_ifN, case_conv_if_thms, []),
   876            (collapseN, safe_collapse_thms, simp_attrs),
   876            (collapseN, safe_collapse_thms, simp_attrs),
   877            (discN, nontriv_disc_thms, simp_attrs),
   877            (discN, nontriv_disc_thms, simp_attrs),
   878            (discIN, nontriv_discI_thms, []),
   878            (discIN, nontriv_discI_thms, []),
   879            (disc_excludeN, disc_exclude_thms, dest_attrs),
   879            (disc_excludeN, disc_exclude_thms, dest_attrs),
   880            (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
   880            (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
   881            (distinctN, distinct_thms, simp_attrs @ induct_simp_attrs),
   881            (distinctN, distinct_thms, simp_attrs @ inductsimp_attrs),
   882            (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
   882            (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
   883            (expandN, expand_thms, []),
   883            (expandN, expand_thms, []),
   884            (injectN, inject_thms, iff_attrs @ induct_simp_attrs),
   884            (injectN, inject_thms, iff_attrs @ inductsimp_attrs),
   885            (nchotomyN, [nchotomy_thm], []),
   885            (nchotomyN, [nchotomy_thm], []),
   886            (selN, all_sel_thms, code_nitpick_simp_simp_attrs),
   886            (selN, all_sel_thms, code_nitpicksimp_simp_attrs),
   887            (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]),
   887            (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]),
   888            (sel_splitN, sel_split_thms, []),
   888            (sel_splitN, sel_split_thms, []),
   889            (sel_split_asmN, sel_split_asm_thms, []),
   889            (sel_split_asmN, sel_split_asm_thms, []),
   890            (splitN, [split_thm], []),
   890            (splitN, [split_thm], []),
   891            (split_asmN, [split_asm_thm], []),
   891            (split_asmN, [split_asm_thm], []),
   893            (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
   893            (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
   894           |> filter_out (null o #2)
   894           |> filter_out (null o #2)
   895           |> map (fn (thmN, thms, attrs) =>
   895           |> map (fn (thmN, thms, attrs) =>
   896             ((qualify true (Binding.name thmN), attrs), [(thms, [])]));
   896             ((qualify true (Binding.name thmN), attrs), [(thms, [])]));
   897 
   897 
   898         val notes' =
   898         val anonymous_notes =
   899           [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
   899           [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
   900           |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
   900           |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
   901 
   901 
   902         val ctr_sugar =
   902         val ctr_sugar =
   903           {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm,
   903           {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm,
   913          lthy
   913          lthy
   914          |> not rep_compat ?
   914          |> not rep_compat ?
   915             (Local_Theory.declaration {syntax = false, pervasive = true}
   915             (Local_Theory.declaration {syntax = false, pervasive = true}
   916                (fn phi => Case_Translation.register
   916                (fn phi => Case_Translation.register
   917                   (Morphism.term phi casex) (map (Morphism.term phi) ctrs)))
   917                   (Morphism.term phi casex) (map (Morphism.term phi) ctrs)))
   918          |> Local_Theory.notes (notes' @ notes) |> snd
   918          |> Local_Theory.notes (anonymous_notes @ notes) |> snd
   919          |> register_ctr_sugar fcT_name ctr_sugar)
   919          |> register_ctr_sugar fcT_name ctr_sugar)
   920       end;
   920       end;
   921   in
   921   in
   922     (goalss, after_qed, lthy')
   922     (goalss, after_qed, lthy')
   923   end;
   923   end;