src/Pure/Proof/extraction.ML
author berghofe
Wed Jan 29 17:32:01 2003 +0100 (2003-01-29)
changeset 13793 c02c81fd11b8
parent 13732 f8badfef5cf2
child 14472 cba7c0a3ffb3
permissions -rw-r--r--
Fixed bug in function corr.
     1 (*  Title:      Pure/Proof/extraction.ML
     2     ID:         $Id$
     3     Author:     Stefan Berghofer, TU Muenchen
     4     License:    GPL (GNU GENERAL PUBLIC LICENSE)
     5 
     6 Extraction of programs from proofs.
     7 *)
     8 
     9 signature EXTRACTION =
    10 sig
    11   val set_preprocessor : (Sign.sg -> Proofterm.proof -> Proofterm.proof) -> theory -> theory
    12   val add_realizes_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    13   val add_realizes_eqns : string list -> theory -> theory
    14   val add_typeof_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    15   val add_typeof_eqns : string list -> theory -> theory
    16   val add_realizers_i : (string * (string list * term * Proofterm.proof)) list
    17     -> theory -> theory
    18   val add_realizers : (thm * (string list * string * string)) list
    19     -> theory -> theory
    20   val add_expand_thms : thm list -> theory -> theory
    21   val add_types : (xstring * ((term -> term option) list *
    22     (term -> typ -> term -> typ -> term) option)) list -> theory -> theory
    23   val extract : (thm * string list) list -> theory -> theory
    24   val nullT : typ
    25   val nullt : term
    26   val mk_typ : typ -> term
    27   val etype_of : theory -> string list -> typ list -> term -> typ
    28   val realizes_of: theory -> string list -> term -> term -> term
    29   val parsers: OuterSyntax.parser list
    30   val setup: (theory -> theory) list
    31 end;
    32 
    33 structure Extraction : EXTRACTION =
    34 struct
    35 
    36 open Proofterm;
    37 
    38 (**** tools ****)
    39 
    40 fun add_syntax thy =
    41   thy
    42   |> Theory.copy
    43   |> Theory.root_path
    44   |> Theory.add_types [("Type", 0, NoSyn), ("Null", 0, NoSyn)]
    45   |> Theory.add_arities [("Type", [], "logic"), ("Null", [], "logic")]
    46   |> Theory.add_consts
    47       [("typeof", "'b::logic => Type", NoSyn),
    48        ("Type", "'a::logic itself => Type", NoSyn),
    49        ("Null", "Null", NoSyn),
    50        ("realizes", "'a::logic => 'b::logic => 'b", NoSyn)];
    51 
    52 val nullT = Type ("Null", []);
    53 val nullt = Const ("Null", nullT);
    54 
    55 fun mk_typ T =
    56   Const ("Type", itselfT T --> Type ("Type", [])) $ Logic.mk_type T;
    57 
    58 fun typeof_proc defaultS vs (Const ("typeof", _) $ u) =
    59       Some (mk_typ (case strip_comb u of
    60           (Var ((a, i), _), _) =>
    61             if a mem vs then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS)
    62             else nullT
    63         | (Free (a, _), _) =>
    64             if a mem vs then TFree ("'" ^ a, defaultS) else nullT
    65         | _ => nullT))
    66   | typeof_proc _ _ _ = None;
    67 
    68 fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ r $ t) = Some t
    69   | rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) =
    70       (case strip_comb t of
    71          (Var (ixn, U), ts) => Some (list_comb (Var (ixn, T --> U), r :: ts))
    72        | (Free (s, U), ts) => Some (list_comb (Free (s, T --> U), r :: ts))
    73        | _ => None)
    74   | rlz_proc _ = None;
    75 
    76 val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o
    77   take_prefix (not o equal ":") o explode;
    78 
    79 type rules =
    80   {next: int, rs: ((term * term) list * (term * term)) list,
    81    net: (int * ((term * term) list * (term * term))) Net.net};
    82 
    83 val empty_rules : rules = {next = 0, rs = [], net = Net.empty};
    84 
    85 fun add_rule (r as (_, (lhs, _)), {next, rs, net} : rules) =
    86   {next = next - 1, rs = r :: rs, net = Net.insert_term
    87      ((Pattern.eta_contract lhs, (next, r)), net, K false)};
    88 
    89 fun merge_rules
    90   ({next, rs = rs1, net} : rules) ({next = next2, rs = rs2, ...} : rules) =
    91   foldr add_rule (rs2 \\ rs1, {next = next, rs = rs1, net = net});
    92 
    93 fun condrew sign rules procs =
    94   let
    95     val tsig = Sign.tsig_of sign;
    96 
    97     fun rew tm =
    98       Pattern.rewrite_term tsig [] (condrew' :: procs) tm
    99     and condrew' tm = get_first (fn (_, (prems, (tm1, tm2))) =>
   100       let
   101         fun ren t = if_none (Term.rename_abs tm1 tm t) t;
   102         val inc = Logic.incr_indexes ([], maxidx_of_term tm + 1);
   103         val env as (Tenv, tenv) = Pattern.match tsig (inc tm1, tm);
   104         val prems' = map (pairself (subst_vars env o inc o ren)) prems;
   105         val env' = Envir.Envir
   106           {maxidx = foldl Int.max
   107             (~1, map (Int.max o pairself maxidx_of_term) prems'),
   108            iTs = Vartab.make Tenv, asol = Vartab.make tenv};
   109         val env'' = foldl (fn (env, p) =>
   110           Pattern.unify (sign, env, [pairself rew p])) (env', prems')
   111       in Some (Envir.norm_term env'' (inc (ren tm2)))
   112       end handle Pattern.MATCH => None | Pattern.Unif => None)
   113         (sort (int_ord o pairself fst)
   114           (Net.match_term rules (Pattern.eta_contract tm)));
   115 
   116   in rew end;
   117 
   118 val chtype = change_type o Some;
   119 
   120 fun add_prefix a b = NameSpace.pack (a :: NameSpace.unpack b);
   121 
   122 fun corr_name s vs =
   123   add_prefix "extr" (space_implode "_" (s :: vs)) ^ "_correctness";
   124 
   125 fun extr_name s vs = add_prefix "extr" (space_implode "_" (s :: vs));
   126 
   127 fun msg d s = priority (implode (replicate d " ") ^ s);
   128 
   129 fun vars_of t = rev (foldl_aterms
   130   (fn (vs, v as Var _) => v ins vs | (vs, _) => vs) ([], t));
   131 
   132 fun vfs_of t = vars_of t @ sort (make_ord atless) (term_frees t);
   133 
   134 fun forall_intr (t, prop) =
   135   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   136   in all T $ Abs (a, T, abstract_over (t, prop)) end;
   137 
   138 fun forall_intr_prf (t, prf) =
   139   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   140   in Abst (a, Some T, prf_abstract_over t prf) end;
   141 
   142 val mkabs = foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t)));
   143 
   144 fun strip_abs 0 t = t
   145   | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t
   146   | strip_abs _ _ = error "strip_abs: not an abstraction";
   147 
   148 fun prf_subst_TVars tye =
   149   map_proof_terms (subst_TVars tye) (typ_subst_TVars tye);
   150 
   151 fun relevant_vars types prop = foldr (fn
   152       (Var ((a, i), T), vs) => (case strip_type T of
   153         (_, Type (s, _)) => if s mem types then a :: vs else vs
   154       | _ => vs)
   155     | (_, vs) => vs) (vars_of prop, []);
   156 
   157 fun tname_of (Type (s, _)) = s
   158   | tname_of _ = "";
   159 
   160 fun get_var_type t =
   161   let
   162     val vs = Term.add_vars ([], t);
   163     val fs = Term.add_frees ([], t)
   164   in fn 
   165       Var (ixn, _) => (case assoc (Term.add_vars ([], t), ixn) of
   166           None => error "get_var_type: no such variable in term"
   167         | Some T => Var (ixn, T))
   168     | Free (s, _) => (case assoc (Term.add_frees ([], t), s) of
   169           None => error "get_var_type: no such variable in term"
   170         | Some T => Free (s, T))
   171     | _ => error "get_var_type: not a variable"
   172   end;
   173 
   174 
   175 (**** theory data ****)
   176 
   177 (* data kind 'Pure/extraction' *)
   178 
   179 structure ExtractionArgs =
   180 struct
   181   val name = "Pure/extraction";
   182   type T =
   183     {realizes_eqns : rules,
   184      typeof_eqns : rules,
   185      types : (string * ((term -> term option) list *
   186        (term -> typ -> term -> typ -> term) option)) list,
   187      realizers : (string list * (term * proof)) list Symtab.table,
   188      defs : thm list,
   189      expand : (string * term) list,
   190      prep : (Sign.sg -> proof -> proof) option}
   191 
   192   val empty =
   193     {realizes_eqns = empty_rules,
   194      typeof_eqns = empty_rules,
   195      types = [],
   196      realizers = Symtab.empty,
   197      defs = [],
   198      expand = [],
   199      prep = None};
   200   val copy = I;
   201   val prep_ext = 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 * T) =
   208     {realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2,
   209      typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2,
   210      types = merge_alists types1 types2,
   211      realizers = Symtab.merge_multi' (eq_set o pairself #1)
   212        (realizers1, realizers2),
   213      defs = gen_merge_lists eq_thm defs1 defs2,
   214      expand = merge_lists expand1 expand2,
   215      prep = (case prep1 of None => prep2 | _ => prep1)};
   216 
   217   fun print sg (x : T) = ();
   218 end;
   219 
   220 structure ExtractionData = TheoryDataFun(ExtractionArgs);
   221 
   222 fun read_condeq thy =
   223   let val sg = sign_of (add_syntax thy)
   224   in fn s =>
   225     let val t = Logic.varify (term_of (read_cterm sg (s, propT)))
   226     in (map Logic.dest_equals (Logic.strip_imp_prems t),
   227       Logic.dest_equals (Logic.strip_imp_concl t))
   228     end handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s)
   229   end;
   230 
   231 (** preprocessor **)
   232 
   233 fun set_preprocessor prep thy =
   234   let val {realizes_eqns, typeof_eqns, types, realizers,
   235     defs, expand, ...} = ExtractionData.get thy
   236   in
   237     ExtractionData.put
   238       {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   239        realizers = realizers, defs = defs, expand = expand, prep = Some prep} thy
   240   end;
   241 
   242 (** equations characterizing realizability **)
   243 
   244 fun gen_add_realizes_eqns prep_eq eqns thy =
   245   let val {realizes_eqns, typeof_eqns, types, realizers,
   246     defs, expand, prep} = ExtractionData.get thy;
   247   in
   248     ExtractionData.put
   249       {realizes_eqns = foldr add_rule (map (prep_eq thy) eqns, realizes_eqns),
   250        typeof_eqns = typeof_eqns, types = types, realizers = realizers,
   251        defs = defs, expand = expand, prep = prep} thy
   252   end
   253 
   254 val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
   255 val add_realizes_eqns = gen_add_realizes_eqns read_condeq;
   256 
   257 (** equations characterizing type of extracted program **)
   258 
   259 fun gen_add_typeof_eqns prep_eq eqns thy =
   260   let
   261     val {realizes_eqns, typeof_eqns, types, realizers,
   262       defs, expand, prep} = ExtractionData.get thy;
   263     val eqns' = map (prep_eq thy) eqns
   264   in
   265     ExtractionData.put
   266       {realizes_eqns = realizes_eqns, realizers = realizers,
   267        typeof_eqns = foldr add_rule (eqns', typeof_eqns),
   268        types = types, defs = defs, expand = expand, prep = prep} thy
   269   end
   270 
   271 val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
   272 val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
   273 
   274 fun thaw (T as TFree (a, S)) =
   275       if ":" mem explode a then TVar (unpack_ixn a, S) else T
   276   | thaw (Type (a, Ts)) = Type (a, map thaw Ts)
   277   | thaw T = T;
   278 
   279 fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S)
   280   | freeze (Type (a, Ts)) = Type (a, map freeze Ts)
   281   | freeze T = T;
   282 
   283 fun freeze_thaw f x =
   284   map_term_types thaw (f (map_term_types freeze x));
   285 
   286 fun etype_of sg vs Ts t =
   287   let
   288     val {typeof_eqns, ...} = ExtractionData.get_sg sg;
   289     fun err () = error ("Unable to determine type of extracted program for\n" ^
   290       Sign.string_of_term sg t)
   291   in case strip_abs_body (freeze_thaw (condrew sg (#net typeof_eqns)
   292     [typeof_proc (Sign.defaultS sg) vs]) (list_abs (map (pair "x") (rev 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 = foldr Symtab.update_multi
   307          (map (prep_rlz thy) (rev rs), realizers),
   308        defs = defs, expand = expand, prep = prep} thy
   309   end
   310 
   311 fun prep_realizer thy =
   312   let
   313     val {realizes_eqns, typeof_eqns, defs, types, ...} =
   314       ExtractionData.get thy;
   315     val procs = flat (map (fst o snd) types);
   316     val rtypes = map fst types;
   317     val eqns = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   318     val thy' = add_syntax thy;
   319     val sign = sign_of thy';
   320     val tsg = Sign.tsig_of sign;
   321     val rd = ProofSyntax.read_proof thy' false
   322   in fn (thm, (vs, s1, s2)) =>
   323     let
   324       val name = Thm.name_of_thm thm;
   325       val _ = assert (name <> "") "add_realizers: unnamed theorem";
   326       val prop = Pattern.rewrite_term tsg
   327         (map (Logic.dest_equals o prop_of) defs) [] (prop_of thm);
   328       val vars = vars_of prop;
   329       val vars' = filter_out (fn v =>
   330         tname_of (body_type (fastype_of v)) mem rtypes) vars;
   331       val T = etype_of sign vs [] prop;
   332       val (T', thw) = Type.freeze_thaw_type
   333         (if T = nullT then nullT else map fastype_of vars' ---> T);
   334       val t = map_term_types thw (term_of (read_cterm sign (s1, T')));
   335       val r' = freeze_thaw (condrew sign eqns
   336         (procs @ [typeof_proc (Sign.defaultS sign) vs, rlz_proc]))
   337           (Const ("realizes", T --> propT --> propT) $
   338             (if T = nullT then t else list_comb (t, vars')) $ prop);
   339       val r = foldr forall_intr (map (get_var_type r') vars, r');
   340       val prf = Reconstruct.reconstruct_proof sign r (rd s2);
   341     in (name, (vs, (t, prf))) end
   342   end;
   343 
   344 val add_realizers_i = gen_add_realizers
   345   (fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf))));
   346 val add_realizers = gen_add_realizers prep_realizer;
   347 
   348 fun realizes_of thy vs t prop =
   349   let
   350     val thy' = add_syntax thy;
   351     val sign = sign_of thy';
   352     val {realizes_eqns, typeof_eqns, defs, types, ...} =
   353       ExtractionData.get thy';
   354     val procs = flat (map (fst o snd) types);
   355     val eqns = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   356     val prop' = Pattern.rewrite_term (Sign.tsig_of sign)
   357       (map (Logic.dest_equals o prop_of) defs) [] prop;
   358   in freeze_thaw (condrew sign eqns
   359     (procs @ [typeof_proc (Sign.defaultS sign) vs, rlz_proc]))
   360       (Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop')
   361   end;
   362 
   363 (** expanding theorems / definitions **)
   364 
   365 fun add_expand_thm (thy, thm) =
   366   let
   367     val {realizes_eqns, typeof_eqns, types, realizers,
   368       defs, expand, prep} = ExtractionData.get thy;
   369 
   370     val name = Thm.name_of_thm thm;
   371     val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   372 
   373     val is_def =
   374       (case strip_comb (fst (Logic.dest_equals (prop_of thm))) of
   375          (Const _, ts) => forall is_Var ts andalso null (duplicates ts)
   376            andalso exists (fn thy =>
   377                is_some (Symtab.lookup (#axioms (rep_theory thy), name)))
   378              (thy :: ancestors_of thy)
   379        | _ => false) handle TERM _ => false;
   380 
   381     val name = Thm.name_of_thm thm;
   382     val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   383   in
   384     (ExtractionData.put (if is_def then
   385         {realizes_eqns = realizes_eqns,
   386          typeof_eqns = add_rule (([],
   387            Logic.dest_equals (prop_of (Drule.abs_def thm))), typeof_eqns),
   388          types = types,
   389          realizers = realizers, defs = gen_ins eq_thm (thm, defs),
   390          expand = expand, prep = prep}
   391       else
   392         {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   393          realizers = realizers, defs = defs,
   394          expand = (name, prop_of thm) ins expand, prep = prep}) thy, thm)
   395   end;
   396 
   397 fun add_expand_thms thms thy = foldl (fst o add_expand_thm) (thy, thms);
   398 
   399 (** types with computational content **)
   400 
   401 fun add_types tys thy =
   402   let val {realizes_eqns, typeof_eqns, types, realizers,
   403     defs, expand, prep} = ExtractionData.get thy;
   404   in
   405     ExtractionData.put
   406       {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns,
   407        types = map (apfst (Sign.intern_tycon (sign_of thy))) tys @ types,
   408        realizers = realizers, defs = defs, expand = expand, prep = prep} thy
   409   end;
   410 
   411 
   412 (**** extract program ****)
   413 
   414 val dummyt = Const ("dummy", dummyT);
   415 
   416 fun extract thms thy =
   417   let
   418     val sg = sign_of (add_syntax thy);
   419     val tsg = Sign.tsig_of sg;
   420     val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =
   421       ExtractionData.get thy;
   422     val procs = flat (map (fst o snd) types);
   423     val rtypes = map fst types;
   424     val typroc = typeof_proc (Sign.defaultS sg);
   425     val prep = if_none prep (K I) sg o ProofRewriteRules.elim_defs sg false defs o
   426       Reconstruct.expand_proof sg (("", None) :: map (apsnd Some) expand);
   427     val rrews = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   428 
   429     fun find_inst prop Ts ts vs =
   430       let
   431         val rvs = relevant_vars rtypes prop;
   432         val vars = vars_of prop;
   433         val n = Int.min (length vars, length ts);
   434 
   435         fun add_args ((Var ((a, i), _), t), (vs', tye)) =
   436           if a mem rvs then
   437             let val T = etype_of sg vs Ts t
   438             in if T = nullT then (vs', tye)
   439                else (a :: vs', (("'" ^ a, i), T) :: tye)
   440             end
   441           else (vs', tye)
   442 
   443       in foldr add_args (take (n, vars) ~~ take (n, ts), ([], [])) end;
   444 
   445     fun find vs = apsome snd o find_first (curry eq_set vs o fst);
   446     fun find' s = map snd o filter (equal s o fst)
   447 
   448     fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw
   449       (condrew sg rrews (procs @ [typroc vs, rlz_proc])) (list_abs
   450         (map (pair "x") (rev Ts), t)));
   451 
   452     fun realizes_null vs prop = app_rlz_rews [] vs
   453       (Const ("realizes", nullT --> propT --> propT) $ nullt $ prop);
   454 
   455     fun corr d defs vs ts Ts hs (PBound i) _ _ = (defs, PBound i)
   456 
   457       | corr d defs vs ts Ts hs (Abst (s, Some T, prf)) (Abst (_, _, prf')) t =
   458           let val (defs', corr_prf) = corr d defs vs [] (T :: Ts)
   459             (dummyt :: hs) prf (incr_pboundvars 1 0 prf')
   460             (case t of Some (Abs (_, _, u)) => Some u | _ => None)
   461           in (defs', Abst (s, Some T, corr_prf)) end
   462 
   463       | corr d defs vs ts Ts hs (AbsP (s, Some prop, prf)) (AbsP (_, _, prf')) t =
   464           let
   465             val T = etype_of sg vs Ts prop;
   466             val u = if T = nullT then 
   467                 (case t of Some u => Some (incr_boundvars 1 u) | None => None)
   468               else (case t of Some (Abs (_, _, u)) => Some u | _ => None);
   469             val (defs', corr_prf) = corr d defs vs [] (T :: Ts) (prop :: hs)
   470               (incr_pboundvars 0 1 prf) (incr_pboundvars 0 1 prf') u;
   471             val rlz = Const ("realizes", T --> propT --> propT)
   472           in (defs',
   473             if T = nullT then AbsP ("R",
   474               Some (app_rlz_rews Ts vs (rlz $ nullt $ prop)),
   475                 prf_subst_bounds [nullt] corr_prf)
   476             else Abst (s, Some T, AbsP ("R",
   477               Some (app_rlz_rews (T :: Ts) vs
   478                 (rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf)))
   479           end
   480 
   481       | corr d defs vs ts Ts hs (prf % Some t) (prf' % _) t' =
   482           let
   483             val (Us, T) = strip_type (fastype_of1 (Ts, t));
   484             val (defs', corr_prf) = corr d defs vs (t :: ts) Ts hs prf prf'
   485               (if tname_of T mem rtypes then t'
   486                else (case t' of Some (u $ _) => Some u | _ => None));
   487             val u = if not (tname_of T mem rtypes) then t else
   488               let
   489                 val eT = etype_of sg vs Ts t;
   490                 val (r, Us') = if eT = nullT then (nullt, Us) else
   491                   (Bound (length Us), eT :: Us);
   492                 val u = list_comb (incr_boundvars (length Us') t,
   493                   map Bound (length Us - 1 downto 0));
   494                 val u' = (case assoc (types, tname_of T) of
   495                     Some ((_, Some f)) => f r eT u T
   496                   | _ => Const ("realizes", eT --> T --> T) $ r $ u)
   497               in app_rlz_rews Ts vs (list_abs (map (pair "x") Us', u')) end
   498           in (defs', corr_prf % Some u) end
   499 
   500       | corr d defs vs ts Ts hs (prf1 %% prf2) (prf1' %% prf2') t =
   501           let
   502             val prop = Reconstruct.prop_of' hs prf2';
   503             val T = etype_of sg vs Ts prop;
   504             val (defs1, f, u) = if T = nullT then (defs, t, None) else
   505               (case t of
   506                  Some (f $ u) => (defs, Some f, Some u)
   507                | _ =>
   508                  let val (defs1, u) = extr d defs vs [] Ts hs prf2'
   509                  in (defs1, None, Some u) end)
   510             val (defs2, corr_prf1) = corr d defs1 vs [] Ts hs prf1 prf1' f;
   511             val (defs3, corr_prf2) = corr d defs2 vs [] Ts hs prf2 prf2' u;
   512           in
   513             if T = nullT then (defs3, corr_prf1 %% corr_prf2) else
   514               (defs3, corr_prf1 % u %% corr_prf2)
   515           end
   516 
   517       | corr d defs vs ts Ts hs (prf0 as PThm ((name, _), prf, prop, Some Ts')) _ _ =
   518           let
   519             val (vs', tye) = find_inst prop Ts ts vs;
   520             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye;
   521             val T = etype_of sg vs' [] prop;
   522             val defs' = if T = nullT then defs
   523               else fst (extr d defs vs ts Ts hs prf0)
   524           in
   525             if T = nullT andalso realizes_null vs' prop aconv prop then (defs, prf0)
   526             else case Symtab.lookup (realizers, name) of
   527               None => (case find vs' (find' name defs') of
   528                 None =>
   529                   let
   530                     val _ = assert (T = nullT) "corr: internal error";
   531                     val _ = msg d ("Building correctness proof for " ^ quote name ^
   532                       (if null vs' then ""
   533                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   534                     val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   535                     val (defs'', corr_prf) =
   536                       corr (d + 1) defs' vs' [] [] [] prf' prf' None;
   537                     val corr_prop = Reconstruct.prop_of corr_prf;
   538                     val corr_prf' = foldr forall_intr_prf
   539                       (map (get_var_type corr_prop) (vfs_of prop), proof_combt
   540                          (PThm ((corr_name name vs', []), corr_prf, corr_prop,
   541                              Some (map TVar (term_tvars corr_prop))), vfs_of corr_prop))
   542                   in
   543                     ((name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'',
   544                      prf_subst_TVars tye' corr_prf')
   545                   end
   546               | Some (_, (_, prf')) => (defs', prf_subst_TVars tye' prf'))
   547             | Some rs => (case find vs' rs of
   548                 Some (_, prf') => (defs', prf_subst_TVars tye' prf')
   549               | None => error ("corr: no realizer for instance of theorem " ^
   550                   quote name ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   551                     (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   552           end
   553 
   554       | corr d defs vs ts Ts hs (prf0 as PAxm (s, prop, Some Ts')) _ _ =
   555           let
   556             val (vs', tye) = find_inst prop Ts ts vs;
   557             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   558           in
   559             if etype_of sg vs' [] prop = nullT andalso
   560               realizes_null vs' prop aconv prop then (defs, prf0)
   561             else case find vs' (Symtab.lookup_multi (realizers, s)) of
   562               Some (_, prf) => (defs, prf_subst_TVars tye' prf)
   563             | None => error ("corr: no realizer for instance of axiom " ^
   564                 quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   565                   (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   566           end
   567 
   568       | corr d defs vs ts Ts hs _ _ _ = error "corr: bad proof"
   569 
   570     and extr d defs vs ts Ts hs (PBound i) = (defs, Bound i)
   571 
   572       | extr d defs vs ts Ts hs (Abst (s, Some T, prf)) =
   573           let val (defs', t) = extr d defs vs []
   574             (T :: Ts) (dummyt :: hs) (incr_pboundvars 1 0 prf)
   575           in (defs', Abs (s, T, t)) end
   576 
   577       | extr d defs vs ts Ts hs (AbsP (s, Some t, prf)) =
   578           let
   579             val T = etype_of sg vs Ts t;
   580             val (defs', t) = extr d defs vs [] (T :: Ts) (t :: hs)
   581               (incr_pboundvars 0 1 prf)
   582           in (defs',
   583             if T = nullT then subst_bound (nullt, t) else Abs (s, T, t))
   584           end
   585 
   586       | extr d defs vs ts Ts hs (prf % Some t) =
   587           let val (defs', u) = extr d defs vs (t :: ts) Ts hs prf
   588           in (defs',
   589             if tname_of (body_type (fastype_of1 (Ts, t))) mem rtypes then u
   590             else u $ t)
   591           end
   592 
   593       | extr d defs vs ts Ts hs (prf1 %% prf2) =
   594           let
   595             val (defs', f) = extr d defs vs [] Ts hs prf1;
   596             val prop = Reconstruct.prop_of' hs prf2;
   597             val T = etype_of sg vs Ts prop
   598           in
   599             if T = nullT then (defs', f) else
   600               let val (defs'', t) = extr d defs' vs [] Ts hs prf2
   601               in (defs'', f $ t) end
   602           end
   603 
   604       | extr d defs vs ts Ts hs (prf0 as PThm ((s, _), prf, prop, Some Ts')) =
   605           let
   606             val (vs', tye) = find_inst prop Ts ts vs;
   607             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   608           in
   609             case Symtab.lookup (realizers, s) of
   610               None => (case find vs' (find' s defs) of
   611                 None =>
   612                   let
   613                     val _ = msg d ("Extracting " ^ quote s ^
   614                       (if null vs' then ""
   615                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   616                     val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   617                     val (defs', t) = extr (d + 1) defs vs' [] [] [] prf';
   618                     val (defs'', corr_prf) =
   619                       corr (d + 1) defs' vs' [] [] [] prf' prf' (Some t);
   620 
   621                     val nt = Envir.beta_norm t;
   622                     val args = filter_out (fn v => tname_of (body_type
   623                       (fastype_of v)) mem rtypes) (vfs_of prop);
   624                     val args' = filter (fn v => Logic.occs (v, nt)) args;
   625                     val t' = mkabs (args', nt);
   626                     val T = fastype_of t';
   627                     val cname = extr_name s vs';
   628                     val c = Const (cname, T);
   629                     val u = mkabs (args, list_comb (c, args'));
   630                     val eqn = Logic.mk_equals (c, t');
   631                     val rlz =
   632                       Const ("realizes", fastype_of nt --> propT --> propT);
   633                     val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop);
   634                     val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop);
   635                     val f = app_rlz_rews [] vs'
   636                       (Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop));
   637 
   638                     val corr_prf' =
   639                       chtype [] equal_elim_axm %> lhs %> rhs %%
   640                        (chtype [propT] symmetric_axm %> rhs %> lhs %%
   641                          (chtype [propT, T] combination_axm %> f %> f %> c %> t' %%
   642                            (chtype [T --> propT] reflexive_axm %> f) %%
   643                            PAxm (cname ^ "_def", eqn,
   644                              Some (map TVar (term_tvars eqn))))) %% corr_prf;
   645                     val corr_prop = Reconstruct.prop_of corr_prf';
   646                     val corr_prf'' = foldr forall_intr_prf
   647                       (map (get_var_type corr_prop) (vfs_of prop), proof_combt
   648                         (PThm ((corr_name s vs', []), corr_prf', corr_prop,
   649                           Some (map TVar (term_tvars corr_prop))), vfs_of corr_prop));
   650                   in
   651                     ((s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'',
   652                      subst_TVars tye' u)
   653                   end
   654               | Some ((_, u), _) => (defs, subst_TVars tye' u))
   655             | Some rs => (case find vs' rs of
   656                 Some (t, _) => (defs, subst_TVars tye' t)
   657               | None => error ("extr: no realizer for instance of theorem " ^
   658                   quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   659                     (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   660           end
   661 
   662       | extr d defs vs ts Ts hs (prf0 as PAxm (s, prop, Some Ts')) =
   663           let
   664             val (vs', tye) = find_inst prop Ts ts vs;
   665             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   666           in
   667             case find vs' (Symtab.lookup_multi (realizers, s)) of
   668               Some (t, _) => (defs, subst_TVars tye' t)
   669             | None => error ("extr: no realizer for instance of axiom " ^
   670                 quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   671                   (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   672           end
   673 
   674       | extr d defs vs ts Ts hs _ = error "extr: bad proof";
   675 
   676     fun prep_thm (thm, vs) =
   677       let
   678         val {prop, der = (_, prf), sign, ...} = rep_thm thm;
   679         val name = Thm.name_of_thm thm;
   680         val _ = assert (name <> "") "extraction: unnamed theorem";
   681         val _ = assert (etype_of sg vs [] prop <> nullT) ("theorem " ^
   682           quote name ^ " has no computational content")
   683       in (Reconstruct.reconstruct_proof sign prop prf, vs) end;
   684 
   685     val defs = foldl (fn (defs, (prf, vs)) =>
   686       fst (extr 0 defs vs [] [] [] prf)) ([], map prep_thm thms);
   687     val {path, ...} = Sign.rep_sg sg;
   688 
   689     fun add_def ((s, (vs, ((t, u), (prf, _)))), thy) =
   690       (case Sign.const_type (sign_of thy) (extr_name s vs) of
   691          None =>
   692            let
   693              val corr_prop = Reconstruct.prop_of prf;
   694              val ft = fst (Type.freeze_thaw t);
   695              val fu = fst (Type.freeze_thaw u);
   696              val thy' = if t = nullt then thy else thy |>
   697                Theory.add_consts_i [(extr_name s vs, fastype_of ft, NoSyn)] |>
   698                fst o PureThy.add_defs_i false [((extr_name s vs ^ "_def",
   699                  Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])];
   700            in
   701              fst (PureThy.store_thm ((corr_name s vs,
   702                Thm.varifyT (funpow (length (term_vars corr_prop))
   703                  (forall_elim_var 0) (forall_intr_frees
   704                    (ProofChecker.thm_of_proof thy'
   705                      (fst (Proofterm.freeze_thaw_prf prf)))))), []) thy')
   706            end
   707        | Some _ => thy);
   708 
   709   in thy |>
   710     Theory.absolute_path |>
   711     curry (foldr add_def) defs |>
   712     Theory.add_path (NameSpace.pack (if_none path []))
   713   end;
   714 
   715 
   716 (**** interface ****)
   717 
   718 structure P = OuterParse and K = OuterSyntax.Keyword;
   719 
   720 val parse_vars = Scan.optional (P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") [];
   721 
   722 val realizersP =
   723   OuterSyntax.command "realizers"
   724   "specify realizers for primitive axioms / theorems, together with correctness proof"
   725   K.thy_decl
   726     (Scan.repeat1 (P.xname -- parse_vars --| P.$$$ ":" -- P.string -- P.string) >>
   727      (fn xs => Toplevel.theory (fn thy => add_realizers
   728        (map (fn (((a, vs), s1), s2) =>
   729          (PureThy.get_thm thy a, (vs, s1, s2))) xs) thy)));
   730 
   731 val realizabilityP =
   732   OuterSyntax.command "realizability"
   733   "add equations characterizing realizability" K.thy_decl
   734   (Scan.repeat1 P.string >> (Toplevel.theory o add_realizes_eqns));
   735 
   736 val typeofP =
   737   OuterSyntax.command "extract_type"
   738   "add equations characterizing type of extracted program" K.thy_decl
   739   (Scan.repeat1 P.string >> (Toplevel.theory o add_typeof_eqns));
   740 
   741 val extractP =
   742   OuterSyntax.command "extract" "extract terms from proofs" K.thy_decl
   743     (Scan.repeat1 (P.xname -- parse_vars) >> (fn xs => Toplevel.theory
   744       (fn thy => extract (map (apfst (PureThy.get_thm thy)) xs) thy)));
   745 
   746 val parsers = [realizersP, realizabilityP, typeofP, extractP];
   747 
   748 val setup =
   749   [ExtractionData.init,
   750 
   751    add_types [("prop", ([], None))],
   752 
   753    add_typeof_eqns
   754      ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   755     \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   756     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('Q)))",
   757 
   758       "(typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   759     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE(Null)))",
   760 
   761       "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   762     \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   763     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('P => 'Q)))",
   764 
   765       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   766     \    (typeof (!!x. PROP P (x))) == (Type (TYPE(Null)))",
   767 
   768       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE('P))) ==>  \
   769     \    (typeof (!!x::'a. PROP P (x))) == (Type (TYPE('a => 'P)))",
   770 
   771       "(%x. typeof (f (x))) == (%x. Type (TYPE('f))) ==>  \
   772     \    (typeof (f)) == (Type (TYPE('f)))"],
   773 
   774    add_realizes_eqns
   775      ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   776     \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   777     \    (PROP realizes (Null) (PROP P) ==> PROP realizes (r) (PROP Q))",
   778 
   779       "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   780     \  (typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   781     \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   782     \    (!!x::'P. PROP realizes (x) (PROP P) ==> PROP realizes (Null) (PROP Q))",
   783 
   784       "(realizes (r) (PROP P ==> PROP Q)) ==  \
   785     \  (!!x. PROP realizes (x) (PROP P) ==> PROP realizes (r (x)) (PROP Q))",
   786 
   787       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   788     \    (realizes (r) (!!x. PROP P (x))) ==  \
   789     \    (!!x. PROP realizes (Null) (PROP P (x)))",
   790 
   791       "(realizes (r) (!!x. PROP P (x))) ==  \
   792     \  (!!x. PROP realizes (r (x)) (PROP P (x)))"],
   793 
   794    Attrib.add_attributes
   795      [("extraction_expand",
   796        (Attrib.no_args add_expand_thm, K Attrib.undef_local_attribute),
   797        "specify theorems / definitions to be expanded during extraction")]];
   798 
   799 val etype_of = etype_of o sign_of o add_syntax;
   800 
   801 end;
   802 
   803 OuterSyntax.add_parsers Extraction.parsers;