src/Pure/Proof/extraction.ML
author haftmann
Wed Sep 24 19:10:30 2014 +0200 (2014-09-24)
changeset 58436 fe9de4089345
parent 56436 30ccec1e82fb
child 58843 521cea5fa777
permissions -rw-r--r--
tuned
berghofe@13402
     1
(*  Title:      Pure/Proof/extraction.ML
berghofe@13402
     2
    Author:     Stefan Berghofer, TU Muenchen
berghofe@13402
     3
berghofe@13402
     4
Extraction of programs from proofs.
berghofe@13402
     5
*)
berghofe@13402
     6
berghofe@13402
     7
signature EXTRACTION =
berghofe@13402
     8
sig
wenzelm@16458
     9
  val set_preprocessor : (theory -> Proofterm.proof -> Proofterm.proof) -> theory -> theory
berghofe@13402
    10
  val add_realizes_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
berghofe@13402
    11
  val add_realizes_eqns : string list -> theory -> theory
berghofe@13402
    12
  val add_typeof_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
berghofe@13402
    13
  val add_typeof_eqns : string list -> theory -> theory
berghofe@13402
    14
  val add_realizers_i : (string * (string list * term * Proofterm.proof)) list
berghofe@13402
    15
    -> theory -> theory
berghofe@13402
    16
  val add_realizers : (thm * (string list * string * string)) list
berghofe@13402
    17
    -> theory -> theory
wenzelm@33704
    18
  val add_expand_thm : bool -> thm -> theory -> theory
berghofe@13732
    19
  val add_types : (xstring * ((term -> term option) list *
berghofe@13732
    20
    (term -> typ -> term -> typ -> term) option)) list -> theory -> theory
berghofe@13732
    21
  val extract : (thm * string list) list -> theory -> theory
berghofe@13402
    22
  val nullT : typ
berghofe@13402
    23
  val nullt : term
berghofe@13714
    24
  val mk_typ : typ -> term
berghofe@13714
    25
  val etype_of : theory -> string list -> typ list -> term -> typ
berghofe@13714
    26
  val realizes_of: theory -> string list -> term -> term -> term
berghofe@37233
    27
  val abs_corr_shyps: theory -> thm -> string list -> term list -> Proofterm.proof -> Proofterm.proof
berghofe@13402
    28
end;
berghofe@13402
    29
berghofe@13402
    30
structure Extraction : EXTRACTION =
berghofe@13402
    31
struct
berghofe@13402
    32
berghofe@13402
    33
(**** tools ****)
berghofe@13402
    34
wenzelm@42407
    35
val typ = Simple_Syntax.read_typ;
wenzelm@42407
    36
wenzelm@42407
    37
val add_syntax =
wenzelm@52788
    38
  Sign.root_path
wenzelm@56436
    39
  #> Sign.add_types_global
wenzelm@56436
    40
    [(Binding.make ("Type", @{here}), 0, NoSyn),
wenzelm@56436
    41
     (Binding.make ("Null", @{here}), 0, NoSyn)]
wenzelm@56239
    42
  #> Sign.add_consts
wenzelm@56436
    43
    [(Binding.make ("typeof", @{here}), typ "'b => Type", NoSyn),
wenzelm@56436
    44
     (Binding.make ("Type", @{here}), typ "'a itself => Type", NoSyn),
wenzelm@56436
    45
     (Binding.make ("Null", @{here}), typ "Null", NoSyn),
wenzelm@56436
    46
     (Binding.make ("realizes", @{here}), typ "'a => 'b => 'b", NoSyn)];
berghofe@13402
    47
berghofe@13402
    48
val nullT = Type ("Null", []);
berghofe@13402
    49
val nullt = Const ("Null", nullT);
berghofe@13402
    50
berghofe@13402
    51
fun mk_typ T =
wenzelm@19391
    52
  Const ("Type", Term.itselfT T --> Type ("Type", [])) $ Logic.mk_type T;
berghofe@13402
    53
berghofe@13402
    54
fun typeof_proc defaultS vs (Const ("typeof", _) $ u) =
skalberg@15531
    55
      SOME (mk_typ (case strip_comb u of
berghofe@13402
    56
          (Var ((a, i), _), _) =>
wenzelm@20664
    57
            if member (op =) vs a then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS)
berghofe@13402
    58
            else nullT
berghofe@13402
    59
        | (Free (a, _), _) =>
wenzelm@20664
    60
            if member (op =) vs a then TFree ("'" ^ a, defaultS) else nullT
berghofe@13402
    61
        | _ => nullT))
skalberg@15531
    62
  | typeof_proc _ _ _ = NONE;
berghofe@13402
    63
haftmann@49960
    64
fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ _ $ t) = SOME t
berghofe@13732
    65
  | rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) =
berghofe@13732
    66
      (case strip_comb t of
skalberg@15531
    67
         (Var (ixn, U), ts) => SOME (list_comb (Var (ixn, T --> U), r :: ts))
skalberg@15531
    68
       | (Free (s, U), ts) => SOME (list_comb (Free (s, T --> U), r :: ts))
skalberg@15531
    69
       | _ => NONE)
skalberg@15531
    70
  | rlz_proc _ = NONE;
berghofe@13402
    71
berghofe@13402
    72
val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o
wenzelm@40627
    73
  take_prefix (fn s => s <> ":") o raw_explode;
berghofe@13402
    74
berghofe@13402
    75
type rules =
berghofe@13402
    76
  {next: int, rs: ((term * term) list * (term * term)) list,
berghofe@13402
    77
   net: (int * ((term * term) list * (term * term))) Net.net};
berghofe@13402
    78
berghofe@13402
    79
val empty_rules : rules = {next = 0, rs = [], net = Net.empty};
berghofe@13402
    80
wenzelm@33337
    81
fun add_rule (r as (_, (lhs, _))) ({next, rs, net} : rules) =
wenzelm@16800
    82
  {next = next - 1, rs = r :: rs, net = Net.insert_term (K false)
wenzelm@18956
    83
     (Envir.eta_contract lhs, (next, r)) net};
berghofe@13402
    84
wenzelm@32784
    85
fun merge_rules ({next, rs = rs1, net} : rules) ({rs = rs2, ...} : rules) =
wenzelm@33337
    86
  fold_rev add_rule (subtract (op =) rs1 rs2) {next = next, rs = rs1, net = net};
berghofe@13402
    87
wenzelm@16458
    88
fun condrew thy rules procs =
berghofe@13402
    89
  let
berghofe@13402
    90
    fun rew tm =
