src/HOL/Code_Evaluation.thy
changeset 35366 6d474096698c
parent 35299 4f4d5bf4ea08
child 35845 e5980f0ad025
equal deleted inserted replaced
35330:e7eb254db165 35366:6d474096698c
   117 in
   117 in
   118   Code.datatype_interpretation ensure_term_of_code
   118   Code.datatype_interpretation ensure_term_of_code
   119 end
   119 end
   120 *}
   120 *}
   121 
   121 
       
   122 setup {*
       
   123 let
       
   124   fun mk_term_of_eq thy ty vs tyco abs ty_rep proj =
       
   125     let
       
   126       val arg = Var (("x", 0), ty);
       
   127       val rhs = Abs ("y", @{typ term}, HOLogic.reflect_term (Const (abs, ty_rep --> ty) $ Bound 0)) $
       
   128         (HOLogic.mk_term_of ty_rep (Const (proj, ty --> ty_rep) $ arg))
       
   129         |> Thm.cterm_of thy;
       
   130       val cty = Thm.ctyp_of thy ty;
       
   131     in
       
   132       @{thm term_of_anything}
       
   133       |> Drule.instantiate' [SOME cty] [SOME (Thm.cterm_of thy arg), SOME rhs]
       
   134       |> Thm.varifyT
       
   135     end;
       
   136   fun add_term_of_code tyco raw_vs abs raw_ty_rep proj thy =
       
   137     let
       
   138       val algebra = Sign.classes_of thy;
       
   139       val vs = map (fn (v, sort) =>
       
   140         (v, curry (Sorts.inter_sort algebra) @{sort typerep} sort)) raw_vs;
       
   141       val ty = Type (tyco, map TFree vs);
       
   142       val ty_rep = map_atyps
       
   143         (fn TFree (v, _) => TFree (v, (the o AList.lookup (op =) vs) v)) raw_ty_rep;
       
   144       val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
       
   145       val eq = mk_term_of_eq thy ty vs tyco abs ty_rep proj;
       
   146    in
       
   147       thy
       
   148       |> Code.del_eqns const
       
   149       |> Code.add_eqn eq
       
   150     end;
       
   151   fun ensure_term_of_code (tyco, (raw_vs, ((abs, ty), (proj, _)))) thy =
       
   152     let
       
   153       val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
       
   154     in if has_inst then add_term_of_code tyco raw_vs abs ty proj thy else thy end;
       
   155 in
       
   156   Code.abstype_interpretation ensure_term_of_code
       
   157 end
       
   158 *}
       
   159 
   122 
   160 
   123 subsubsection {* Code generator setup *}
   161 subsubsection {* Code generator setup *}
   124 
   162 
   125 lemmas [code del] = term.recs term.cases term.size
   163 lemmas [code del] = term.recs term.cases term.size
   126 lemma [code, code del]: "eq_class.eq (t1\<Colon>term) t2 \<longleftrightarrow> eq_class.eq t1 t2" ..
   164 lemma [code, code del]: "eq_class.eq (t1\<Colon>term) t2 \<longleftrightarrow> eq_class.eq t1 t2" ..