src/HOL/Tools/Ctr_Sugar/ctr_sugar_code.ML
changeset 66251 cd935b7cb3fb
parent 63352 4eaf35781b23
child 69593 3dda49e08b9d
equal deleted inserted replaced
66250:56a87a5093be 66251:cd935b7cb3fb
   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;