author | berghofe |
Sun, 17 Nov 2002 23:43:53 +0100 | |
changeset 13719 | 44fed7d0c305 |
parent 13714 | bdd483321f4b |
child 13732 | f8badfef5cf2 |
permissions | -rw-r--r-- |
13402 | 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 |
|
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 |
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 |
||
13417
12cc77f90811
Tuned type constraint of function merge_rules to make smlnj happy.
berghofe
parents:
13402
diff
changeset
|
86 |
fun merge_rules |
12cc77f90811
Tuned type constraint of function merge_rules to make smlnj happy.
berghofe
parents:
13402
diff
changeset
|
87 |
({next, rs = rs1, net} : rules) ({next = next2, rs = rs2, ...} : rules) = |
13402 | 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); |
|
13714 | 101 |
val prems' = map (pairself (subst_vars env o inc o ren)) prems; |
13402 | 102 |
val env' = Envir.Envir |
103 |
{maxidx = foldl Int.max |
|
104 |
(~1, map (Int.max o pairself maxidx_of_term) prems'), |
|
13714 | 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))) |
|
13402 | 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 |
||
13714 | 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 |
||
13402 | 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 |
|
13609
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
466 |
if T = nullT andalso realizes_null vs' prop aconv prop then (defs, prf0) |
13402 | 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 |
|
13719
44fed7d0c305
Fixed small bug that caused some definitions to be "forgotten".
berghofe
parents:
13714
diff
changeset
|
481 |
((name, (vs', ((nullt, nullt), corr_prf'))) :: defs'', |
13402 | 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 |
|
13609
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
497 |
if etype_of sg vs' [] prop = nullT andalso |
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
498 |
realizes_null vs' prop aconv prop then (defs, prf0) |
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
499 |
else case find vs' (Symtab.lookup_multi (realizers, s)) of |
13402 | 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 |
|
13719
44fed7d0c305
Fixed small bug that caused some definitions to be "forgotten".
berghofe
parents:
13714
diff
changeset
|
583 |
((s, (vs', ((t', u), corr_prf'))) :: defs'', |
13402 | 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) |
|
13609
73c3915553b4
Added check for axioms with "realizes Null A = A".
berghofe
parents:
13417
diff
changeset
|
601 |
| None => error ("extr: no realizer for instance of axiom " ^ |
13402 | 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 |
||
13714 | 731 |
val etype_of = etype_of o sign_of o add_syntax; |
732 |
||
13402 | 733 |
end; |
734 |
||
735 |
OuterSyntax.add_parsers Extraction.parsers; |