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