src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML
changeset 78095 bc42c074e58f
parent 74561 8e6c973003c8
child 80634 a90ab1ea6458
equal deleted inserted replaced
78094:c3efa0b63d2e 78095:bc42c074e58f
   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))