author | wenzelm |
Thu, 29 Oct 2009 17:58:26 +0100 | |
changeset 33317 | b4534348b8fd |
parent 33245 | 65232054ffd0 |
child 33337 | 9c3b9bf81e8b |
permissions | -rw-r--r-- |
13402 | 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 |
|
16458 | 9 |
val set_preprocessor : (theory -> Proofterm.proof -> Proofterm.proof) -> theory -> theory |
13402 | 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_thms : thm list -> theory -> theory |
|
13732 | 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 |
|
13402 | 22 |
val nullT : typ |
23 |
val nullt : term |
|
13714 | 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 |
|
13402 | 27 |
end; |
28 |
||
29 |
structure Extraction : EXTRACTION = |
|
30 |
struct |
|
31 |
||
32 |
open Proofterm; |
|
33 |
||
34 |
(**** tools ****) |
|
35 |
||
36 |
fun add_syntax thy = |
|
37 |
thy |
|
38 |
|> Theory.copy |
|
24712
64ed05609568
proper Sign operations instead of Theory aliases;
wenzelm
parents:
24707
diff
changeset
|
39 |
|> Sign.root_path |
30344
10a67c5ddddb
more uniform handling of binding in targets and derived elements;
wenzelm
parents:
29635
diff
changeset
|
40 |
|> Sign.add_types [(Binding.name "Type", 0, NoSyn), (Binding.name "Null", 0, NoSyn)] |
22796 | 41 |
|> Sign.add_consts |
30344
10a67c5ddddb
more uniform handling of binding in targets and derived elements;
wenzelm
parents:
29635
diff
changeset
|
42 |
[(Binding.name "typeof", "'b::{} => Type", NoSyn), |
10a67c5ddddb
more uniform handling of binding in targets and derived elements;
wenzelm
parents:
29635
diff
changeset
|
43 |
(Binding.name "Type", "'a::{} itself => Type", NoSyn), |
10a67c5ddddb
more uniform handling of binding in targets and derived elements;
wenzelm
parents:
29635
diff
changeset
|
44 |
(Binding.name "Null", "Null", NoSyn), |
10a67c5ddddb
more uniform handling of binding in targets and derived elements;
wenzelm
parents:
29635
diff
changeset
|
45 |
(Binding.name "realizes", "'a::{} => 'b::{} => 'b", NoSyn)]; |
13402 | 46 |
|
47 |
val nullT = Type ("Null", []); |
|
48 |
val nullt = Const ("Null", nullT); |
|
49 |
||
50 |
fun mk_typ T = |
|
19391 | 51 |
Const ("Type", Term.itselfT T --> Type ("Type", [])) $ Logic.mk_type T; |
13402 | 52 |
|
53 |
fun typeof_proc defaultS vs (Const ("typeof", _) $ u) = |
|
15531 | 54 |
SOME (mk_typ (case strip_comb u of |
13402 | 55 |
(Var ((a, i), _), _) => |
20664 | 56 |
if member (op =) vs a then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS) |
13402 | 57 |
else nullT |
58 |
| (Free (a, _), _) => |
|
20664 | 59 |
if member (op =) vs a then TFree ("'" ^ a, defaultS) else nullT |
13402 | 60 |
| _ => nullT)) |
15531 | 61 |
| typeof_proc _ _ _ = NONE; |
13402 | 62 |
|
15531 | 63 |
fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ r $ t) = SOME t |
13732 | 64 |
| rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) = |
65 |
(case strip_comb t of |
|
15531 | 66 |
(Var (ixn, U), ts) => SOME (list_comb (Var (ixn, T --> U), r :: ts)) |
67 |
| (Free (s, U), ts) => SOME (list_comb (Free (s, T --> U), r :: ts)) |
|
68 |
| _ => NONE) |
|
69 |
| rlz_proc _ = NONE; |
|
13402 | 70 |
|
71 |
val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o |
|
28375 | 72 |
take_prefix (fn s => s <> ":") o explode; |
13402 | 73 |
|
74 |
type rules = |
|
75 |
{next: int, rs: ((term * term) list * (term * term)) list, |
|
76 |
net: (int * ((term * term) list * (term * term))) Net.net}; |
|
77 |
||
78 |
val empty_rules : rules = {next = 0, rs = [], net = Net.empty}; |
|
79 |
||
80 |
fun add_rule (r as (_, (lhs, _)), {next, rs, net} : rules) = |
|
16800 | 81 |
{next = next - 1, rs = r :: rs, net = Net.insert_term (K false) |
18956 | 82 |
(Envir.eta_contract lhs, (next, r)) net}; |
13402 | 83 |
|
32784 | 84 |
fun merge_rules ({next, rs = rs1, net} : rules) ({rs = rs2, ...} : rules) = |
23178 | 85 |
List.foldr add_rule {next = next, rs = rs1, net = net} (subtract (op =) rs1 rs2); |
13402 | 86 |
|
16458 | 87 |
fun condrew thy rules procs = |
13402 | 88 |
let |
89 |
fun rew tm = |
|
17203 | 90 |
Pattern.rewrite_term thy [] (condrew' :: procs) tm |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
91 |
and condrew' tm = |
13402 | 92 |
let |
32738 | 93 |
val cache = Unsynchronized.ref ([] : (term * term) list); |
17232 | 94 |
fun lookup f x = (case AList.lookup (op =) (!cache) x of |
15531 | 95 |
NONE => |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
96 |
let val y = f x |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
97 |
in (cache := (x, y) :: !cache; y) end |
15531 | 98 |
| SOME y => y); |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
99 |
in |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
100 |
get_first (fn (_, (prems, (tm1, tm2))) => |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
101 |
let |
19466 | 102 |
fun ren t = the_default t (Term.rename_abs tm1 tm t); |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
103 |
val inc = Logic.incr_indexes ([], maxidx_of_term tm + 1); |
18184 | 104 |
val env as (Tenv, tenv) = Pattern.match thy (inc tm1, tm) (Vartab.empty, Vartab.empty); |
32035 | 105 |
val prems' = map (pairself (Envir.subst_term env o inc o ren)) prems; |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
106 |
val env' = Envir.Envir |
32032 | 107 |
{maxidx = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u) prems' ~1, |
108 |
tenv = tenv, tyenv = Tenv}; |
|
18184 | 109 |
val env'' = fold (Pattern.unify thy o pairself (lookup rew)) prems' env'; |
15531 | 110 |
in SOME (Envir.norm_term env'' (inc (ren tm2))) |
111 |
end handle Pattern.MATCH => NONE | Pattern.Unif => NONE) |
|
16486 | 112 |
(sort (int_ord o pairself fst) |
18956 | 113 |
(Net.match_term rules (Envir.eta_contract tm))) |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
114 |
end; |
13402 | 115 |
|
116 |
in rew end; |
|
117 |
||
15531 | 118 |
val chtype = change_type o SOME; |
13402 | 119 |
|
30364
577edc39b501
moved basic algebra of long names from structure NameSpace to Long_Name;
wenzelm
parents:
30344
diff
changeset
|
120 |
fun extr_name s vs = Long_Name.append "extr" (space_implode "_" (s :: vs)); |
16195 | 121 |
fun corr_name s vs = extr_name s vs ^ "_correctness"; |
13402 | 122 |
|
16195 | 123 |
fun msg d s = priority (Symbol.spaces d ^ s); |
13402 | 124 |
|
28812
413695e07bd4
Frees in PThms are now quantified in the order of their appearance in the
berghofe
parents:
28805
diff
changeset
|
125 |
fun vars_of t = map Var (rev (Term.add_vars t [])); |
413695e07bd4
Frees in PThms are now quantified in the order of their appearance in the
berghofe
parents:
28805
diff
changeset
|
126 |
fun frees_of t = map Free (rev (Term.add_frees t [])); |
413695e07bd4
Frees in PThms are now quantified in the order of their appearance in the
berghofe
parents:
28805
diff
changeset
|
127 |
fun vfs_of t = vars_of t @ frees_of t; |
13402 | 128 |
|
129 |
fun forall_intr_prf (t, prf) = |
|
130 |
let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p) |
|
15531 | 131 |
in Abst (a, SOME T, prf_abstract_over t prf) end; |
13402 | 132 |
|
23178 | 133 |
val mkabs = List.foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t))); |
13402 | 134 |
|
13732 | 135 |
fun strip_abs 0 t = t |
136 |
| strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t |
|
137 |
| strip_abs _ _ = error "strip_abs: not an abstraction"; |
|
138 |
||
13402 | 139 |
fun prf_subst_TVars tye = |
140 |
map_proof_terms (subst_TVars tye) (typ_subst_TVars tye); |
|
141 |
||
23178 | 142 |
fun relevant_vars types prop = List.foldr (fn |
32784 | 143 |
(Var ((a, _), T), vs) => (case strip_type T of |
20664 | 144 |
(_, Type (s, _)) => if member (op =) types s then a :: vs else vs |
13402 | 145 |
| _ => vs) |
15574
b1d1b5bfc464
Removed practically all references to Library.foldr.
skalberg
parents:
15570
diff
changeset
|
146 |
| (_, vs) => vs) [] (vars_of prop); |
13402 | 147 |
|
13732 | 148 |
fun tname_of (Type (s, _)) = s |
149 |
| tname_of _ = ""; |
|
150 |
||
151 |
fun get_var_type t = |
|
152 |
let |
|
16865 | 153 |
val vs = Term.add_vars t []; |
154 |
val fs = Term.add_frees t []; |
|
13732 | 155 |
in fn |
17232 | 156 |
Var (ixn, _) => (case AList.lookup (op =) vs ixn of |
15531 | 157 |
NONE => error "get_var_type: no such variable in term" |
158 |
| SOME T => Var (ixn, T)) |
|
17232 | 159 |
| Free (s, _) => (case AList.lookup (op =) fs s of |
15531 | 160 |
NONE => error "get_var_type: no such variable in term" |
161 |
| SOME T => Free (s, T)) |
|
13732 | 162 |
| _ => error "get_var_type: not a variable" |
163 |
end; |
|
164 |
||
13402 | 165 |
|
166 |
(**** theory data ****) |
|
167 |
||
22846 | 168 |
(* theory data *) |
13402 | 169 |
|
16458 | 170 |
structure ExtractionData = TheoryDataFun |
22846 | 171 |
( |
13402 | 172 |
type T = |
173 |
{realizes_eqns : rules, |
|
174 |
typeof_eqns : rules, |
|
13732 | 175 |
types : (string * ((term -> term option) list * |
176 |
(term -> typ -> term -> typ -> term) option)) list, |
|
13402 | 177 |
realizers : (string list * (term * proof)) list Symtab.table, |
178 |
defs : thm list, |
|
179 |
expand : (string * term) list, |
|
16458 | 180 |
prep : (theory -> proof -> proof) option} |
13402 | 181 |
|
182 |
val empty = |
|
183 |
{realizes_eqns = empty_rules, |
|
184 |
typeof_eqns = empty_rules, |
|
185 |
types = [], |
|
186 |
realizers = Symtab.empty, |
|
187 |
defs = [], |
|
188 |
expand = [], |
|
15531 | 189 |
prep = NONE}; |
13402 | 190 |
val copy = I; |
16458 | 191 |
val extend = I; |
13402 | 192 |
|
16458 | 193 |
fun merge _ |
13402 | 194 |
(({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1, |
195 |
realizers = realizers1, defs = defs1, expand = expand1, prep = prep1}, |
|
196 |
{realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2, |
|
197 |
realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T * T) = |
|
198 |
{realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2, |
|
199 |
typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2, |
|
22717 | 200 |
types = AList.merge (op =) (K true) (types1, types2), |
33038 | 201 |
realizers = Symtab.merge_list (eq_set (op =) o pairself #1) (realizers1, realizers2), |
22662 | 202 |
defs = Library.merge Thm.eq_thm (defs1, defs2), |
203 |
expand = Library.merge (op =) (expand1, expand2), |
|
15531 | 204 |
prep = (case prep1 of NONE => prep2 | _ => prep1)}; |
22846 | 205 |
); |
13402 | 206 |
|
207 |
fun read_condeq thy = |
|
16458 | 208 |
let val thy' = add_syntax thy |
13402 | 209 |
in fn s => |
24707 | 210 |
let val t = Logic.varify (Syntax.read_prop_global thy' s) |
13402 | 211 |
in (map Logic.dest_equals (Logic.strip_imp_prems t), |
212 |
Logic.dest_equals (Logic.strip_imp_concl t)) |
|
213 |
end handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s) |
|
214 |
end; |
|
215 |
||
216 |
(** preprocessor **) |
|
217 |
||
218 |
fun set_preprocessor prep thy = |
|
219 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
220 |
defs, expand, ...} = ExtractionData.get thy |
|
221 |
in |
|
222 |
ExtractionData.put |
|
223 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
15531 | 224 |
realizers = realizers, defs = defs, expand = expand, prep = SOME prep} thy |
13402 | 225 |
end; |
226 |
||
227 |
(** equations characterizing realizability **) |
|
228 |
||
229 |
fun gen_add_realizes_eqns prep_eq eqns thy = |
|
230 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
231 |
defs, expand, prep} = ExtractionData.get thy; |
|
232 |
in |
|
233 |
ExtractionData.put |
|
23178 | 234 |
{realizes_eqns = List.foldr add_rule realizes_eqns (map (prep_eq thy) eqns), |
13402 | 235 |
typeof_eqns = typeof_eqns, types = types, realizers = realizers, |
236 |
defs = defs, expand = expand, prep = prep} thy |
|
237 |
end |
|
238 |
||
239 |
val add_realizes_eqns_i = gen_add_realizes_eqns (K I); |
|
240 |
val add_realizes_eqns = gen_add_realizes_eqns read_condeq; |
|
241 |
||
242 |
(** equations characterizing type of extracted program **) |
|
243 |
||
244 |
fun gen_add_typeof_eqns prep_eq eqns thy = |
|
245 |
let |
|
246 |
val {realizes_eqns, typeof_eqns, types, realizers, |
|
247 |
defs, expand, prep} = ExtractionData.get thy; |
|
13732 | 248 |
val eqns' = map (prep_eq thy) eqns |
13402 | 249 |
in |
250 |
ExtractionData.put |
|
251 |
{realizes_eqns = realizes_eqns, realizers = realizers, |
|
23178 | 252 |
typeof_eqns = List.foldr add_rule typeof_eqns eqns', |
13732 | 253 |
types = types, defs = defs, expand = expand, prep = prep} thy |
13402 | 254 |
end |
255 |
||
256 |
val add_typeof_eqns_i = gen_add_typeof_eqns (K I); |
|
257 |
val add_typeof_eqns = gen_add_typeof_eqns read_condeq; |
|
258 |
||
259 |
fun thaw (T as TFree (a, S)) = |
|
28375 | 260 |
if exists_string (fn s => s = ":") a then TVar (unpack_ixn a, S) else T |
13402 | 261 |
| thaw (Type (a, Ts)) = Type (a, map thaw Ts) |
262 |
| thaw T = T; |
|
263 |
||
264 |
fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S) |
|
265 |
| freeze (Type (a, Ts)) = Type (a, map freeze Ts) |
|
266 |
| freeze T = T; |
|
267 |
||
268 |
fun freeze_thaw f x = |
|
20548
8ef25fe585a8
renamed Term.map_term_types to Term.map_types (cf. Term.fold_types);
wenzelm
parents:
19482
diff
changeset
|
269 |
map_types thaw (f (map_types freeze x)); |
13402 | 270 |
|
16458 | 271 |
fun etype_of thy vs Ts t = |
13402 | 272 |
let |
16458 | 273 |
val {typeof_eqns, ...} = ExtractionData.get thy; |
13402 | 274 |
fun err () = error ("Unable to determine type of extracted program for\n" ^ |
26939
1035c89b4c02
moved global pretty/string_of functions from Sign to Syntax;
wenzelm
parents:
26653
diff
changeset
|
275 |
Syntax.string_of_term_global thy t) |
16458 | 276 |
in case strip_abs_body (freeze_thaw (condrew thy (#net typeof_eqns) |
277 |
[typeof_proc (Sign.defaultS thy) vs]) (list_abs (map (pair "x") (rev Ts), |
|
13402 | 278 |
Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of |
279 |
Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ()) |
|
280 |
| _ => err () |
|
281 |
end; |
|
282 |
||
283 |
(** realizers for axioms / theorems, together with correctness proofs **) |
|
284 |
||
285 |
fun gen_add_realizers prep_rlz rs thy = |
|
286 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
287 |
defs, expand, prep} = ExtractionData.get thy |
|
288 |
in |
|
289 |
ExtractionData.put |
|
290 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
25389 | 291 |
realizers = fold (Symtab.cons_list o prep_rlz thy) rs realizers, |
13402 | 292 |
defs = defs, expand = expand, prep = prep} thy |
293 |
end |
|
294 |
||
295 |
fun prep_realizer thy = |
|
296 |
let |
|
13732 | 297 |
val {realizes_eqns, typeof_eqns, defs, types, ...} = |
13402 | 298 |
ExtractionData.get thy; |
19482
9f11af8f7ef9
tuned basic list operators (flat, maps, map_filter);
wenzelm
parents:
19466
diff
changeset
|
299 |
val procs = maps (fst o snd) types; |
13732 | 300 |
val rtypes = map fst types; |
16800 | 301 |
val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
13402 | 302 |
val thy' = add_syntax thy; |
303 |
val rd = ProofSyntax.read_proof thy' false |
|
304 |
in fn (thm, (vs, s1, s2)) => |
|
305 |
let |
|
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
20897
diff
changeset
|
306 |
val name = Thm.get_name thm; |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
307 |
val _ = name <> "" orelse error "add_realizers: unnamed theorem"; |
17203 | 308 |
val prop = Pattern.rewrite_term thy' |
13402 | 309 |
(map (Logic.dest_equals o prop_of) defs) [] (prop_of thm); |
310 |
val vars = vars_of prop; |
|
13732 | 311 |
val vars' = filter_out (fn v => |
20664 | 312 |
member (op =) rtypes (tname_of (body_type (fastype_of v)))) vars; |
16458 | 313 |
val T = etype_of thy' vs [] prop; |
13402 | 314 |
val (T', thw) = Type.freeze_thaw_type |
13732 | 315 |
(if T = nullT then nullT else map fastype_of vars' ---> T); |
27251 | 316 |
val t = map_types thw (OldGoals.simple_read_term thy' T' s1); |
16458 | 317 |
val r' = freeze_thaw (condrew thy' eqns |
318 |
(procs @ [typeof_proc (Sign.defaultS thy') vs, rlz_proc])) |
|
13402 | 319 |
(Const ("realizes", T --> propT --> propT) $ |
13732 | 320 |
(if T = nullT then t else list_comb (t, vars')) $ prop); |
27330 | 321 |
val r = fold_rev Logic.all (map (get_var_type r') vars) r'; |
16458 | 322 |
val prf = Reconstruct.reconstruct_proof thy' r (rd s2); |
13402 | 323 |
in (name, (vs, (t, prf))) end |
324 |
end; |
|
325 |
||
326 |
val add_realizers_i = gen_add_realizers |
|
327 |
(fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf)))); |
|
328 |
val add_realizers = gen_add_realizers prep_realizer; |
|
329 |
||
13714 | 330 |
fun realizes_of thy vs t prop = |
331 |
let |
|
332 |
val thy' = add_syntax thy; |
|
13732 | 333 |
val {realizes_eqns, typeof_eqns, defs, types, ...} = |
13714 | 334 |
ExtractionData.get thy'; |
22717 | 335 |
val procs = maps (rev o fst o snd) types; |
16800 | 336 |
val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
17203 | 337 |
val prop' = Pattern.rewrite_term thy' |
13714 | 338 |
(map (Logic.dest_equals o prop_of) defs) [] prop; |
16458 | 339 |
in freeze_thaw (condrew thy' eqns |
340 |
(procs @ [typeof_proc (Sign.defaultS thy') vs, rlz_proc])) |
|
13714 | 341 |
(Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop') |
342 |
end; |
|
343 |
||
13402 | 344 |
(** expanding theorems / definitions **) |
345 |
||
18728 | 346 |
fun add_expand_thm thm thy = |
13402 | 347 |
let |
348 |
val {realizes_eqns, typeof_eqns, types, realizers, |
|
349 |
defs, expand, prep} = ExtractionData.get thy; |
|
350 |
||
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
20897
diff
changeset
|
351 |
val name = Thm.get_name thm; |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
352 |
val _ = name <> "" orelse error "add_expand_thms: unnamed theorem"; |
13402 | 353 |
|
354 |
val is_def = |
|
355 |
(case strip_comb (fst (Logic.dest_equals (prop_of thm))) of |
|
18928
042608ffa2ec
subsituted gen_duplicates / has_duplicates for duplicates whenever appropriate
haftmann
parents:
18921
diff
changeset
|
356 |
(Const _, ts) => forall is_Var ts andalso not (has_duplicates (op =) ts) |
28674 | 357 |
andalso (Thm.get_kind thm = Thm.definitionK orelse can (Thm.axiom thy) name) |
13402 | 358 |
| _ => false) handle TERM _ => false; |
359 |
in |
|
360 |
(ExtractionData.put (if is_def then |
|
361 |
{realizes_eqns = realizes_eqns, |
|
362 |
typeof_eqns = add_rule (([], |
|
363 |
Logic.dest_equals (prop_of (Drule.abs_def thm))), typeof_eqns), |
|
364 |
types = types, |
|
22360
26ead7ed4f4b
moved eq_thm etc. to structure Thm in Pure/more_thm.ML;
wenzelm
parents:
21858
diff
changeset
|
365 |
realizers = realizers, defs = insert Thm.eq_thm thm defs, |
13402 | 366 |
expand = expand, prep = prep} |
367 |
else |
|
368 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
369 |
realizers = realizers, defs = defs, |
|
20854 | 370 |
expand = insert (op =) (name, prop_of thm) expand, prep = prep}) thy) |
13402 | 371 |
end; |
372 |
||
18728 | 373 |
val add_expand_thms = fold add_expand_thm; |
374 |
||
30528 | 375 |
val extraction_expand = Thm.declaration_attribute (fn th => Context.mapping (add_expand_thm th) I); |
13402 | 376 |
|
15801 | 377 |
|
13732 | 378 |
(** types with computational content **) |
379 |
||
380 |
fun add_types tys thy = |
|
22717 | 381 |
ExtractionData.map |
382 |
(fn {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} => |
|
13732 | 383 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, |
22717 | 384 |
types = fold (AList.update (op =) o apfst (Sign.intern_type thy)) tys types, |
385 |
realizers = realizers, defs = defs, expand = expand, prep = prep}) |
|
386 |
thy; |
|
13732 | 387 |
|
13402 | 388 |
|
15801 | 389 |
(** Pure setup **) |
390 |
||
26463 | 391 |
val _ = Context.>> (Context.map_theory |
18708 | 392 |
(add_types [("prop", ([], NONE))] #> |
15801 | 393 |
|
394 |
add_typeof_eqns |
|
395 |
["(typeof (PROP P)) == (Type (TYPE(Null))) ==> \ |
|
396 |
\ (typeof (PROP Q)) == (Type (TYPE('Q))) ==> \ |
|
397 |
\ (typeof (PROP P ==> PROP Q)) == (Type (TYPE('Q)))", |
|
398 |
||
399 |
"(typeof (PROP Q)) == (Type (TYPE(Null))) ==> \ |
|
400 |
\ (typeof (PROP P ==> PROP Q)) == (Type (TYPE(Null)))", |
|
401 |
||
402 |
"(typeof (PROP P)) == (Type (TYPE('P))) ==> \ |
|
403 |
\ (typeof (PROP Q)) == (Type (TYPE('Q))) ==> \ |
|
404 |
\ (typeof (PROP P ==> PROP Q)) == (Type (TYPE('P => 'Q)))", |
|
405 |
||
406 |
"(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==> \ |
|
407 |
\ (typeof (!!x. PROP P (x))) == (Type (TYPE(Null)))", |
|
408 |
||
409 |
"(%x. typeof (PROP P (x))) == (%x. Type (TYPE('P))) ==> \ |
|
410 |
\ (typeof (!!x::'a. PROP P (x))) == (Type (TYPE('a => 'P)))", |
|
411 |
||
412 |
"(%x. typeof (f (x))) == (%x. Type (TYPE('f))) ==> \ |
|
18708 | 413 |
\ (typeof (f)) == (Type (TYPE('f)))"] #> |
15801 | 414 |
|
415 |
add_realizes_eqns |
|
416 |
["(typeof (PROP P)) == (Type (TYPE(Null))) ==> \ |
|
417 |
\ (realizes (r) (PROP P ==> PROP Q)) == \ |
|
418 |
\ (PROP realizes (Null) (PROP P) ==> PROP realizes (r) (PROP Q))", |
|
419 |
||
420 |
"(typeof (PROP P)) == (Type (TYPE('P))) ==> \ |
|
421 |
\ (typeof (PROP Q)) == (Type (TYPE(Null))) ==> \ |
|
422 |
\ (realizes (r) (PROP P ==> PROP Q)) == \ |
|
423 |
\ (!!x::'P. PROP realizes (x) (PROP P) ==> PROP realizes (Null) (PROP Q))", |
|
424 |
||
425 |
"(realizes (r) (PROP P ==> PROP Q)) == \ |
|
426 |
\ (!!x. PROP realizes (x) (PROP P) ==> PROP realizes (r (x)) (PROP Q))", |
|
427 |
||
428 |
"(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==> \ |
|
429 |
\ (realizes (r) (!!x. PROP P (x))) == \ |
|
430 |
\ (!!x. PROP realizes (Null) (PROP P (x)))", |
|
431 |
||
432 |
"(realizes (r) (!!x. PROP P (x))) == \ |
|
18708 | 433 |
\ (!!x. PROP realizes (r (x)) (PROP P (x)))"] #> |
15801 | 434 |
|
30528 | 435 |
Attrib.setup (Binding.name "extraction_expand") (Scan.succeed extraction_expand) |
436 |
"specify theorems / definitions to be expanded during extraction")); |
|
15801 | 437 |
|
438 |
||
13402 | 439 |
(**** extract program ****) |
440 |
||
441 |
val dummyt = Const ("dummy", dummyT); |
|
442 |
||
443 |
fun extract thms thy = |
|
444 |
let |
|
16458 | 445 |
val thy' = add_syntax thy; |
13402 | 446 |
val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = |
447 |
ExtractionData.get thy; |
|
22717 | 448 |
val procs = maps (rev o fst o snd) types; |
13732 | 449 |
val rtypes = map fst types; |
16458 | 450 |
val typroc = typeof_proc (Sign.defaultS thy'); |
19466 | 451 |
val prep = the_default (K I) prep thy' o ProofRewriteRules.elim_defs thy' false defs o |
16458 | 452 |
Reconstruct.expand_proof thy' (("", NONE) :: map (apsnd SOME) expand); |
16800 | 453 |
val rrews = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
13402 | 454 |
|
455 |
fun find_inst prop Ts ts vs = |
|
456 |
let |
|
13732 | 457 |
val rvs = relevant_vars rtypes prop; |
13402 | 458 |
val vars = vars_of prop; |
459 |
val n = Int.min (length vars, length ts); |
|
460 |
||
461 |
fun add_args ((Var ((a, i), _), t), (vs', tye)) = |
|
20664 | 462 |
if member (op =) rvs a then |
16458 | 463 |
let val T = etype_of thy' vs Ts t |
13402 | 464 |
in if T = nullT then (vs', tye) |
465 |
else (a :: vs', (("'" ^ a, i), T) :: tye) |
|
466 |
end |
|
467 |
else (vs', tye) |
|
468 |
||
23178 | 469 |
in List.foldr add_args ([], []) (Library.take (n, vars) ~~ Library.take (n, ts)) end; |
13402 | 470 |
|
33038 | 471 |
fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst); |
28375 | 472 |
fun find' (s: string) = map_filter (fn (s', x) => if s = s' then SOME x else NONE); |
13402 | 473 |
|
13732 | 474 |
fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw |
16458 | 475 |
(condrew thy' rrews (procs @ [typroc vs, rlz_proc])) (list_abs |
13732 | 476 |
(map (pair "x") (rev Ts), t))); |
477 |
||
478 |
fun realizes_null vs prop = app_rlz_rews [] vs |
|
479 |
(Const ("realizes", nullT --> propT --> propT) $ nullt $ prop); |
|
13402 | 480 |
|
481 |
fun corr d defs vs ts Ts hs (PBound i) _ _ = (defs, PBound i) |
|
482 |
||
15531 | 483 |
| corr d defs vs ts Ts hs (Abst (s, SOME T, prf)) (Abst (_, _, prf')) t = |
13402 | 484 |
let val (defs', corr_prf) = corr d defs vs [] (T :: Ts) |
485 |
(dummyt :: hs) prf (incr_pboundvars 1 0 prf') |
|
15531 | 486 |
(case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE) |
487 |
in (defs', Abst (s, SOME T, corr_prf)) end |
|
13402 | 488 |
|
15531 | 489 |
| corr d defs vs ts Ts hs (AbsP (s, SOME prop, prf)) (AbsP (_, _, prf')) t = |
13402 | 490 |
let |
16458 | 491 |
val T = etype_of thy' vs Ts prop; |
13402 | 492 |
val u = if T = nullT then |
15531 | 493 |
(case t of SOME u => SOME (incr_boundvars 1 u) | NONE => NONE) |
494 |
else (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE); |
|
13402 | 495 |
val (defs', corr_prf) = corr d defs vs [] (T :: Ts) (prop :: hs) |
496 |
(incr_pboundvars 0 1 prf) (incr_pboundvars 0 1 prf') u; |
|
497 |
val rlz = Const ("realizes", T --> propT --> propT) |
|
498 |
in (defs', |
|
13732 | 499 |
if T = nullT then AbsP ("R", |
15531 | 500 |
SOME (app_rlz_rews Ts vs (rlz $ nullt $ prop)), |
13732 | 501 |
prf_subst_bounds [nullt] corr_prf) |
15531 | 502 |
else Abst (s, SOME T, AbsP ("R", |
503 |
SOME (app_rlz_rews (T :: Ts) vs |
|
13732 | 504 |
(rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf))) |
13402 | 505 |
end |
506 |
||
15531 | 507 |
| corr d defs vs ts Ts hs (prf % SOME t) (prf' % _) t' = |
13732 | 508 |
let |
509 |
val (Us, T) = strip_type (fastype_of1 (Ts, t)); |
|
510 |
val (defs', corr_prf) = corr d defs vs (t :: ts) Ts hs prf prf' |
|
20664 | 511 |
(if member (op =) rtypes (tname_of T) then t' |
15531 | 512 |
else (case t' of SOME (u $ _) => SOME u | _ => NONE)); |
20664 | 513 |
val u = if not (member (op =) rtypes (tname_of T)) then t else |
13732 | 514 |
let |
16458 | 515 |
val eT = etype_of thy' vs Ts t; |
13732 | 516 |
val (r, Us') = if eT = nullT then (nullt, Us) else |
517 |
(Bound (length Us), eT :: Us); |
|
518 |
val u = list_comb (incr_boundvars (length Us') t, |
|
519 |
map Bound (length Us - 1 downto 0)); |
|
17271 | 520 |
val u' = (case AList.lookup (op =) types (tname_of T) of |
15531 | 521 |
SOME ((_, SOME f)) => f r eT u T |
13732 | 522 |
| _ => Const ("realizes", eT --> T --> T) $ r $ u) |
523 |
in app_rlz_rews Ts vs (list_abs (map (pair "x") Us', u')) end |
|
15531 | 524 |
in (defs', corr_prf % SOME u) end |
13402 | 525 |
|
526 |
| corr d defs vs ts Ts hs (prf1 %% prf2) (prf1' %% prf2') t = |
|
527 |
let |
|
528 |
val prop = Reconstruct.prop_of' hs prf2'; |
|
16458 | 529 |
val T = etype_of thy' vs Ts prop; |
15531 | 530 |
val (defs1, f, u) = if T = nullT then (defs, t, NONE) else |
13402 | 531 |
(case t of |
15531 | 532 |
SOME (f $ u) => (defs, SOME f, SOME u) |
13402 | 533 |
| _ => |
534 |
let val (defs1, u) = extr d defs vs [] Ts hs prf2' |
|
15531 | 535 |
in (defs1, NONE, SOME u) end) |
13402 | 536 |
val (defs2, corr_prf1) = corr d defs1 vs [] Ts hs prf1 prf1' f; |
537 |
val (defs3, corr_prf2) = corr d defs2 vs [] Ts hs prf2 prf2' u; |
|
538 |
in |
|
539 |
if T = nullT then (defs3, corr_prf1 %% corr_prf2) else |
|
540 |
(defs3, corr_prf1 % u %% corr_prf2) |
|
541 |
end |
|
542 |
||
28805 | 543 |
| corr d defs vs ts Ts hs (prf0 as PThm (_, ((name, prop, SOME Ts'), body))) _ _ = |
13402 | 544 |
let |
29635
31d14e9fa0da
proof_body: turned lazy into future -- ensures that body is fulfilled eventually, without explicit force;
wenzelm
parents:
29579
diff
changeset
|
545 |
val prf = join_proof body; |
13402 | 546 |
val (vs', tye) = find_inst prop Ts ts vs; |
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
547 |
val tye' = (map fst (OldTerm.term_tvars prop) ~~ Ts') @ tye; |
16458 | 548 |
val T = etype_of thy' vs' [] prop; |
13402 | 549 |
val defs' = if T = nullT then defs |
550 |
else fst (extr d defs vs ts Ts hs prf0) |
|
551 |
in |
|
13609
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
552 |
if T = nullT andalso realizes_null vs' prop aconv prop then (defs, prf0) |
17412 | 553 |
else case Symtab.lookup realizers name of |
15531 | 554 |
NONE => (case find vs' (find' name defs') of |
555 |
NONE => |
|
13402 | 556 |
let |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
557 |
val _ = T = nullT orelse error "corr: internal error"; |
13402 | 558 |
val _ = msg d ("Building correctness proof for " ^ quote name ^ |
559 |
(if null vs' then "" |
|
560 |
else " (relevant variables: " ^ commas_quote vs' ^ ")")); |
|
16458 | 561 |
val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf); |
13402 | 562 |
val (defs'', corr_prf) = |
15531 | 563 |
corr (d + 1) defs' vs' [] [] [] prf' prf' NONE; |
13732 | 564 |
val corr_prop = Reconstruct.prop_of corr_prf; |
23178 | 565 |
val corr_prf' = List.foldr forall_intr_prf |
15574
b1d1b5bfc464
Removed practically all references to Library.foldr.
skalberg
parents:
15570
diff
changeset
|
566 |
(proof_combt |
28805 | 567 |
(PThm (serial (), |
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
568 |
((corr_name name vs', corr_prop, SOME (map TVar (OldTerm.term_tvars corr_prop))), |
30718 | 569 |
Future.value (approximate_proof_body corr_prf))), vfs_of corr_prop)) |
22750 | 570 |
(map (get_var_type corr_prop) (vfs_of prop)) |
13402 | 571 |
in |
13732 | 572 |
((name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'', |
13402 | 573 |
prf_subst_TVars tye' corr_prf') |
574 |
end |
|
15531 | 575 |
| SOME (_, (_, prf')) => (defs', prf_subst_TVars tye' prf')) |
576 |
| SOME rs => (case find vs' rs of |
|
577 |
SOME (_, prf') => (defs', prf_subst_TVars tye' prf') |
|
578 |
| NONE => error ("corr: no realizer for instance of theorem " ^ |
|
26939
1035c89b4c02
moved global pretty/string_of functions from Sign to Syntax;
wenzelm
parents:
26653
diff
changeset
|
579 |
quote name ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
13402 | 580 |
(Reconstruct.prop_of (proof_combt (prf0, ts)))))) |
581 |
end |
|
582 |
||
15531 | 583 |
| corr d defs vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) _ _ = |
13402 | 584 |
let |
585 |
val (vs', tye) = find_inst prop Ts ts vs; |
|
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
586 |
val tye' = (map fst (OldTerm.term_tvars prop) ~~ Ts') @ tye |
13402 | 587 |
in |
16458 | 588 |
if etype_of thy' vs' [] prop = nullT andalso |
13609
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
589 |
realizes_null vs' prop aconv prop then (defs, prf0) |
18956 | 590 |
else case find vs' (Symtab.lookup_list realizers s) of |
15531 | 591 |
SOME (_, prf) => (defs, prf_subst_TVars tye' prf) |
592 |
| NONE => error ("corr: no realizer for instance of axiom " ^ |
|
26939
1035c89b4c02
moved global pretty/string_of functions from Sign to Syntax;
wenzelm
parents:
26653
diff
changeset
|
593 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
13402 | 594 |
(Reconstruct.prop_of (proof_combt (prf0, ts))))) |
595 |
end |
|
596 |
||
597 |
| corr d defs vs ts Ts hs _ _ _ = error "corr: bad proof" |
|
598 |
||
599 |
and extr d defs vs ts Ts hs (PBound i) = (defs, Bound i) |
|
600 |
||
15531 | 601 |
| extr d defs vs ts Ts hs (Abst (s, SOME T, prf)) = |
13402 | 602 |
let val (defs', t) = extr d defs vs [] |
603 |
(T :: Ts) (dummyt :: hs) (incr_pboundvars 1 0 prf) |
|
604 |
in (defs', Abs (s, T, t)) end |
|
605 |
||
15531 | 606 |
| extr d defs vs ts Ts hs (AbsP (s, SOME t, prf)) = |
13402 | 607 |
let |
16458 | 608 |
val T = etype_of thy' vs Ts t; |
13402 | 609 |
val (defs', t) = extr d defs vs [] (T :: Ts) (t :: hs) |
610 |
(incr_pboundvars 0 1 prf) |
|
611 |
in (defs', |
|
612 |
if T = nullT then subst_bound (nullt, t) else Abs (s, T, t)) |
|
613 |
end |
|
614 |
||
15531 | 615 |
| extr d defs vs ts Ts hs (prf % SOME t) = |
13402 | 616 |
let val (defs', u) = extr d defs vs (t :: ts) Ts hs prf |
13732 | 617 |
in (defs', |
20664 | 618 |
if member (op =) rtypes (tname_of (body_type (fastype_of1 (Ts, t)))) then u |
13732 | 619 |
else u $ t) |
620 |
end |
|
13402 | 621 |
|
622 |
| extr d defs vs ts Ts hs (prf1 %% prf2) = |
|
623 |
let |
|
624 |
val (defs', f) = extr d defs vs [] Ts hs prf1; |
|
625 |
val prop = Reconstruct.prop_of' hs prf2; |
|
16458 | 626 |
val T = etype_of thy' vs Ts prop |
13402 | 627 |
in |
628 |
if T = nullT then (defs', f) else |
|
629 |
let val (defs'', t) = extr d defs' vs [] Ts hs prf2 |
|
630 |
in (defs'', f $ t) end |
|
631 |
end |
|
632 |
||
28805 | 633 |
| extr d defs vs ts Ts hs (prf0 as PThm (_, ((s, prop, SOME Ts'), body))) = |
13402 | 634 |
let |
29635
31d14e9fa0da
proof_body: turned lazy into future -- ensures that body is fulfilled eventually, without explicit force;
wenzelm
parents:
29579
diff
changeset
|
635 |
val prf = join_proof body; |
13402 | 636 |
val (vs', tye) = find_inst prop Ts ts vs; |
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
637 |
val tye' = (map fst (OldTerm.term_tvars prop) ~~ Ts') @ tye |
13402 | 638 |
in |
17412 | 639 |
case Symtab.lookup realizers s of |
15531 | 640 |
NONE => (case find vs' (find' s defs) of |
641 |
NONE => |
|
13402 | 642 |
let |
643 |
val _ = msg d ("Extracting " ^ quote s ^ |
|
644 |
(if null vs' then "" |
|
645 |
else " (relevant variables: " ^ commas_quote vs' ^ ")")); |
|
16458 | 646 |
val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf); |
13402 | 647 |
val (defs', t) = extr (d + 1) defs vs' [] [] [] prf'; |
648 |
val (defs'', corr_prf) = |
|
15531 | 649 |
corr (d + 1) defs' vs' [] [] [] prf' prf' (SOME t); |
13402 | 650 |
|
651 |
val nt = Envir.beta_norm t; |
|
20664 | 652 |
val args = filter_out (fn v => member (op =) rtypes |
653 |
(tname_of (body_type (fastype_of v)))) (vfs_of prop); |
|
33317 | 654 |
val args' = filter (fn v => Logic.occs (v, nt)) args; |
15574
b1d1b5bfc464
Removed practically all references to Library.foldr.
skalberg
parents:
15570
diff
changeset
|
655 |
val t' = mkabs nt args'; |
13402 | 656 |
val T = fastype_of t'; |
13732 | 657 |
val cname = extr_name s vs'; |
13402 | 658 |
val c = Const (cname, T); |
15574
b1d1b5bfc464
Removed practically all references to Library.foldr.
skalberg
parents:
15570
diff
changeset
|
659 |
val u = mkabs (list_comb (c, args')) args; |
13402 | 660 |
val eqn = Logic.mk_equals (c, t'); |
661 |
val rlz = |
|
662 |
Const ("realizes", fastype_of nt --> propT --> propT); |
|
13732 | 663 |
val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop); |
664 |
val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop); |
|
665 |
val f = app_rlz_rews [] vs' |
|
666 |
(Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop)); |
|
13402 | 667 |
|
13732 | 668 |
val corr_prf' = |
669 |
chtype [] equal_elim_axm %> lhs %> rhs %% |
|
670 |
(chtype [propT] symmetric_axm %> rhs %> lhs %% |
|
671 |
(chtype [propT, T] combination_axm %> f %> f %> c %> t' %% |
|
672 |
(chtype [T --> propT] reflexive_axm %> f) %% |
|
673 |
PAxm (cname ^ "_def", eqn, |
|
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
674 |
SOME (map TVar (OldTerm.term_tvars eqn))))) %% corr_prf; |
13732 | 675 |
val corr_prop = Reconstruct.prop_of corr_prf'; |
23178 | 676 |
val corr_prf'' = List.foldr forall_intr_prf |
15574
b1d1b5bfc464
Removed practically all references to Library.foldr.
skalberg
parents:
15570
diff
changeset
|
677 |
(proof_combt |
28805 | 678 |
(PThm (serial (), |
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
679 |
((corr_name s vs', corr_prop, SOME (map TVar (OldTerm.term_tvars corr_prop))), |
30718 | 680 |
Future.value (approximate_proof_body corr_prf'))), vfs_of corr_prop)) |
22750 | 681 |
(map (get_var_type corr_prop) (vfs_of prop)); |
13402 | 682 |
in |
13732 | 683 |
((s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'', |
13402 | 684 |
subst_TVars tye' u) |
685 |
end |
|
15531 | 686 |
| SOME ((_, u), _) => (defs, subst_TVars tye' u)) |
687 |
| SOME rs => (case find vs' rs of |
|
688 |
SOME (t, _) => (defs, subst_TVars tye' t) |
|
689 |
| NONE => error ("extr: no realizer for instance of theorem " ^ |
|
26939
1035c89b4c02
moved global pretty/string_of functions from Sign to Syntax;
wenzelm
parents:
26653
diff
changeset
|
690 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
13402 | 691 |
(Reconstruct.prop_of (proof_combt (prf0, ts)))))) |
692 |
end |
|
693 |
||
15531 | 694 |
| extr d defs vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) = |
13402 | 695 |
let |
696 |
val (vs', tye) = find_inst prop Ts ts vs; |
|
29270
0eade173f77e
moved old add_type_XXX, add_term_XXX etc. to structure OldTerm;
wenzelm
parents:
29265
diff
changeset
|
697 |
val tye' = (map fst (OldTerm.term_tvars prop) ~~ Ts') @ tye |
13402 | 698 |
in |
18956 | 699 |
case find vs' (Symtab.lookup_list realizers s) of |
15531 | 700 |
SOME (t, _) => (defs, subst_TVars tye' t) |
701 |
| NONE => error ("extr: no realizer for instance of axiom " ^ |
|
26939
1035c89b4c02
moved global pretty/string_of functions from Sign to Syntax;
wenzelm
parents:
26653
diff
changeset
|
702 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
13402 | 703 |
(Reconstruct.prop_of (proof_combt (prf0, ts))))) |
704 |
end |
|
705 |
||
706 |
| extr d defs vs ts Ts hs _ = error "extr: bad proof"; |
|
707 |
||
13732 | 708 |
fun prep_thm (thm, vs) = |
13402 | 709 |
let |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
26481
diff
changeset
|
710 |
val thy = Thm.theory_of_thm thm; |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
26481
diff
changeset
|
711 |
val prop = Thm.prop_of thm; |
28814 | 712 |
val prf = Thm.proof_of thm; |
21646
c07b5b0e8492
thm/prf: separate official name vs. additional tags;
wenzelm
parents:
20897
diff
changeset
|
713 |
val name = Thm.get_name thm; |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
714 |
val _ = name <> "" orelse error "extraction: unnamed theorem"; |
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
715 |
val _ = etype_of thy' vs [] prop <> nullT orelse error ("theorem " ^ |
13402 | 716 |
quote name ^ " has no computational content") |
22596 | 717 |
in (Reconstruct.reconstruct_proof thy prop prf, vs) end; |
13402 | 718 |
|
33245 | 719 |
val defs = |
720 |
fold (fn (prf, vs) => fn defs => fst (extr 0 defs vs [] [] [] prf)) |
|
721 |
(map prep_thm thms) []; |
|
13402 | 722 |
|
16149 | 723 |
fun add_def (s, (vs, ((t, u), (prf, _)))) thy = |
16458 | 724 |
(case Sign.const_type thy (extr_name s vs) of |
15531 | 725 |
NONE => |
13732 | 726 |
let |
727 |
val corr_prop = Reconstruct.prop_of prf; |
|
16287 | 728 |
val ft = Type.freeze t; |
729 |
val fu = Type.freeze u; |
|
22750 | 730 |
val (def_thms, thy') = if t = nullt then ([], thy) else |
731 |
thy |
|
30435
e62d6ecab6ad
explicit Binding.qualified_name -- prevents implicitly qualified bstring;
wenzelm
parents:
30364
diff
changeset
|
732 |
|> Sign.add_consts_i [(Binding.qualified_name (extr_name s vs), fastype_of ft, NoSyn)] |
e62d6ecab6ad
explicit Binding.qualified_name -- prevents implicitly qualified bstring;
wenzelm
parents:
30364
diff
changeset
|
733 |
|> PureThy.add_defs false [((Binding.qualified_name (extr_name s vs ^ "_def"), |
22750 | 734 |
Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])] |
13732 | 735 |
in |
22750 | 736 |
thy' |
30435
e62d6ecab6ad
explicit Binding.qualified_name -- prevents implicitly qualified bstring;
wenzelm
parents:
30364
diff
changeset
|
737 |
|> PureThy.store_thm (Binding.qualified_name (corr_name s vs), |
29265
5b4247055bd7
moved old add_term_vars, add_term_frees etc. to structure OldTerm;
wenzelm
parents:
28814
diff
changeset
|
738 |
Thm.varifyT (funpow (length (OldTerm.term_vars corr_prop)) |
26653 | 739 |
(Thm.forall_elim_var 0) (forall_intr_frees |
22750 | 740 |
(ProofChecker.thm_of_proof thy' |
26481 | 741 |
(fst (Proofterm.freeze_thaw_prf prf)))))) |
22750 | 742 |
|> snd |
28370 | 743 |
|> fold Code.add_default_eqn def_thms |
13732 | 744 |
end |
15531 | 745 |
| SOME _ => thy); |
13402 | 746 |
|
16149 | 747 |
in |
748 |
thy |
|
30435
e62d6ecab6ad
explicit Binding.qualified_name -- prevents implicitly qualified bstring;
wenzelm
parents:
30364
diff
changeset
|
749 |
|> Sign.root_path |
16149 | 750 |
|> fold_rev add_def defs |
22796 | 751 |
|> Sign.restore_naming thy |
13402 | 752 |
end; |
753 |
||
754 |
||
755 |
(**** interface ****) |
|
756 |
||
17057 | 757 |
structure P = OuterParse and K = OuterKeyword; |
13402 | 758 |
|
13732 | 759 |
val parse_vars = Scan.optional (P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") []; |
760 |
||
24867 | 761 |
val _ = |
13402 | 762 |
OuterSyntax.command "realizers" |
763 |
"specify realizers for primitive axioms / theorems, together with correctness proof" |
|
764 |
K.thy_decl |
|
13732 | 765 |
(Scan.repeat1 (P.xname -- parse_vars --| P.$$$ ":" -- P.string -- P.string) >> |
13402 | 766 |
(fn xs => Toplevel.theory (fn thy => add_realizers |
26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26336
diff
changeset
|
767 |
(map (fn (((a, vs), s1), s2) => (PureThy.get_thm thy a, (vs, s1, s2))) xs) thy))); |
13402 | 768 |
|
24867 | 769 |
val _ = |
13402 | 770 |
OuterSyntax.command "realizability" |
771 |
"add equations characterizing realizability" K.thy_decl |
|
772 |
(Scan.repeat1 P.string >> (Toplevel.theory o add_realizes_eqns)); |
|
773 |
||
24867 | 774 |
val _ = |
13402 | 775 |
OuterSyntax.command "extract_type" |
776 |
"add equations characterizing type of extracted program" K.thy_decl |
|
777 |
(Scan.repeat1 P.string >> (Toplevel.theory o add_typeof_eqns)); |
|
778 |
||
24867 | 779 |
val _ = |
13402 | 780 |
OuterSyntax.command "extract" "extract terms from proofs" K.thy_decl |
26336
a0e2b706ce73
renamed datatype thmref to Facts.ref, tuned interfaces;
wenzelm
parents:
25389
diff
changeset
|
781 |
(Scan.repeat1 (P.xname -- parse_vars) >> (fn xs => Toplevel.theory (fn thy => |
26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26336
diff
changeset
|
782 |
extract (map (apfst (PureThy.get_thm thy)) xs) thy))); |
13402 | 783 |
|
16458 | 784 |
val etype_of = etype_of o add_syntax; |
13714 | 785 |
|
13402 | 786 |
end; |