src/HOL/Code_Eval.thy
author haftmann
Tue, 16 Sep 2008 09:21:24 +0200
changeset 28228 7ebe8dc06cbb
child 28243 84d90ec67059
permissions -rw-r--r--
evaluation using code generator
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
28228
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     1
(*  Title:      HOL/Code_Eval.thy
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     2
    ID:         $Id$
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     3
    Author:     Florian Haftmann, TU Muenchen
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     4
*)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     5
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     6
header {* Term evaluation using the generic code generator *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     7
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     8
theory Code_Eval
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
     9
imports Plain RType
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    10
begin
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    11
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    12
subsection {* Term representation *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    13
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    14
subsubsection {* Terms and class @{text term_of} *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    15
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    16
datatype "term" = dummy_term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    17
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    18
definition
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    19
  Const :: "message_string \<Rightarrow> rtype \<Rightarrow> term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    20
where
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    21
  "Const _ _ = dummy_term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    22
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    23
definition
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    24
  App :: "term \<Rightarrow> term \<Rightarrow> term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    25
where
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    26
  "App _ _ = dummy_term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    27
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    28
code_datatype Const App
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    29
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    30
class term_of = rtype +
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    31
  fixes term_of :: "'a \<Rightarrow> term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    32
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    33
lemma term_of_anything: "term_of x \<equiv> t"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    34
  by (rule eq_reflection) (cases "term_of x", cases t, simp)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    35
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    36
ML {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    37
structure Eval =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    38
struct
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    39
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    40
fun mk_term f g (Const (c, ty)) =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    41
      @{term Const} $ Message_String.mk c $ g ty
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    42
  | mk_term f g (t1 $ t2) =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    43
      @{term App} $ mk_term f g t1 $ mk_term f g t2
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    44
  | mk_term f g (Free v) = f v
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    45
  | mk_term f g (Bound i) = Bound i
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    46
  | mk_term f g (Abs (v, _, t)) = Abs (v, @{typ term}, mk_term f g t);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    47
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    48
fun mk_term_of ty t = Const (@{const_name term_of}, ty --> @{typ term}) $ t;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    49
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    50
end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    51
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    52
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    53
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    54
subsubsection {* @{text term_of} instances *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    55
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    56
setup {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    57
let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    58
  fun add_term_of_def ty vs tyco thy =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    59
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    60
      val lhs = Const (@{const_name term_of}, ty --> @{typ term})
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    61
        $ Free ("x", ty);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    62
      val rhs = @{term "undefined \<Colon> term"};
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    63
      val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    64
    in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    65
      thy
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    66
      |> TheoryTarget.instantiation ([tyco], vs, @{sort term_of})
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    67
      |> `(fn lthy => Syntax.check_term lthy eq)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    68
      |-> (fn eq => Specification.definition (NONE, (Attrib.no_binding, eq)))
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    69
      |> snd
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    70
      |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    71
      |> LocalTheory.exit
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    72
      |> ProofContext.theory_of
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    73
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    74
  fun interpretator (tyco, (raw_vs, _)) thy =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    75
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    76
      val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    77
      val constrain_sort =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    78
        curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    79
      val vs = (map o apsnd) constrain_sort raw_vs;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    80
      val ty = Type (tyco, map TFree vs);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    81
    in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    82
      thy
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    83
      |> RType.perhaps_add_def tyco
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    84
      |> not has_inst ? add_term_of_def ty vs tyco
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    85
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    86
in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    87
  Code.type_interpretation interpretator
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    88
end
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    89
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    90
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    91
setup {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    92
let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    93
  fun mk_term_of_eq ty vs tyco (c, tys) =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    94
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    95
      val t = list_comb (Const (c, tys ---> ty),
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    96
        map Free (Name.names Name.context "a" tys));
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    97
    in (map_aterms (fn Free (v, ty) => Var ((v, 0), ty) | t => t) t, Eval.mk_term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    98
      (fn (v, ty) => Eval.mk_term_of ty (Var ((v, 0), ty)))
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
    99
      (RType.mk (fn (v, sort) => RType.rtype (TFree (v, sort)))) t)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   100
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   101
  fun prove_term_of_eq ty eq thy =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   102
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   103
      val cty = Thm.ctyp_of thy ty;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   104
      val (arg, rhs) = pairself (Thm.cterm_of thy) eq;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   105
      val thm = @{thm term_of_anything}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   106
        |> Drule.instantiate' [SOME cty] [SOME arg, SOME rhs]
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   107
        |> Thm.varifyT;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   108
    in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   109
      thy
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   110
      |> Code.add_func thm
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   111
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   112
  fun interpretator (tyco, (raw_vs, raw_cs)) thy =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   113
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   114
      val constrain_sort =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   115
        curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   116
      val vs = (map o apsnd) constrain_sort raw_vs;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   117
      val cs = (map o apsnd o map o map_atyps)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   118
        (fn TFree (v, sort) => TFree (v, constrain_sort sort)) raw_cs;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   119
      val ty = Type (tyco, map TFree vs);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   120
      val eqs = map (mk_term_of_eq ty vs tyco) cs;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   121
      val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   122
    in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   123
      thy
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   124
      |> Code.del_funcs const
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   125
      |> fold (prove_term_of_eq ty) eqs
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   126
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   127
in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   128
  Code.type_interpretation interpretator
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   129
end
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   130
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   131
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   132
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   133
subsubsection {* Code generator setup *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   134
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   135
lemmas [code func del] = term.recs term.cases term.size
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   136
lemma [code func, code func del]: "(t1\<Colon>term) = t2 \<longleftrightarrow> t1 = t2" ..
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   137
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   138
lemma [code func, code func del]: "(term_of \<Colon> rtype \<Rightarrow> term) = term_of" ..
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   139
lemma [code func, code func del]: "(term_of \<Colon> term \<Rightarrow> term) = term_of" ..
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   140
lemma [code func, code func del]: "(term_of \<Colon> message_string \<Rightarrow> term) = term_of" ..
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   141
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   142
code_type "term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   143
  (SML "Term.term")
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   144
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   145
code_const Const and App
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   146
  (SML "Term.Const/ (_, _)" and "Term.$/ (_, _)")
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   147
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   148
code_const "term_of \<Colon> message_string \<Rightarrow> term"
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   149
  (SML "Message'_String.mk")
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   150
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   151
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   152
subsubsection {* Syntax *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   153
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   154
print_translation {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   155
let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   156
  val term = Const ("<TERM>", dummyT);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   157
  fun tr1' [_, _] = term;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   158
  fun tr2' [] = term;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   159
in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   160
  [(@{const_syntax Const}, tr1'),
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   161
    (@{const_syntax App}, tr1'),
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   162
    (@{const_syntax dummy_term}, tr2')]
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   163
end
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   164
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   165
setup {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   166
  Sign.declare_const [] ((Name.binding "rterm_of", @{typ "'a \<Rightarrow> 'b"}), NoSyn)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   167
  #> snd
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   168
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   169
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   170
notation (output)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   171
  rterm_of ("\<guillemotleft>_\<guillemotright>")
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   172
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   173
locale rterm_syntax =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   174
  fixes rterm_of_syntax :: "'a \<Rightarrow> 'b" ("\<guillemotleft>_\<guillemotright>")
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   175
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   176
parse_translation {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   177
let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   178
  fun rterm_of_tr [t] = Lexicon.const @{const_name rterm_of} $ t
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   179
    | rterm_of_tr ts = raise TERM ("rterm_of_tr", ts);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   180
in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   181
  [(Syntax.fixedN ^ "rterm_of_syntax", rterm_of_tr)]
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   182
end
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   183
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   184
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   185
setup {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   186
let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   187
  val subst_rterm_of = Eval.mk_term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   188
    (fn (v, _) => error ("illegal free variable in term quotation: " ^ quote v))
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   189
    (RType.mk (fn (v, sort) => RType.rtype (TFree (v, sort))));
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   190
  fun subst_rterm_of' (Const (@{const_name rterm_of}, _), [t]) = subst_rterm_of t
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   191
    | subst_rterm_of' (Const (@{const_name rterm_of}, _), _) =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   192
        error ("illegal number of arguments for " ^ quote @{const_name rterm_of})
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   193
    | subst_rterm_of' (t, ts) = list_comb (t, map (subst_rterm_of' o strip_comb) ts);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   194
  fun subst_rterm_of'' t = 
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   195
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   196
      val t' = subst_rterm_of' (strip_comb t);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   197
    in if t aconv t'
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   198
      then NONE
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   199
      else SOME t'
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   200
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   201
  fun check_rterm_of ts ctxt =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   202
    let
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   203
      val ts' = map subst_rterm_of'' ts;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   204
    in if exists is_some ts'
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   205
      then SOME (map2 the_default ts ts', ctxt)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   206
      else NONE
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   207
    end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   208
in
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   209
  Context.theory_map (Syntax.add_term_check 0 "rterm_of" check_rterm_of)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   210
end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   211
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   212
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   213
hide const dummy_term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   214
hide (open) const Const App
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   215
hide (open) const term_of
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   216
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   217
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   218
subsection {* Evaluation setup *}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   219
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   220
ML {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   221
signature EVAL =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   222
sig
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   223
  val mk_term: ((string * typ) -> term) -> (typ -> term) -> term -> term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   224
  val eval_ref: (unit -> term) option ref
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   225
  val eval_term: theory -> term -> term
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   226
end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   227
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   228
structure Eval : EVAL =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   229
struct
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   230
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   231
open Eval;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   232
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   233
val eval_ref = ref (NONE : (unit -> term) option);
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   234
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   235
fun eval_term thy t =
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   236
  t 
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   237
  |> Eval.mk_term_of (fastype_of t)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   238
  |> (fn t => Code_ML.eval_term ("Eval.eval_ref", eval_ref) thy t [])
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   239
  |> Code.postprocess_term thy;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   240
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   241
end;
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   242
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   243
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   244
setup {*
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   245
  Value.add_evaluator ("code", Eval.eval_term o ProofContext.theory_of)
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   246
*}
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   247
7ebe8dc06cbb evaluation using code generator
haftmann
parents:
diff changeset
   248
end