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