wenzelm@17203
    91
      Pattern.rewrite_term thy [] (condrew' :: procs) tm
berghofe@15399
    92
    and condrew' tm =
berghofe@13402
    93
      let
wenzelm@32738
    94
        val cache = Unsynchronized.ref ([] : (term * term) list);
haftmann@17232
    95
        fun lookup f x = (case AList.lookup (op =) (!cache) x of
skalberg@15531
    96
            NONE =>
berghofe@15399
    97
              let val y = f x
berghofe@15399
    98
              in (cache := (x, y) :: !cache; y) end
skalberg@15531
    99
          | SOME y => y);
berghofe@15399
   100
      in
berghofe@15399
   101
        get_first (fn (_, (prems, (tm1, tm2))) =>
berghofe@15399
   102
        let
wenzelm@19466
   103
          fun ren t = the_default t (Term.rename_abs tm1 tm t);
berghofe@15399
   104
          val inc = Logic.incr_indexes ([], maxidx_of_term tm + 1);
wenzelm@18184
   105
          val env as (Tenv, tenv) = Pattern.match thy (inc tm1, tm) (Vartab.empty, Vartab.empty);
wenzelm@32035
   106
          val prems' = map (pairself (Envir.subst_term env o inc o ren)) prems;
berghofe@15399
   107
          val env' = Envir.Envir
wenzelm@32032
   108
            {maxidx = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u) prems' ~1,
wenzelm@32032
   109
             tenv = tenv, tyenv = Tenv};
wenzelm@18184
   110
          val env'' = fold (Pattern.unify thy o pairself (lookup rew)) prems' env';
skalberg@15531
   111
        in SOME (Envir.norm_term env'' (inc (ren tm2)))
skalberg@15531
   112
        end handle Pattern.MATCH => NONE | Pattern.Unif => NONE)
wenzelm@16486
   113
          (sort (int_ord o pairself fst)
wenzelm@18956
   114
            (Net.match_term rules (Envir.eta_contract tm)))
berghofe@15399
   115
      end;
berghofe@13402
   116
berghofe@13402
   117
  in rew end;
berghofe@13402
   118
wenzelm@37310
   119
val chtype = Proofterm.change_type o SOME;
berghofe@13402
   120
wenzelm@30364
   121
fun extr_name s vs = Long_Name.append "extr" (space_implode "_" (s :: vs));
wenzelm@16195
   122
fun corr_name s vs = extr_name s vs ^ "_correctness";
berghofe@13402
   123
wenzelm@48704
   124
fun msg d s = Output.urgent_message (Pretty.spaces d ^ s);
berghofe@13402
   125
berghofe@28812
   126
fun vars_of t = map Var (rev (Term.add_vars t []));
berghofe@28812
   127
fun frees_of t = map Free (rev (Term.add_frees t []));
berghofe@28812
   128
fun vfs_of t = vars_of t @ frees_of t;
berghofe@13402
   129
berghofe@37233
   130
val mkabs = fold_rev (fn v => fn t => Abs ("x", fastype_of v, abstract_over (v, t)));
berghofe@13402
   131
berghofe@37233
   132
val mkabsp = fold_rev (fn t => fn prf => AbsP ("H", SOME t, prf));
berghofe@13402
   133
berghofe@13732
   134
fun strip_abs 0 t = t
berghofe@13732
   135
  | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t
berghofe@13732
   136
  | strip_abs _ _ = error "strip_abs: not an abstraction";
berghofe@13732
   137
wenzelm@37310
   138
val prf_subst_TVars = Proofterm.map_proof_types o typ_subst_TVars;
berghofe@13402
   139
wenzelm@40844
   140
fun relevant_vars types prop =
wenzelm@40844
   141
  List.foldr
wenzelm@40844
   142
    (fn (Var ((a, _), T), vs) =>
wenzelm@40844
   143
        (case body_type T of
wenzelm@40844
   144
          Type (s, _) => if member (op =) types s then a :: vs else vs
wenzelm@40844
   145
        | _ => vs)
wenzelm@40844
   146
      | (_, vs) => vs) [] (vars_of prop);
berghofe@13402
   147
berghofe@13732
   148
fun tname_of (Type (s, _)) = s
berghofe@13732
   149
  | tname_of _ = "";
berghofe@13732
   150
berghofe@13732
   151
fun get_var_type t =
berghofe@13732
   152
  let
wenzelm@16865
   153
    val vs = Term.add_vars t [];
wenzelm@16865
   154
    val fs = Term.add_frees t [];
wenzelm@42406
   155
  in
wenzelm@42406
   156
    fn Var (ixn, _) =>
wenzelm@42406
   157
        (case AList.lookup (op =) vs ixn of
skalberg@15531
   158
          NONE => error "get_var_type: no such variable in term"
skalberg@15531
   159
        | SOME T => Var (ixn, T))
wenzelm@42406
   160
     | Free (s, _) =>
wenzelm@42406
   161
        (case AList.lookup (op =) fs s of
skalberg@15531
   162
          NONE => error "get_var_type: no such variable in term"
skalberg@15531
   163
        | SOME T => Free (s, T))
berghofe@13732
   164
    | _ => error "get_var_type: not a variable"
berghofe@13732
   165
  end;
berghofe@13732
   166
berghofe@37233
   167
fun read_term thy T s =
berghofe@37233
   168
  let
wenzelm@42360
   169
    val ctxt = Proof_Context.init_global thy
wenzelm@42406
   170
      |> Config.put Type_Infer_Context.const_sorts false
wenzelm@42360
   171
      |> Proof_Context.set_defsort [];
berghofe@37233
   172
    val parse = if T = propT then Syntax.parse_prop else Syntax.parse_term;
wenzelm@39288
   173
  in parse ctxt s |> Type.constraint T |> Syntax.check_term ctxt end;
berghofe@37233
   174
berghofe@13402
   175
berghofe@13402
   176
(**** theory data ****)
berghofe@13402
   177
wenzelm@22846
   178
(* theory data *)
berghofe@13402
   179
wenzelm@33522
   180
structure ExtractionData = Theory_Data
wenzelm@22846
   181
