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" .. |