(
berghofe@13402
   182
  type T =
berghofe@13402
   183
    {realizes_eqns : rules,
berghofe@13402
   184
     typeof_eqns : rules,
berghofe@13732
   185
     types : (string * ((term -> term option) list *
berghofe@13732
   186
       (term -> typ -> term -> typ -> term) option)) list,
berghofe@13402
   187
     realizers : (string list * (term * proof)) list Symtab.table,
berghofe@13402
   188
     defs : thm list,
berghofe@37233
   189
     expand : string list,
wenzelm@16458
   190
     prep : (theory -> proof -> proof) option}
berghofe@13402
   191
berghofe@13402
   192
  val empty =
berghofe@13402
   193
    {realizes_eqns = empty_rules,
berghofe@13402
   194
     typeof_eqns = empty_rules,
berghofe@13402
   195
     types = [],
berghofe@13402
   196
     realizers = Symtab.empty,
berghofe@13402
   197
     defs = [],
berghofe@13402
   198
     expand = [],
skalberg@15531
   199
     prep = NONE};
wenzelm@16458
   200
  val extend = I;
berghofe@13402
   201
wenzelm@33522
   202
  fun merge
wenzelm@33522
   203
    ({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1,
berghofe@13402
   204
       realizers = realizers1, defs = defs1, expand = expand1, prep = prep1},
berghofe@13402
   205
      {realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2,
wenzelm@33522
   206
       realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T =
berghofe@13402
   207
    {realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2,
berghofe@13402
   208
     typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2,
haftmann@22717
   209
     types = AList.merge (op =) (K true) (types1, types2),
haftmann@33038
   210
     realizers = Symtab.merge_list (eq_set (op =) o pairself #1) (realizers1, realizers2),
haftmann@22662
   211
     defs = Library.merge Thm.eq_thm (defs1, defs2),
berghofe@37233
   212
     expand = Library.merge (op =) (expand1, expand2),
wenzelm@38761
   213
     prep = if is_some prep1 then prep1 else prep2};
wenzelm@22846
   214
);
berghofe@13402
   215
berghofe@13402
   216
fun read_condeq thy =
wenzelm@16458
   217
  let val thy' = add_syntax thy
berghofe@13402
   218
  in fn s =>
berghofe@37233
   219
    let val t = Logic.varify_global (read_term thy' propT s)
wenzelm@35424
   220
    in
wenzelm@35424
   221
      (map Logic.dest_equals (Logic.strip_imp_prems t),
wenzelm@35424
   222
        Logic.dest_equals (Logic.strip_imp_concl t))
wenzelm@35424
   223
      handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s)
wenzelm@35424
   224
    end
berghofe@13402
   225
  end;
berghofe@13402
   226
berghofe@13402
   227
(** preprocessor **)
berghofe@13402
   228
berghofe@13402
   229
fun set_preprocessor prep thy =
berghofe@13402
   230
  let val {realizes_eqns, typeof_eqns, types, realizers,
berghofe@13402
   231
    defs, expand, ...} = ExtractionData.get thy
berghofe@13402
   232
  in
berghofe@13402
   233
    ExtractionData.put
berghofe@13402
   234
      {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
skalberg@15531
   235
       realizers = realizers, defs = defs, expand = expand, prep = SOME prep} thy
berghofe@13402
   236
  end;
berghofe@13402
   237
berghofe@13402
   238
(** equations characterizing realizability **)
berghofe@13402
   239
berghofe@13402
   240
fun gen_add_realizes_eqns prep_eq eqns thy =
berghofe@13402
   241
  let val {realizes_eqns, typeof_eqns, types, realizers,
berghofe@13402
   242
    defs, expand, prep} = ExtractionData.get thy;
berghofe@13402
   243
  in
berghofe@13402
   244
    ExtractionData.put
wenzelm@33337
   245
      {realizes_eqns = fold_rev add_rule (map (prep_eq thy) eqns) realizes_eqns,
berghofe@13402
   246
       typeof_eqns = typeof_eqns, types = types, realizers = realizers,
berghofe@13402
   247
       defs = defs, expand = expand, prep = prep} thy
berghofe@13402
   248
  end
berghofe@13402
   249
berghofe@13402
   250
val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
berghofe@13402
   251
val add_realizes_eqns = gen_add_realizes_eqns read_condeq;
berghofe@13402
   252
berghofe@13402
   253
(** equations characterizing type of extracted program **)
berghofe@13402
   254
berghofe@13402
   255
fun gen_add_typeof_eqns prep_eq eqns thy =
berghofe@13402
   256
  let
berghofe@13402
   257
    val {realizes_eqns, typeof_eqns, types, realizers,
berghofe@13402
   258
      defs, expand, prep} = ExtractionData.get thy;
berghofe@13732
   259
    val eqns' = map (prep_eq thy) eqns
berghofe@13402
   260
  in
berghofe@13402
   261
    ExtractionData.put
berghofe@13402
   262
      {realizes_eqns = realizes_eqns, realizers = realizers,
wenzelm@33337
   263
       typeof_eqns = fold_rev add_rule eqns' typeof_eqns,
berghofe@13732
   264
       types = types, defs = defs, expand = expand, prep = prep} thy
berghofe@13402
   265
  end
berghofe@13402
   266
berghofe@13402
   267
val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
berghofe@13402
   268
val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
berghofe@13402
   269
berghofe@13402
   270
fun thaw (T as TFree (a, S)) =
wenzelm@28375
   271
      if exists_string (fn s => s = ":") a then TVar (unpack_ixn a, S) else T
berghofe@13402
   272
  | thaw (Type (a, Ts)) = Type (a, map thaw Ts)
berghofe@13402
   273
  | thaw T = T;
berghofe@13402
   274
berghofe@13402
   275
fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S)
berghofe@13402
   276
  | freeze (Type (a, Ts)) = Type (a, map freeze Ts)
berghofe@13402
   277
  | freeze T = T;
berghofe@13402
   278
berghofe@13402
   279
fun freeze_thaw f x =
wenzelm@20548
   280
  map_types thaw (f (map_types freeze x));
berghofe@13402
   281
wenzelm@16458
   282
fun etype_of thy vs Ts t =
berghofe@13402
   283
  let
wenzelm@16458
   284
    val {typeof_eqns, ...} = ExtractionData.get thy;
berghofe@13402
   285
    fun err () = error ("Unable to determine type of extracted program for\n" ^
wenzelm@26939
   286
      Syntax.string_of_term_global thy t)
wenzelm@46219
   287
  in
wenzelm@46219
   288
    (case
wenzelm@46219
   289
      strip_abs_body
wenzelm@46219
   290
        (freeze_thaw (condrew thy (#net typeof_eqns) [typeof_proc [] vs])
wenzelm@46219
   291
          (fold (Term.abs o pair "x") Ts
wenzelm@46219
   292
            (Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of
berghofe@13402
   293
      Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ())
wenzelm@46219
   294
    | _ => err ())
berghofe@13402
   295
  end;
berghofe@13402
   296
berghofe@13402
   297
(** realizers for axioms / theorems, together with correctness proofs **)
berghofe@13402
   298
berghofe@13402
   299
fun gen_add_realizers prep_rlz rs thy =
berghofe@13402
   300
  let val {realizes_eqns, typeof_eqns, types, realizers,
berghofe@13402
   301
    defs, expand, prep} = ExtractionData.get thy
berghofe@13402
   302
  in
berghofe@13402
   303
    ExtractionData.put
berghofe@13402
   304
      {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
wenzelm@25389
   305
       realizers = fold (Symtab.cons_list o prep_rlz thy) rs realizers,
berghofe@13402
   306
       defs = defs, expand = expand, prep = prep} thy
berghofe@13402
   307
  end
berghofe@13402
   308
berghofe@13402
   309
fun prep_realizer thy =
berghofe@13402
   310
  let
berghofe@13732
   311
    val {realizes_eqns, typeof_eqns, defs, types, ...} =
berghofe@13402
   312
      ExtractionData.get thy;
wenzelm@19482
   313
    val procs = maps (fst o snd) types;
berghofe@13732
   314
    val rtypes = map fst types;
wenzelm@16800
   315
    val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns);
berghofe@13402
   316
    val thy' = add_syntax thy;
berghofe@37233
   317
    val rd = Proof_Syntax.read_proof thy' true false;
berghofe@13402
   318
  in fn (thm, (vs, s1, s2)) =>
berghofe@13402
   319
    let
wenzelm@36744
   320
      val name = Thm.derivation_name thm;
wenzelm@21858
   321
      val _ = name <> "" orelse error "add_realizers: unnamed theorem";
berghofe@37233
   322
      val prop = Thm.unconstrainT thm |> prop_of |>
berghofe@37233
   323
        Pattern.rewrite_term thy' (map (Logic.dest_equals o prop_of) defs) [];
berghofe@13402
   324
      val vars = vars_of prop;
berghofe@13732
   325
      val vars' = filter_out (fn v =>
wenzelm@20664
   326
        member (op =) rtypes (tname_of (body_type (fastype_of v)))) vars;
berghofe@37233
   327
      val shyps = maps (fn Var ((x, i), _) =>
berghofe@37233
   328
        if member (op =) vs x then Logic.mk_of_sort
berghofe@37233
   329
          (TVar (("'" ^ x, i), []), Sign.defaultS thy')
berghofe@37233
   330
        else []) vars;
wenzelm@16458
   331
      val T = etype_of thy' vs [] prop;
wenzelm@33832
   332
      val (T', thw) = Type.legacy_freeze_thaw_type
berghofe@13732
   333
        (if T = nullT then nullT else map fastype_of vars' ---> T);
berghofe@37233
   334
      val t = map_types thw (read_term thy' T' s1);
wenzelm@16458
   335
      val r' = freeze_thaw (condrew thy' eqns
berghofe@37233
   336
        (procs @ [typeof_proc [] vs, rlz_proc]))
berghofe@13402
   337
          (Const ("realizes", T --> propT --> propT) $
berghofe@13732
   338
            (if T = nullT then t else list_comb (t, vars')) $ prop);
berghofe@37233
   339
      val r = Logic.list_implies (shyps,
berghofe@37233
   340
        fold_rev Logic.all (map (get_var_type r') vars) r');
wenzelm@16458
   341
      val prf = Reconstruct.reconstruct_proof thy' r (rd s2);
berghofe@13402
   342
    in (name, (vs, (t, prf))) end
berghofe@13402
   343
  end;
berghofe@13402
   344
berghofe@13402
   345
val add_realizers_i = gen_add_realizers
berghofe@13402
   346
  (fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf))));
berghofe@13402
   347
val add_realizers = gen_add_realizers prep_realizer;
berghofe@13402
   348
berghofe@13714
   349
fun realizes_of thy vs t prop =
berghofe@13714
   350
  let
berghofe@13714
   351
    val thy' = add_syntax thy;
berghofe@13732
   352
    val {realizes_eqns, typeof_eqns, defs, types, ...} =
berghofe@13714
   353
      ExtractionData.get thy';
haftmann@22717
   354
    val procs = maps (rev o fst o snd) types;
wenzelm@16800
   355
    val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns);
wenzelm@17203
   356
    val prop' = Pattern.rewrite_term thy'
berghofe@13714
   357
      (map (Logic.dest_equals o prop_of) defs) [] prop;
wenzelm@16458
   358
  in freeze_thaw (condrew thy' eqns
berghofe@37233
   359
    (procs @ [typeof_proc [] vs, rlz_proc]))
berghofe@13714
   360
      (Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop')
berghofe@13714
   361
  end;
berghofe@13714
   362
berghofe@37233
   363
fun abs_corr_shyps thy thm vs xs prf =
berghofe@37233
   364
  let
berghofe@37233
   365
    val S = Sign.defaultS thy;
berghofe@37233
   366
    val ((atyp_map, constraints, _), prop') =
berghofe@37233
   367
      Logic.unconstrainT (#shyps (rep_thm thm)) (prop_of thm);
berghofe@37233
   368
    val atyps = fold_types (fold_atyps (insert (op =))) (prop_of thm) [];
berghofe@37233
   369
    val Ts = map_filter (fn ((v, i), _) => if member (op =) vs v then
berghofe@37233
   370
        SOME (TVar (("'" ^ v, i), [])) else NONE)
berghofe@37233
   371
      (rev (Term.add_vars prop' []));
berghofe@37233
   372
    val cs = maps (fn T => map (pair T) S) Ts;
berghofe@37233
   373
    val constraints' = map Logic.mk_of_class cs;
berghofe@37233
   374
    fun typ_map T = Type.strip_sorts
berghofe@37233
   375
      (map_atyps (fn U => if member (op =) atyps U then atyp_map U else U) T);
berghofe@37233
   376
    fun mk_hyp (T, c) = Hyp (Logic.mk_of_class (typ_map T, c));
berghofe@37233
   377
    val xs' = map (map_types typ_map) xs
berghofe@37233
   378
  in
berghofe@37233
   379
    prf |>
wenzelm@37310
   380
    Same.commit (Proofterm.map_proof_same (map_types typ_map) typ_map mk_hyp) |>
wenzelm@37310
   381
    fold_rev Proofterm.implies_intr_proof' (map snd constraints) |>
wenzelm@37310
   382
    fold_rev Proofterm.forall_intr_proof' xs' |>
wenzelm@37310
   383
    fold_rev Proofterm.implies_intr_proof' constraints'
berghofe@37233
   384
  end;
berghofe@37233
   385
berghofe@13402
   386
(** expanding theorems / definitions **)
berghofe@13402
   387
wenzelm@33704
   388
fun add_expand_thm is_def thm thy =
berghofe@13402
   389
  let
berghofe@13402
   390
    val {realizes_eqns, typeof_eqns, types, realizers,
berghofe@13402
   391
      defs, expand, prep} = ExtractionData.get thy;
berghofe@13402
   392
wenzelm@36744
   393
    val name = Thm.derivation_name thm;
wenzelm@33704
   394
    val _ = name <> "" orelse error "add_expand_thm: unnamed theorem";
berghofe@13402
   395
  in
wenzelm@33704
   396
    thy |> ExtractionData.put
wenzelm@33704
   397
      (if is_def then
berghofe@13402
   398
        {realizes_eqns = realizes_eqns,
berghofe@37233
   399
         typeof_eqns = add_rule ([], Logic.dest_equals (map_types
berghofe@37233
   400
           Type.strip_sorts (prop_of (Drule.abs_def thm)))) typeof_eqns,
berghofe@13402
   401
         types = types,
wenzelm@22360
   402
         realizers = realizers, defs = insert Thm.eq_thm thm defs,
berghofe@13402
   403
         expand = expand, prep = prep}
berghofe@13402
   404
      else
berghofe@13402
   405
        {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
berghofe@13402
   406
         realizers = realizers, defs = defs,
berghofe@37233
   407
         expand = insert (op =) name expand, prep = prep})
berghofe@13402
   408
  end;
berghofe@13402
   409
wenzelm@33704
   410
fun extraction_expand is_def =
wenzelm@33704
   411
  Thm.declaration_attribute (fn th => Context.mapping (add_expand_thm is_def th) I);
berghofe@13402
   412
wenzelm@15801
   413
berghofe@13732
   414
(** types with computational content **)
berghofe@13732
   415
berghofe@13732
   416
fun add_types tys thy =
haftmann@22717
   417
  ExtractionData.map
haftmann@22717
   418
    (fn {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =>
berghofe@13732
   419
      {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns,
haftmann@22717
   420
       types = fold (AList.update (op =) o apfst (Sign.intern_type thy)) tys types,
haftmann@22717
   421
       realizers = realizers, defs = defs, expand = expand, prep = prep})
haftmann@22717
   422
    thy;
berghofe@13732
   423
berghofe@13402
   424
wenzelm@15801
   425
(** Pure setup **)
wenzelm@15801
   426
wenzelm@53171
   427
val _ = Theory.setup
wenzelm@18708
   428
  (add_types [("prop", ([], NONE))] #>
wenzelm@15801
   429
wenzelm@15801
   430
   add_typeof_eqns
wenzelm@15801
   431
     ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
wenzelm@15801
   432
    \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
wenzelm@15801
   433
    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('Q)))",
wenzelm@15801
   434
wenzelm@15801
   435
      "(typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
wenzelm@15801
   436
    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE(Null)))",
wenzelm@15801
   437
wenzelm@15801
   438
      "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
wenzelm@15801
   439
    \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
wenzelm@15801
   440
    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('P => 'Q)))",
wenzelm@15801
   441
wenzelm@15801
   442
      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
wenzelm@15801
   443
    \    (typeof (!!x. PROP P (x))) == (Type (TYPE(Null)))",
wenzelm@15801
   444
wenzelm@15801
   445
      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE('P))) ==>  \
wenzelm@15801
   446
    \    (typeof (!!x::'a. PROP P (x))) == (Type (TYPE('a => 'P)))",
wenzelm@15801
   447
wenzelm@15801
   448
      "(%x. typeof (f (x))) == (%x. Type (TYPE('f))) ==>  \
wenzelm@18708
   449
    \    (typeof (f)) == (Type (TYPE('f)))"] #>
wenzelm@15801
   450
wenzelm@15801
   451
   add_realizes_eqns
wenzelm@15801
   452
     ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
wenzelm@15801
   453
    \    (realizes (r) (PROP P ==> PROP Q)) ==  \
wenzelm@15801
   454
    \    (PROP realizes (Null) (PROP P) ==> PROP realizes (r) (PROP Q))",
wenzelm@15801
   455
wenzelm@15801
   456
      "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
wenzelm@15801
   457
    \  (typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
wenzelm@15801
   458
    \    (realizes (r) (PROP P ==> PROP Q)) ==  \
wenzelm@15801
   459
    \    (!!x::'P. PROP realizes (x) (PROP P) ==> PROP realizes (Null) (PROP Q))",
wenzelm@15801
   460
wenzelm@15801
   461
      "(realizes (r) (PROP P ==> PROP Q)) ==  \
wenzelm@15801
   462
    \  (!!x. PROP realizes (x) (PROP P) ==> PROP realizes (r (x)) (PROP Q))",
wenzelm@15801
   463
wenzelm@15801
   464
      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
wenzelm@15801
   465
    \    (realizes (r) (!!x. PROP P (x))) ==  \
wenzelm@15801
   466
    \    (!!x. PROP realizes (Null) (PROP P (x)))",
wenzelm@15801
   467
wenzelm@15801
   468
      "(realizes (r) (!!x. PROP P (x))) ==  \
wenzelm@18708
   469
    \  (!!x. PROP realizes (r (x)) (PROP P (x)))"] #>
wenzelm@15801
   470
wenzelm@56206
   471
   Attrib.setup @{binding extraction_expand} (Scan.succeed (extraction_expand false))
wenzelm@33704
   472
     "specify theorems to be expanded during extraction" #>
wenzelm@56206
   473
   Attrib.setup @{binding extraction_expand_def} (Scan.succeed (extraction_expand true))
wenzelm@53171
   474
     "specify definitions to be expanded during extraction");
wenzelm@15801
   475
wenzelm@15801
   476
berghofe@13402
   477
(**** extract program ****)
berghofe@13402
   478
berghofe@13402
   479
val dummyt = Const ("dummy", dummyT);
berghofe@13402
   480
haftmann@58436
   481
fun extract thm_vss thy =
berghofe@13402
   482
  let
wenzelm@16458
   483
    val thy' = add_syntax thy;
berghofe@13402
   484
    val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =
berghofe@13402
   485
      ExtractionData.get thy;
haftmann@22717
   486
    val procs = maps (rev o fst o snd) types;
berghofe@13732
   487
    val rtypes = map fst types;
berghofe@37233
   488
    val typroc = typeof_proc [];
wenzelm@19466
   489
    val prep = the_default (K I) prep thy' o ProofRewriteRules.elim_defs thy' false defs o
berghofe@37233
   490
      Reconstruct.expand_proof thy' (map (rpair NONE) ("" :: expand));
wenzelm@16800
   491
    val rrews = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns);
berghofe@13402
   492
berghofe@13402
   493
    fun find_inst prop Ts ts vs =
berghofe@13402
   494
      let
berghofe@13732
   495
        val rvs = relevant_vars rtypes prop;
berghofe@13402
   496
        val vars = vars_of prop;
berghofe@13402
   497
        val n = Int.min (length vars, length ts);
berghofe@13402
   498
wenzelm@33337
   499
        fun add_args (Var ((a, i), _), t) (vs', tye) =
wenzelm@20664
   500
          if member (op =) rvs a then
wenzelm@16458
   501
            let val T = etype_of thy' vs Ts t
berghofe@13402
   502
            in if T = nullT then (vs', tye)
berghofe@13402
   503
               else (a :: vs', (("'" ^ a, i), T) :: tye)
berghofe@13402
   504
            end
berghofe@13402
   505
          else (vs', tye)
berghofe@13402
   506
haftmann@33957
   507
      in fold_rev add_args (take n vars ~~ take n ts) ([], []) end;
berghofe@13402
   508
berghofe@37233
   509
    fun mk_shyps tye = maps (fn (ixn, _) =>
berghofe@37233
   510
      Logic.mk_of_sort (TVar (ixn, []), Sign.defaultS thy)) tye;
berghofe@37233
   511
berghofe@37233
   512
    fun mk_sprfs cs tye = maps (fn (_, T) =>
berghofe@37233
   513
      ProofRewriteRules.mk_of_sort_proof thy (map SOME cs)
berghofe@37233
   514
        (T, Sign.defaultS thy)) tye;
berghofe@37233
   515
haftmann@33038
   516
    fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst);
wenzelm@28375
   517
    fun find' (s: string) = map_filter (fn (s', x) => if s = s' then SOME x else NONE);
berghofe@13402
   518
wenzelm@46219
   519
    fun app_rlz_rews Ts vs t =
wenzelm@46219
   520
      strip_abs (length Ts)
wenzelm@46219
   521
        (freeze_thaw (condrew thy' rrews (procs @ [typroc vs, rlz_proc]))
wenzelm@46219
   522
          (fold (Term.abs o pair "x") Ts t));
berghofe@13732
   523
berghofe@13732
   524
    fun realizes_null vs prop = app_rlz_rews [] vs
berghofe@13732
   525
      (Const ("realizes", nullT --> propT --> propT) $ nullt $ prop);
berghofe@13402
   526
haftmann@49960
   527
    fun corr d vs ts Ts hs cs _ (PBound i) _ defs = (PBound i, defs)
berghofe@13402
   528
haftmann@49960
   529
      | corr d vs ts Ts hs cs t (Abst (s, SOME T, prf)) (Abst (_, _, prf')) defs =
haftmann@49960
   530
          let val (corr_prf, defs') = corr d vs [] (T :: Ts)
haftmann@49960
   531
            (dummyt :: hs) cs (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE)
haftmann@49960
   532
            prf (Proofterm.incr_pboundvars 1 0 prf') defs
haftmann@49960
   533
          in (Abst (s, SOME T, corr_prf), defs') end
berghofe@13402
   534
haftmann@49960
   535
      | corr d vs ts Ts hs cs t (AbsP (s, SOME prop, prf)) (AbsP (_, _, prf')) defs =
berghofe@13402
   536
          let
wenzelm@16458
   537
            val T = etype_of thy' vs Ts prop;
wenzelm@42407
   538
            val u = if T = nullT then
skalberg@15531
   539
                (case t of SOME u => SOME (incr_boundvars 1 u) | NONE => NONE)
skalberg@15531
   540
              else (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE);
haftmann@49960
   541
            val (corr_prf, defs') =
haftmann@49960
   542
              corr d vs [] (T :: Ts) (prop :: hs)
haftmann@49960
   543
                (prop :: cs) u (Proofterm.incr_pboundvars 0 1 prf)
haftmann@49960
   544
                (Proofterm.incr_pboundvars 0 1 prf') defs;
berghofe@13402
   545
            val rlz = Const ("realizes", T --> propT --> propT)
haftmann@49960
   546
          in (
berghofe@13732
   547
            if T = nullT then AbsP ("R",
skalberg@15531
   548
              SOME (app_rlz_rews Ts vs (rlz $ nullt $ prop)),
wenzelm@37310
   549
                Proofterm.prf_subst_bounds [nullt] corr_prf)
skalberg@15531
   550
            else Abst (s, SOME T, AbsP ("R",
skalberg@15531
   551
              SOME (app_rlz_rews (T :: Ts) vs
haftmann@49960
   552
                (rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf)), defs')
berghofe@13402
   553
          end
berghofe@13402
   554
haftmann@49960
   555
      | corr d vs ts Ts hs cs t' (prf % SOME t) (prf' % _) defs =
berghofe@13732
   556
          let
berghofe@13732
   557
            val (Us, T) = strip_type (fastype_of1 (Ts, t));
haftmann@49960
   558
            val (corr_prf, defs') = corr d vs (t :: ts) Ts hs cs
wenzelm@20664
   559
              (if member (op =) rtypes (tname_of T) then t'
haftmann@49960
   560
               else (case t' of SOME (u $ _) => SOME u | _ => NONE))
haftmann@49960
   561
               prf prf' defs;
wenzelm@20664
   562
            val u = if not (member (op =) rtypes (tname_of T)) then t else
berghofe@13732
   563
              let
wenzelm@16458
   564
                val eT = etype_of thy' vs Ts t;
berghofe@13732
   565
                val (r, Us') = if eT = nullT then (nullt, Us) else
berghofe@13732
   566
                  (Bound (length Us), eT :: Us);
berghofe@13732
   567
                val u = list_comb (incr_boundvars (length Us') t,
berghofe@13732
   568
                  map Bound (length Us - 1 downto 0));
haftmann@17271
   569
                val u' = (case AList.lookup (op =) types (tname_of T) of
skalberg@15531
   570
                    SOME ((_, SOME f)) => f r eT u T
berghofe@13732
   571
                  | _ => Const ("realizes", eT --> T --> T) $ r $ u)
wenzelm@46219
   572
              in app_rlz_rews Ts vs (fold_rev (Term.abs o pair "x") Us' u') end
haftmann@49960
   573
          in (corr_prf % SOME u, defs') end
berghofe@13402
   574
haftmann@49960
   575
      | corr d vs ts Ts hs cs t (prf1 %% prf2) (prf1' %% prf2') defs =
berghofe@13402
   576
          let
berghofe@13402
   577
            val prop = Reconstruct.prop_of' hs prf2';
wenzelm@16458
   578
            val T = etype_of thy' vs Ts prop;
haftmann@49960
   579
            val (f, u, defs1) = if T = nullT then (t, NONE, defs) else
berghofe@13402
   580
              (case t of
haftmann@49960
   581
                 SOME (f $ u) => (SOME f, SOME u, defs)
berghofe@13402
   582
               | _ =>
haftmann@49960
   583
                 let val (u, defs1) = extr d vs [] Ts hs prf2' defs
haftmann@49960
   584
                 in (NONE, SOME u, defs1) end)
haftmann@49960
   585
            val ((corr_prf1, corr_prf2), defs2) =
haftmann@49960
   586
              defs1
haftmann@49960
   587
              |> corr d vs [] Ts hs cs f prf1 prf1'
haftmann@49960
   588
              ||>> corr d vs [] Ts hs cs u prf2 prf2';
berghofe@13402
   589
          in
haftmann@49960
   590
            if T = nullT then (corr_prf1 %% corr_prf2, defs2) else
haftmann@49960
   591
              (corr_prf1 % u %% corr_prf2, defs2)
berghofe@13402
   592
          end
berghofe@13402
   593
haftmann@49960
   594
      | corr d vs ts Ts hs cs _ (prf0 as PThm (_, ((name, prop, SOME Ts'), body))) _ defs =
berghofe@13402
   595
          let
wenzelm@37310
   596
            val prf = Proofterm.join_proof body;
berghofe@13402
   597
            val (vs', tye) = find_inst prop Ts ts vs;
berghofe@37233
   598
            val shyps = mk_shyps tye;
berghofe@37233
   599
            val sprfs = mk_sprfs cs tye;
krauss@36042
   600
            val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye;
wenzelm@16458
   601
            val T = etype_of thy' vs' [] prop;
berghofe@13402
   602
            val defs' = if T = nullT then defs
haftmann@49960
   603
              else snd (extr d vs ts Ts hs prf0 defs)
berghofe@13402
   604
          in
haftmann@49960
   605
            if T = nullT andalso realizes_null vs' prop aconv prop then (prf0, defs)
haftmann@49960
   606
            else (case Symtab.lookup realizers name of
skalberg@15531
   607
              NONE => (case find vs' (find' name defs') of
skalberg@15531
   608
                NONE =>
berghofe@13402
   609
                  let
wenzelm@21858
   610
                    val _ = T = nullT orelse error "corr: internal error";
berghofe@13402
   611
                    val _ = msg d ("Building correctness proof for " ^ quote name ^
berghofe@13402
   612
                      (if null vs' then ""
berghofe@13402
   613
                       else " (relevant variables: " ^ commas_quote vs' ^ ")"));
wenzelm@16458
   614
                    val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf);
haftmann@49960
   615
                    val (corr_prf0, defs'') = corr (d + 1) vs' [] [] []
haftmann@49960
   616
                      (rev shyps) NONE prf' prf' defs';
berghofe@37233
   617
                    val corr_prf = mkabsp shyps corr_prf0;
berghofe@13732
   618
                    val corr_prop = Reconstruct.prop_of corr_prf;
berghofe@37233
   619
                    val corr_prf' =
wenzelm@37310
   620
                      Proofterm.proof_combP (Proofterm.proof_combt
wenzelm@28805
   621
                         (PThm (serial (),
krauss@36042
   622
                          ((corr_name name vs', corr_prop, SOME (map TVar (Term.add_tvars corr_prop [] |> rev))),
wenzelm@37310
   623
                            Future.value (Proofterm.approximate_proof_body corr_prf))),
wenzelm@37310
   624
                              vfs_of corr_prop),
berghofe@37233
   625
                              map PBound (length shyps - 1 downto 0)) |>
wenzelm@37310
   626
                      fold_rev Proofterm.forall_intr_proof'
wenzelm@37310
   627
                        (map (get_var_type corr_prop) (vfs_of prop)) |>
berghofe@37233
   628
                      mkabsp shyps
berghofe@13402
   629
                  in
haftmann@49960
   630
                    (Proofterm.proof_combP (prf_subst_TVars tye' corr_prf', sprfs),
haftmann@49960
   631
                      (name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'')
berghofe@13402
   632
                  end
wenzelm@37310
   633
              | SOME (_, (_, prf')) =>
haftmann@49960
   634
                  (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs'))
skalberg@15531
   635
            | SOME rs => (case find vs' rs of
haftmann@49960
   636
                SOME (_, prf') => (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs')
skalberg@15531
   637
              | NONE => error ("corr: no realizer for instance of theorem " ^
wenzelm@26939
   638
                  quote name ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
haftmann@49960
   639
                    (Reconstruct.prop_of (Proofterm.proof_combt (prf0, ts)))))))
berghofe@13402
   640
          end
berghofe@13402
   641
haftmann@49960
   642
      | corr d vs ts Ts hs cs _ (prf0 as PAxm (s, prop, SOME Ts')) _ defs =
berghofe@13402
   643
          let
berghofe@13402
   644
            val (vs', tye) = find_inst prop Ts ts vs;
krauss@36042
   645
            val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye
berghofe@13402
   646
          in
wenzelm@16458
   647
            if etype_of thy' vs' [] prop = nullT andalso
haftmann@49960
   648
              realizes_null vs' prop aconv prop then (prf0, defs)
wenzelm@18956
   649
            else case find vs' (Symtab.lookup_list realizers s) of
haftmann@49960
   650
              SOME (_, prf) => (Proofterm.proof_combP (prf_subst_TVars tye' prf, mk_sprfs cs tye),
haftmann@49960
   651
                defs)
skalberg@15531
   652
            | NONE => error ("corr: no realizer for instance of axiom " ^
wenzelm@26939
   653
                quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
wenzelm@37310
   654
                  (Reconstruct.prop_of (Proofterm.proof_combt (prf0, ts)))))
berghofe@13402
   655
          end
berghofe@13402
   656
haftmann@49960
   657
      | corr d vs ts Ts hs _ _ _ _ defs = error "corr: bad proof"
berghofe@13402
   658
haftmann@49960
   659
    and extr d vs ts Ts hs (PBound i) defs = (Bound i, defs)
berghofe@13402
   660
haftmann@49960
   661
      | extr d vs ts Ts hs (Abst (s, SOME T, prf)) defs =
haftmann@49960
   662
          let val (t, defs') = extr d vs []
haftmann@49960
   663
            (T :: Ts) (dummyt :: hs) (Proofterm.incr_pboundvars 1 0 prf) defs
haftmann@49960
   664
          in (Abs (s, T, t), defs') end
berghofe@13402
   665
haftmann@49960
   666
      | extr d vs ts Ts hs (AbsP (s, SOME t, prf)) defs =
berghofe@13402
   667
          let
wenzelm@16458
   668
            val T = etype_of thy' vs Ts t;
haftmann@49960
   669
            val (t, defs') =
haftmann@49960
   670
              extr d vs [] (T :: Ts) (t :: hs) (Proofterm.incr_pboundvars 0 1 prf) defs
haftmann@49960
   671
          in
haftmann@49960
   672
            (if T = nullT then subst_bound (nullt, t) else Abs (s, T, t), defs')
berghofe@13402
   673
          end
berghofe@13402
   674
haftmann@49960
   675
      | extr d vs ts Ts hs (prf % SOME t) defs =
haftmann@49960
   676
          let val (u, defs') = extr d vs (t :: ts) Ts hs prf defs
haftmann@49960
   677
          in (if member (op =) rtypes (tname_of (body_type (fastype_of1 (Ts, t)))) then u
haftmann@49960
   678
            else u $ t, defs')
berghofe@13732
   679
          end
berghofe@13402
   680
haftmann@49960
   681
      | extr d vs ts Ts hs (prf1 %% prf2) defs =
berghofe@13402
   682
          let
haftmann@49960
   683
            val (f, defs') = extr d vs [] Ts hs prf1 defs;
berghofe@13402
   684
            val prop = Reconstruct.prop_of' hs prf2;
wenzelm@16458
   685
            val T = etype_of thy' vs Ts prop
berghofe@13402
   686
          in
haftmann@49960
   687
            if T = nullT then (f, defs') else
haftmann@49960
   688
              let val (t, defs'') = extr d vs [] Ts hs prf2 defs'
haftmann@49960
   689
              in (f $ t, defs'') end
berghofe@13402
   690
          end
berghofe@13402
   691
haftmann@49960
   692
      | extr d vs ts Ts hs (prf0 as PThm (_, ((s, prop, SOME Ts'), body))) defs =
berghofe@13402
   693
          let
wenzelm@37310
   694
            val prf = Proofterm.join_proof body;
berghofe@13402
   695
            val (vs', tye) = find_inst prop Ts ts vs;
berghofe@37233
   696
            val shyps = mk_shyps tye;
krauss@36042
   697
            val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye
berghofe@13402
   698
          in
wenzelm@17412
   699
            case Symtab.lookup realizers s of
skalberg@15531
   700
              NONE => (case find vs' (find' s defs) of
skalberg@15531
   701
                NONE =>
berghofe@13402
   702
                  let
berghofe@13402
   703
                    val _ = msg d ("Extracting " ^ quote s ^
berghofe@13402
   704
                      (if null vs' then ""
berghofe@13402
   705
                       else " (relevant variables: " ^ commas_quote vs' ^ ")"));
wenzelm@16458
   706
                    val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf);
haftmann@49960
   707
                    val (t, defs') = extr (d + 1) vs' [] [] [] prf' defs;
haftmann@49960
   708
                    val (corr_prf, defs'') = corr (d + 1) vs' [] [] []
haftmann@49960
   709
                      (rev shyps) (SOME t) prf' prf' defs';
berghofe@13402
   710
berghofe@13402
   711
                    val nt = Envir.beta_norm t;
wenzelm@20664
   712
                    val args = filter_out (fn v => member (op =) rtypes
wenzelm@20664
   713
                      (tname_of (body_type (fastype_of v)))) (vfs_of prop);
wenzelm@33317
   714
                    val args' = filter (fn v => Logic.occs (v, nt)) args;
berghofe@37233
   715
                    val t' = mkabs args' nt;
berghofe@13402
   716
                    val T = fastype_of t';
berghofe@13732
   717
                    val cname = extr_name s vs';
berghofe@13402
   718
                    val c = Const (cname, T);
berghofe@37233
   719
                    val u = mkabs args (list_comb (c, args'));
berghofe@13402
   720
                    val eqn = Logic.mk_equals (c, t');
berghofe@13402
   721
                    val rlz =
berghofe@13402
   722
                      Const ("realizes", fastype_of nt --> propT --> propT);
berghofe@13732
   723
                    val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop);
berghofe@13732
   724
                    val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop);
berghofe@13732
   725
                    val f = app_rlz_rews [] vs'
berghofe@13732
   726
                      (Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop));
berghofe@13402
   727
berghofe@37233
   728
                    val corr_prf' = mkabsp shyps
wenzelm@37310
   729
                      (chtype [] Proofterm.equal_elim_axm %> lhs %> rhs %%
wenzelm@37310
   730
                       (chtype [propT] Proofterm.symmetric_axm %> rhs %> lhs %%
wenzelm@37310
   731
                         (chtype [T, propT] Proofterm.combination_axm %> f %> f %> c %> t' %%
wenzelm@37310
   732
                           (chtype [T --> propT] Proofterm.reflexive_axm %> f) %%
wenzelm@46909
   733
                           PAxm (Thm.def_name cname, eqn,
berghofe@37233
   734
                             SOME (map TVar (Term.add_tvars eqn [] |> rev))))) %% corr_prf);
berghofe@13732
   735
                    val corr_prop = Reconstruct.prop_of corr_prf';
berghofe@37233
   736
                    val corr_prf'' =
wenzelm@37310
   737
                      Proofterm.proof_combP (Proofterm.proof_combt
wenzelm@28805
   738
                        (PThm (serial (),
krauss@36042
   739
                         ((corr_name s vs', corr_prop, SOME (map TVar (Term.add_tvars corr_prop [] |> rev))),
wenzelm@37310
   740
                           Future.value (Proofterm.approximate_proof_body corr_prf'))),
wenzelm@37310
   741
                            vfs_of corr_prop),
berghofe@37233
   742
                             map PBound (length shyps - 1 downto 0)) |>
wenzelm@37310
   743
                      fold_rev Proofterm.forall_intr_proof'
wenzelm@37310
   744
                        (map (get_var_type corr_prop) (vfs_of prop)) |>
berghofe@37233
   745
                      mkabsp shyps
berghofe@13402
   746
                  in
haftmann@49960
   747
                    (subst_TVars tye' u,
haftmann@49960
   748
                      (s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'')
berghofe@13402
   749
                  end
haftmann@49960
   750
              | SOME ((_, u), _) => (subst_TVars tye' u, defs))
skalberg@15531
   751
            | SOME rs => (case find vs' rs of
haftmann@49960
   752
                SOME (t, _) => (subst_TVars tye' t, defs)
skalberg@15531
   753
              | NONE => error ("extr: no realizer for instance of theorem " ^
wenzelm@26939
   754
                  quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
wenzelm@37310
   755
                    (Reconstruct.prop_of (Proofterm.proof_combt (prf0, ts))))))
berghofe@13402
   756
          end
berghofe@13402
   757
haftmann@49960
   758
      | extr d vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) defs =
berghofe@13402
   759
          let
berghofe@13402
   760
            val (vs', tye) = find_inst prop Ts ts vs;
krauss@36042
   761
            val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye
berghofe@13402
   762
          in
wenzelm@18956
   763
            case find vs' (Symtab.lookup_list realizers s) of
haftmann@49960
   764
              SOME (t, _) => (subst_TVars tye' t, defs)
skalberg@15531
   765
            | NONE => error ("extr: no realizer for instance of axiom " ^
wenzelm@26939
   766
                quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm
wenzelm@37310
   767
                  (Reconstruct.prop_of (Proofterm.proof_combt (prf0, ts)))))
berghofe@13402
   768
          end
berghofe@13402
   769
haftmann@49960
   770
      | extr d vs ts Ts hs _ defs = error "extr: bad proof";
berghofe@13402
   771
haftmann@58436
   772
    fun prep_thm vs thm =
berghofe@13402
   773
      let
wenzelm@26626
   774
        val thy = Thm.theory_of_thm thm;
wenzelm@26626
   775
        val prop = Thm.prop_of thm;
wenzelm@28814
   776
        val prf = Thm.proof_of thm;
wenzelm@36744
   777
        val name = Thm.derivation_name thm;
wenzelm@21858
   778
        val _ = name <> "" orelse error "extraction: unnamed theorem";
wenzelm@21858
   779
        val _ = etype_of thy' vs [] prop <> nullT orelse error ("theorem " ^
berghofe@13402
   780
          quote name ^ " has no computational content")
haftmann@58436
   781
      in Reconstruct.reconstruct_proof thy prop prf end;
berghofe@13402
   782
wenzelm@33245
   783
    val defs =
haftmann@58436
   784
      fold (fn (thm, vs) => snd o (extr 0 vs [] [] [] o prep_thm vs) thm)
haftmann@58436
   785
        thm_vss [];
berghofe@13402
   786
wenzelm@16149
   787
    fun add_def (s, (vs, ((t, u), (prf, _)))) thy =
wenzelm@16458
   788
      (case Sign.const_type thy (extr_name s vs) of
skalberg@15531
   789
         NONE =>
berghofe@13732
   790
           let
berghofe@13732
   791
             val corr_prop = Reconstruct.prop_of prf;
wenzelm@33832
   792
             val ft = Type.legacy_freeze t;
wenzelm@33832
   793
             val fu = Type.legacy_freeze u;
haftmann@22750
   794
             val (def_thms, thy') = if t = nullt then ([], thy) else
haftmann@22750
   795
               thy
wenzelm@56239
   796
               |> Sign.add_consts [(Binding.qualified_name (extr_name s vs), fastype_of ft, NoSyn)]
wenzelm@46909
   797
               |> Global_Theory.add_defs false
wenzelm@46909
   798
                  [((Binding.qualified_name (Thm.def_name (extr_name s vs)),
haftmann@22750
   799
                    Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])]
berghofe@13732
   800
           in
haftmann@22750
   801
             thy'
wenzelm@39557
   802
             |> Global_Theory.store_thm (Binding.qualified_name (corr_name s vs),
berghofe@37233
   803
                  Thm.varifyT_global (funpow (length (vars_of corr_prop))
wenzelm@35985
   804
                    (Thm.forall_elim_var 0) (Thm.forall_intr_frees
wenzelm@44057
   805
                      (Proof_Checker.thm_of_proof thy'
wenzelm@26481
   806
                       (fst (Proofterm.freeze_thaw_prf prf))))))
haftmann@22750
   807
             |> snd
haftmann@28370
   808
             |> fold Code.add_default_eqn def_thms
berghofe@13732
   809
           end
skalberg@15531
   810
       | SOME _ => thy);
berghofe@13402
   811
wenzelm@16149
   812
  in
wenzelm@16149
   813
    thy
wenzelm@30435
   814
    |> Sign.root_path
wenzelm@16149
   815
    |> fold_rev add_def defs
wenzelm@22796
   816
    |> Sign.restore_naming thy
berghofe@13402
   817
  end;
berghofe@13402
   818
wenzelm@16458
   819
val etype_of = etype_of o add_syntax;
berghofe@13714
   820
berghofe@13402
   821
end;