author | wenzelm |
Sun, 09 Jul 2023 14:33:45 +0200 | |
changeset 78273 | 95a3bb4d7e38 |
parent 77867 | 686a7d71ed7b |
child 79113 | 5109e4b2a292 |
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 |
|
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
18 |
val add_expand_thm : bool -> thm -> 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 |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
27 |
val abs_corr_shyps: theory -> thm -> string list -> term list -> Proofterm.proof -> Proofterm.proof |
13402 | 28 |
end; |
29 |
||
30 |
structure Extraction : EXTRACTION = |
|
31 |
struct |
|
32 |
||
33 |
(**** tools ****) |
|
34 |
||
42407
5b9dd52f5dca
prefer internal types, via Simple_Syntax.read_typ;
wenzelm
parents:
42406
diff
changeset
|
35 |
val typ = Simple_Syntax.read_typ; |
5b9dd52f5dca
prefer internal types, via Simple_Syntax.read_typ;
wenzelm
parents:
42406
diff
changeset
|
36 |
|
5b9dd52f5dca
prefer internal types, via Simple_Syntax.read_typ;
wenzelm
parents:
42406
diff
changeset
|
37 |
val add_syntax = |
52788 | 38 |
Sign.root_path |
56436 | 39 |
#> Sign.add_types_global |
64556 | 40 |
[(Binding.make ("Type", \<^here>), 0, NoSyn), |
41 |
(Binding.make ("Null", \<^here>), 0, NoSyn)] |
|
56239 | 42 |
#> Sign.add_consts |
67721 | 43 |
[(Binding.make ("typeof", \<^here>), typ "'b \<Rightarrow> Type", NoSyn), |
44 |
(Binding.make ("Type", \<^here>), typ "'a itself \<Rightarrow> Type", NoSyn), |
|
64556 | 45 |
(Binding.make ("Null", \<^here>), typ "Null", NoSyn), |
67721 | 46 |
(Binding.make ("realizes", \<^here>), typ "'a \<Rightarrow> 'b \<Rightarrow> 'b", NoSyn)]; |
13402 | 47 |
|
48 |
val nullT = Type ("Null", []); |
|
49 |
val nullt = Const ("Null", nullT); |
|
50 |
||
51 |
fun mk_typ T = |
|
19391 | 52 |
Const ("Type", Term.itselfT T --> Type ("Type", [])) $ Logic.mk_type T; |
13402 | 53 |
|
54 |
fun typeof_proc defaultS vs (Const ("typeof", _) $ u) = |
|
15531 | 55 |
SOME (mk_typ (case strip_comb u of |
13402 | 56 |
(Var ((a, i), _), _) => |
20664 | 57 |
if member (op =) vs a then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS) |
13402 | 58 |
else nullT |
59 |
| (Free (a, _), _) => |
|
20664 | 60 |
if member (op =) vs a then TFree ("'" ^ a, defaultS) else nullT |
13402 | 61 |
| _ => nullT)) |
15531 | 62 |
| typeof_proc _ _ _ = NONE; |
13402 | 63 |
|
49960 | 64 |
fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ _ $ t) = SOME t |
13732 | 65 |
| rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) = |
66 |
(case strip_comb t of |
|
15531 | 67 |
(Var (ixn, U), ts) => SOME (list_comb (Var (ixn, T --> U), r :: ts)) |
68 |
| (Free (s, U), ts) => SOME (list_comb (Free (s, T --> U), r :: ts)) |
|
69 |
| _ => NONE) |
|
70 |
| rlz_proc _ = NONE; |
|
13402 | 71 |
|
72 |
val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o |
|
67522 | 73 |
chop_prefix (fn s => s <> ":") o raw_explode; |
13402 | 74 |
|
75 |
type rules = |
|
76 |
{next: int, rs: ((term * term) list * (term * term)) list, |
|
77 |
net: (int * ((term * term) list * (term * term))) Net.net}; |
|
78 |
||
79 |
val empty_rules : rules = {next = 0, rs = [], net = Net.empty}; |
|
80 |
||
33337 | 81 |
fun add_rule (r as (_, (lhs, _))) ({next, rs, net} : rules) = |
16800 | 82 |
{next = next - 1, rs = r :: rs, net = Net.insert_term (K false) |
18956 | 83 |
(Envir.eta_contract lhs, (next, r)) net}; |
13402 | 84 |
|
32784 | 85 |
fun merge_rules ({next, rs = rs1, net} : rules) ({rs = rs2, ...} : rules) = |
33337 | 86 |
fold_rev add_rule (subtract (op =) rs1 rs2) {next = next, rs = rs1, net = net}; |
13402 | 87 |
|
16458 | 88 |
fun condrew thy rules procs = |
13402 | 89 |
let |
90 |
fun rew tm = |
|
17203 | 91 |
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
|
92 |
and condrew' tm = |
13402 | 93 |
let |
32738 | 94 |
val cache = Unsynchronized.ref ([] : (term * term) list); |
17232 | 95 |
fun lookup f x = (case AList.lookup (op =) (!cache) x of |
15531 | 96 |
NONE => |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
97 |
let val y = f x |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
98 |
in (cache := (x, y) :: !cache; y) end |
15531 | 99 |
| SOME y => y); |
15399
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
100 |
in |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
101 |
get_first (fn (_, (prems, (tm1, tm2))) => |
683d83051d6a
Added term cache to function condrew in order to speed up rewriting.
berghofe
parents:
14981
diff
changeset
|
102 |
let |
19466 | 103 |
fun ren t = the_default t (Term.rename_abs tm1 tm t); |
59787 | 104 |
val inc = Logic.incr_indexes ([], [], maxidx_of_term tm + 1); |
18184 | 105 |
val env as (Tenv, tenv) = Pattern.match thy (inc tm1, tm) (Vartab.empty, Vartab.empty); |
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
58950
diff
changeset
|
106 |
val prems' = map (apply2 (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
|
107 |
val env' = Envir.Envir |
32032 | 108 |
{maxidx = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u) prems' ~1, |
109 |
tenv = tenv, tyenv = Tenv}; |
|
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
58950
diff
changeset
|
110 |
val env'' = fold (Pattern.unify (Context.Theory thy) o apply2 (lookup rew)) prems' env'; |
15531 | 111 |
in SOME (Envir.norm_term env'' (inc (ren tm2))) |
112 |
end handle Pattern.MATCH => NONE | Pattern.Unif => NONE) |
|
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
58950
diff
changeset
|
113 |
(sort (int_ord o apply2 fst) |
18956 | 114 |
(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
|
115 |
end; |
13402 | 116 |
|
117 |
in rew end; |
|
118 |
||
70806 | 119 |
val change_types = Proofterm.change_types o SOME; |
13402 | 120 |
|
30364
577edc39b501
moved basic algebra of long names from structure NameSpace to Long_Name;
wenzelm
parents:
30344
diff
changeset
|
121 |
fun extr_name s vs = Long_Name.append "extr" (space_implode "_" (s :: vs)); |
16195 | 122 |
fun corr_name s vs = extr_name s vs ^ "_correctness"; |
13402 | 123 |
|
61865 | 124 |
fun msg d s = writeln (Symbol.spaces d ^ s); |
13402 | 125 |
|
74235 | 126 |
fun vars_of t = map Var (build_rev (Term.add_vars t)); |
127 |
fun frees_of t = map Free (build_rev (Term.add_frees t)); |
|
28812
413695e07bd4
Frees in PThms are now quantified in the order of their appearance in the
berghofe
parents:
28805
diff
changeset
|
128 |
fun vfs_of t = vars_of t @ frees_of t; |
13402 | 129 |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
130 |
val mkabs = fold_rev (fn v => fn t => Abs ("x", fastype_of v, abstract_over (v, t))); |
13402 | 131 |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
132 |
val mkabsp = fold_rev (fn t => fn prf => AbsP ("H", SOME t, prf)); |
13402 | 133 |
|
13732 | 134 |
fun strip_abs 0 t = t |
135 |
| strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t |
|
136 |
| strip_abs _ _ = error "strip_abs: not an abstraction"; |
|
137 |
||
37310 | 138 |
val prf_subst_TVars = Proofterm.map_proof_types o typ_subst_TVars; |
13402 | 139 |
|
40844 | 140 |
fun relevant_vars types prop = |
141 |
List.foldr |
|
142 |
(fn (Var ((a, _), T), vs) => |
|
143 |
(case body_type T of |
|
144 |
Type (s, _) => if member (op =) types s then a :: vs else vs |
|
145 |
| _ => vs) |
|
146 |
| (_, vs) => vs) [] (vars_of prop); |
|
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 []; |
|
42406
05f2468d6b36
eliminated obsolete Proof_Syntax.strip_sorts_consttypes;
wenzelm
parents:
42375
diff
changeset
|
155 |
in |
05f2468d6b36
eliminated obsolete Proof_Syntax.strip_sorts_consttypes;
wenzelm
parents:
42375
diff
changeset
|
156 |
fn Var (ixn, _) => |
05f2468d6b36
eliminated obsolete Proof_Syntax.strip_sorts_consttypes;
wenzelm
parents:
42375
diff
changeset
|
157 |
(case AList.lookup (op =) vs ixn of |
15531 | 158 |
NONE => error "get_var_type: no such variable in term" |
159 |
| SOME T => Var (ixn, T)) |
|
42406
05f2468d6b36
eliminated obsolete Proof_Syntax.strip_sorts_consttypes;
wenzelm
parents:
42375
diff
changeset
|
160 |
| Free (s, _) => |
05f2468d6b36
eliminated obsolete Proof_Syntax.strip_sorts_consttypes;
wenzelm
parents:
42375
diff
changeset
|
161 |
(case AList.lookup (op =) fs s of |
15531 | 162 |
NONE => error "get_var_type: no such variable in term" |
163 |
| SOME T => Free (s, T)) |
|
13732 | 164 |
| _ => error "get_var_type: not a variable" |
165 |
end; |
|
166 |
||
62922 | 167 |
fun read_term ctxt T s = |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
168 |
let |
62922 | 169 |
val ctxt' = ctxt |
62958
b41c1cb5e251
Type_Infer.object_logic controls improvement of type inference result;
wenzelm
parents:
62922
diff
changeset
|
170 |
|> Proof_Context.set_defsort [] |
b41c1cb5e251
Type_Infer.object_logic controls improvement of type inference result;
wenzelm
parents:
62922
diff
changeset
|
171 |
|> Config.put Type_Infer.object_logic false |
b41c1cb5e251
Type_Infer.object_logic controls improvement of type inference result;
wenzelm
parents:
62922
diff
changeset
|
172 |
|> Config.put Type_Infer_Context.const_sorts false; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
173 |
val parse = if T = propT then Syntax.parse_prop else Syntax.parse_term; |
62922 | 174 |
in parse ctxt' s |> Type.constraint T |> Syntax.check_term ctxt' end; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
175 |
|
70589 | 176 |
fun make_proof_body prf = |
177 |
let |
|
178 |
val (oracles, thms) = |
|
179 |
([prf], ([], [])) |-> Proofterm.fold_proof_atoms false |
|
71465
910a081cca74
more position information for oracles (e.g. "skip_proof" for 'sorry'), requires Proofterm.proofs := 1;
wenzelm
parents:
71214
diff
changeset
|
180 |
(fn Oracle (name, prop, _) => apfst (cons ((name, Position.none), SOME prop)) |
70589 | 181 |
| PThm (header, thm_body) => apsnd (cons (Proofterm.make_thm header thm_body)) |
182 |
| _ => I); |
|
77866 | 183 |
val body = |
184 |
PBody |
|
77867 | 185 |
{oracles = Ord_List.make Proofterm.oracle_ord oracles, |
77866 | 186 |
thms = Ord_List.make Proofterm.thm_ord thms, |
187 |
proof = prf}; |
|
70589 | 188 |
in Proofterm.thm_body body end; |
189 |
||
190 |
||
13402 | 191 |
|
192 |
(**** theory data ****) |
|
193 |
||
22846 | 194 |
(* theory data *) |
13402 | 195 |
|
33522 | 196 |
structure ExtractionData = Theory_Data |
22846 | 197 |
( |
13402 | 198 |
type T = |
199 |
{realizes_eqns : rules, |
|
200 |
typeof_eqns : rules, |
|
13732 | 201 |
types : (string * ((term -> term option) list * |
202 |
(term -> typ -> term -> typ -> term) option)) list, |
|
13402 | 203 |
realizers : (string list * (term * proof)) list Symtab.table, |
204 |
defs : thm list, |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
205 |
expand : string list, |
16458 | 206 |
prep : (theory -> proof -> proof) option} |
13402 | 207 |
|
208 |
val empty = |
|
209 |
{realizes_eqns = empty_rules, |
|
210 |
typeof_eqns = empty_rules, |
|
211 |
types = [], |
|
212 |
realizers = Symtab.empty, |
|
213 |
defs = [], |
|
214 |
expand = [], |
|
15531 | 215 |
prep = NONE}; |
13402 | 216 |
|
33522 | 217 |
fun merge |
218 |
({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1, |
|
13402 | 219 |
realizers = realizers1, defs = defs1, expand = expand1, prep = prep1}, |
220 |
{realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2, |
|
33522 | 221 |
realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T = |
13402 | 222 |
{realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2, |
223 |
typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2, |
|
22717 | 224 |
types = AList.merge (op =) (K true) (types1, types2), |
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
58950
diff
changeset
|
225 |
realizers = Symtab.merge_list (eq_set (op =) o apply2 #1) (realizers1, realizers2), |
22662 | 226 |
defs = Library.merge Thm.eq_thm (defs1, defs2), |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
227 |
expand = Library.merge (op =) (expand1, expand2), |
38761 | 228 |
prep = if is_some prep1 then prep1 else prep2}; |
22846 | 229 |
); |
13402 | 230 |
|
231 |
fun read_condeq thy = |
|
62922 | 232 |
let val ctxt' = Proof_Context.init_global (add_syntax thy) |
13402 | 233 |
in fn s => |
62922 | 234 |
let val t = Logic.varify_global (read_term ctxt' propT s) |
35424 | 235 |
in |
236 |
(map Logic.dest_equals (Logic.strip_imp_prems t), |
|
237 |
Logic.dest_equals (Logic.strip_imp_concl t)) |
|
238 |
handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s) |
|
239 |
end |
|
13402 | 240 |
end; |
241 |
||
242 |
(** preprocessor **) |
|
243 |
||
244 |
fun set_preprocessor prep thy = |
|
245 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
246 |
defs, expand, ...} = ExtractionData.get thy |
|
247 |
in |
|
248 |
ExtractionData.put |
|
249 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
15531 | 250 |
realizers = realizers, defs = defs, expand = expand, prep = SOME prep} thy |
13402 | 251 |
end; |
252 |
||
253 |
(** equations characterizing realizability **) |
|
254 |
||
255 |
fun gen_add_realizes_eqns prep_eq eqns thy = |
|
256 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
257 |
defs, expand, prep} = ExtractionData.get thy; |
|
258 |
in |
|
259 |
ExtractionData.put |
|
33337 | 260 |
{realizes_eqns = fold_rev add_rule (map (prep_eq thy) eqns) realizes_eqns, |
13402 | 261 |
typeof_eqns = typeof_eqns, types = types, realizers = realizers, |
262 |
defs = defs, expand = expand, prep = prep} thy |
|
263 |
end |
|
264 |
||
265 |
val add_realizes_eqns_i = gen_add_realizes_eqns (K I); |
|
266 |
val add_realizes_eqns = gen_add_realizes_eqns read_condeq; |
|
267 |
||
268 |
(** equations characterizing type of extracted program **) |
|
269 |
||
270 |
fun gen_add_typeof_eqns prep_eq eqns thy = |
|
271 |
let |
|
272 |
val {realizes_eqns, typeof_eqns, types, realizers, |
|
273 |
defs, expand, prep} = ExtractionData.get thy; |
|
13732 | 274 |
val eqns' = map (prep_eq thy) eqns |
13402 | 275 |
in |
276 |
ExtractionData.put |
|
277 |
{realizes_eqns = realizes_eqns, realizers = realizers, |
|
33337 | 278 |
typeof_eqns = fold_rev add_rule eqns' typeof_eqns, |
13732 | 279 |
types = types, defs = defs, expand = expand, prep = prep} thy |
13402 | 280 |
end |
281 |
||
282 |
val add_typeof_eqns_i = gen_add_typeof_eqns (K I); |
|
283 |
val add_typeof_eqns = gen_add_typeof_eqns read_condeq; |
|
284 |
||
285 |
fun thaw (T as TFree (a, S)) = |
|
77851 | 286 |
if member_string a ":" then TVar (unpack_ixn a, S) else T |
13402 | 287 |
| thaw (Type (a, Ts)) = Type (a, map thaw Ts) |
288 |
| thaw T = T; |
|
289 |
||
290 |
fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S) |
|
291 |
| freeze (Type (a, Ts)) = Type (a, map freeze Ts) |
|
292 |
| freeze T = T; |
|
293 |
||
294 |
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
|
295 |
map_types thaw (f (map_types freeze x)); |
13402 | 296 |
|
16458 | 297 |
fun etype_of thy vs Ts t = |
13402 | 298 |
let |
16458 | 299 |
val {typeof_eqns, ...} = ExtractionData.get thy; |
13402 | 300 |
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
|
301 |
Syntax.string_of_term_global thy t) |
46219
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
302 |
in |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
303 |
(case |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
304 |
strip_abs_body |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
305 |
(freeze_thaw (condrew thy (#net typeof_eqns) [typeof_proc [] vs]) |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
306 |
(fold (Term.abs o pair "x") Ts |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
307 |
(Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of |
13402 | 308 |
Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ()) |
46219
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
309 |
| _ => err ()) |
13402 | 310 |
end; |
311 |
||
312 |
(** realizers for axioms / theorems, together with correctness proofs **) |
|
313 |
||
314 |
fun gen_add_realizers prep_rlz rs thy = |
|
315 |
let val {realizes_eqns, typeof_eqns, types, realizers, |
|
316 |
defs, expand, prep} = ExtractionData.get thy |
|
317 |
in |
|
318 |
ExtractionData.put |
|
319 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
25389 | 320 |
realizers = fold (Symtab.cons_list o prep_rlz thy) rs realizers, |
13402 | 321 |
defs = defs, expand = expand, prep = prep} thy |
322 |
end |
|
323 |
||
324 |
fun prep_realizer thy = |
|
325 |
let |
|
13732 | 326 |
val {realizes_eqns, typeof_eqns, defs, types, ...} = |
13402 | 327 |
ExtractionData.get thy; |
19482
9f11af8f7ef9
tuned basic list operators (flat, maps, map_filter);
wenzelm
parents:
19466
diff
changeset
|
328 |
val procs = maps (fst o snd) types; |
13732 | 329 |
val rtypes = map fst types; |
16800 | 330 |
val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
13402 | 331 |
val thy' = add_syntax thy; |
62922 | 332 |
val ctxt' = Proof_Context.init_global thy'; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
333 |
val rd = Proof_Syntax.read_proof thy' true false; |
13402 | 334 |
in fn (thm, (vs, s1, s2)) => |
335 |
let |
|
36744
6e1f3d609a68
renamed Thm.get_name -> Thm.derivation_name and Thm.put_name -> Thm.name_derivation, to emphasize the true nature of these operations;
wenzelm
parents:
36620
diff
changeset
|
336 |
val name = Thm.derivation_name thm; |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
337 |
val _ = name <> "" orelse error "add_realizers: unnamed theorem"; |
59582 | 338 |
val prop = Thm.unconstrainT thm |> Thm.prop_of |> |
339 |
Pattern.rewrite_term thy' (map (Logic.dest_equals o Thm.prop_of) defs) []; |
|
13402 | 340 |
val vars = vars_of prop; |
13732 | 341 |
val vars' = filter_out (fn v => |
20664 | 342 |
member (op =) rtypes (tname_of (body_type (fastype_of v)))) vars; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
343 |
val shyps = maps (fn Var ((x, i), _) => |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
344 |
if member (op =) vs x then Logic.mk_of_sort |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
345 |
(TVar (("'" ^ x, i), []), Sign.defaultS thy') |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
346 |
else []) vars; |
16458 | 347 |
val T = etype_of thy' vs [] prop; |
33832 | 348 |
val (T', thw) = Type.legacy_freeze_thaw_type |
13732 | 349 |
(if T = nullT then nullT else map fastype_of vars' ---> T); |
62922 | 350 |
val t = map_types thw (read_term ctxt' T' s1); |
16458 | 351 |
val r' = freeze_thaw (condrew thy' eqns |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
352 |
(procs @ [typeof_proc [] vs, rlz_proc])) |
13402 | 353 |
(Const ("realizes", T --> propT --> propT) $ |
13732 | 354 |
(if T = nullT then t else list_comb (t, vars')) $ prop); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
355 |
val r = Logic.list_implies (shyps, |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
356 |
fold_rev Logic.all (map (get_var_type r') vars) r'); |
70449 | 357 |
val prf = Proofterm.reconstruct_proof thy' r (rd s2); |
13402 | 358 |
in (name, (vs, (t, prf))) end |
359 |
end; |
|
360 |
||
361 |
val add_realizers_i = gen_add_realizers |
|
362 |
(fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf)))); |
|
363 |
val add_realizers = gen_add_realizers prep_realizer; |
|
364 |
||
13714 | 365 |
fun realizes_of thy vs t prop = |
366 |
let |
|
367 |
val thy' = add_syntax thy; |
|
13732 | 368 |
val {realizes_eqns, typeof_eqns, defs, types, ...} = |
13714 | 369 |
ExtractionData.get thy'; |
22717 | 370 |
val procs = maps (rev o fst o snd) types; |
16800 | 371 |
val eqns = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
17203 | 372 |
val prop' = Pattern.rewrite_term thy' |
59582 | 373 |
(map (Logic.dest_equals o Thm.prop_of) defs) [] prop; |
16458 | 374 |
in freeze_thaw (condrew thy' eqns |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
375 |
(procs @ [typeof_proc [] vs, rlz_proc])) |
13714 | 376 |
(Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop') |
377 |
end; |
|
378 |
||
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
379 |
fun abs_corr_shyps thy thm vs xs prf = |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
380 |
let |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
381 |
val S = Sign.defaultS thy; |
70436 | 382 |
val (ucontext, prop') = |
61039 | 383 |
Logic.unconstrainT (Thm.shyps_of thm) (Thm.prop_of thm); |
59582 | 384 |
val atyps = fold_types (fold_atyps (insert (op =))) (Thm.prop_of thm) []; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
385 |
val Ts = map_filter (fn ((v, i), _) => if member (op =) vs v then |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
386 |
SOME (TVar (("'" ^ v, i), [])) else NONE) |
74235 | 387 |
(build_rev (Term.add_vars prop')); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
388 |
val cs = maps (fn T => map (pair T) S) Ts; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
389 |
val constraints' = map Logic.mk_of_class cs; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
390 |
fun typ_map T = Type.strip_sorts |
70436 | 391 |
(map_atyps (fn U => if member (op =) atyps U then (#atyp_map ucontext) U else U) T); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
392 |
fun mk_hyp (T, c) = Hyp (Logic.mk_of_class (typ_map T, c)); |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
393 |
val xs' = map (map_types typ_map) xs |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
394 |
in |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
395 |
prf |> |
37310 | 396 |
Same.commit (Proofterm.map_proof_same (map_types typ_map) typ_map mk_hyp) |> |
70436 | 397 |
fold_rev Proofterm.implies_intr_proof' (map snd (#constraints ucontext)) |> |
37310 | 398 |
fold_rev Proofterm.forall_intr_proof' xs' |> |
399 |
fold_rev Proofterm.implies_intr_proof' constraints' |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
400 |
end; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
401 |
|
13402 | 402 |
(** expanding theorems / definitions **) |
403 |
||
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
404 |
fun add_expand_thm is_def thm thy = |
13402 | 405 |
let |
406 |
val {realizes_eqns, typeof_eqns, types, realizers, |
|
407 |
defs, expand, prep} = ExtractionData.get thy; |
|
408 |
||
36744
6e1f3d609a68
renamed Thm.get_name -> Thm.derivation_name and Thm.put_name -> Thm.name_derivation, to emphasize the true nature of these operations;
wenzelm
parents:
36620
diff
changeset
|
409 |
val name = Thm.derivation_name thm; |
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
410 |
val _ = name <> "" orelse error "add_expand_thm: unnamed theorem"; |
13402 | 411 |
in |
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
412 |
thy |> ExtractionData.put |
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
413 |
(if is_def then |
13402 | 414 |
{realizes_eqns = realizes_eqns, |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
415 |
typeof_eqns = add_rule ([], Logic.dest_equals (map_types |
59582 | 416 |
Type.strip_sorts (Thm.prop_of (Drule.abs_def thm)))) typeof_eqns, |
13402 | 417 |
types = types, |
61094 | 418 |
realizers = realizers, defs = insert Thm.eq_thm_prop (Thm.trim_context thm) defs, |
13402 | 419 |
expand = expand, prep = prep} |
420 |
else |
|
421 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types, |
|
422 |
realizers = realizers, defs = defs, |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
423 |
expand = insert (op =) name expand, prep = prep}) |
13402 | 424 |
end; |
425 |
||
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
426 |
fun extraction_expand is_def = |
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
427 |
Thm.declaration_attribute (fn th => Context.mapping (add_expand_thm is_def th) I); |
13402 | 428 |
|
15801 | 429 |
|
13732 | 430 |
(** types with computational content **) |
431 |
||
432 |
fun add_types tys thy = |
|
22717 | 433 |
ExtractionData.map |
434 |
(fn {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} => |
|
13732 | 435 |
{realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, |
22717 | 436 |
types = fold (AList.update (op =) o apfst (Sign.intern_type thy)) tys types, |
437 |
realizers = realizers, defs = defs, expand = expand, prep = prep}) |
|
438 |
thy; |
|
13732 | 439 |
|
13402 | 440 |
|
15801 | 441 |
(** Pure setup **) |
442 |
||
53171 | 443 |
val _ = Theory.setup |
18708 | 444 |
(add_types [("prop", ([], NONE))] #> |
15801 | 445 |
|
446 |
add_typeof_eqns |
|
67721 | 447 |
["(typeof (PROP P)) \<equiv> (Type (TYPE(Null))) \<Longrightarrow> \ |
448 |
\ (typeof (PROP Q)) \<equiv> (Type (TYPE('Q))) \<Longrightarrow> \ |
|
449 |
\ (typeof (PROP P \<Longrightarrow> PROP Q)) \<equiv> (Type (TYPE('Q)))", |
|
15801 | 450 |
|
67721 | 451 |
"(typeof (PROP Q)) \<equiv> (Type (TYPE(Null))) \<Longrightarrow> \ |
452 |
\ (typeof (PROP P \<Longrightarrow> PROP Q)) \<equiv> (Type (TYPE(Null)))", |
|
15801 | 453 |
|
67721 | 454 |
"(typeof (PROP P)) \<equiv> (Type (TYPE('P))) \<Longrightarrow> \ |
455 |
\ (typeof (PROP Q)) \<equiv> (Type (TYPE('Q))) \<Longrightarrow> \ |
|
456 |
\ (typeof (PROP P \<Longrightarrow> PROP Q)) \<equiv> (Type (TYPE('P \<Rightarrow> 'Q)))", |
|
15801 | 457 |
|
67721 | 458 |
"(\<lambda>x. typeof (PROP P (x))) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow> \ |
459 |
\ (typeof (\<And>x. PROP P (x))) \<equiv> (Type (TYPE(Null)))", |
|
15801 | 460 |
|
67721 | 461 |
"(\<lambda>x. typeof (PROP P (x))) \<equiv> (\<lambda>x. Type (TYPE('P))) \<Longrightarrow> \ |
462 |
\ (typeof (\<And>x::'a. PROP P (x))) \<equiv> (Type (TYPE('a \<Rightarrow> 'P)))", |
|
15801 | 463 |
|
67721 | 464 |
"(\<lambda>x. typeof (f (x))) \<equiv> (\<lambda>x. Type (TYPE('f))) \<Longrightarrow> \ |
465 |
\ (typeof (f)) \<equiv> (Type (TYPE('f)))"] #> |
|
15801 | 466 |
|
467 |
add_realizes_eqns |
|
67721 | 468 |
["(typeof (PROP P)) \<equiv> (Type (TYPE(Null))) \<Longrightarrow> \ |
469 |
\ (realizes (r) (PROP P \<Longrightarrow> PROP Q)) \<equiv> \ |
|
470 |
\ (PROP realizes (Null) (PROP P) \<Longrightarrow> PROP realizes (r) (PROP Q))", |
|
15801 | 471 |
|
67721 | 472 |
"(typeof (PROP P)) \<equiv> (Type (TYPE('P))) \<Longrightarrow> \ |
473 |
\ (typeof (PROP Q)) \<equiv> (Type (TYPE(Null))) \<Longrightarrow> \ |
|
474 |
\ (realizes (r) (PROP P \<Longrightarrow> PROP Q)) \<equiv> \ |
|
475 |
\ (\<And>x::'P. PROP realizes (x) (PROP P) \<Longrightarrow> PROP realizes (Null) (PROP Q))", |
|
15801 | 476 |
|
67721 | 477 |
"(realizes (r) (PROP P \<Longrightarrow> PROP Q)) \<equiv> \ |
478 |
\ (\<And>x. PROP realizes (x) (PROP P) \<Longrightarrow> PROP realizes (r (x)) (PROP Q))", |
|
15801 | 479 |
|
67721 | 480 |
"(\<lambda>x. typeof (PROP P (x))) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow> \ |
481 |
\ (realizes (r) (\<And>x. PROP P (x))) \<equiv> \ |
|
482 |
\ (\<And>x. PROP realizes (Null) (PROP P (x)))", |
|
15801 | 483 |
|
67721 | 484 |
"(realizes (r) (\<And>x. PROP P (x))) \<equiv> \ |
485 |
\ (\<And>x. PROP realizes (r (x)) (PROP P (x)))"] #> |
|
15801 | 486 |
|
67147 | 487 |
Attrib.setup \<^binding>\<open>extraction_expand\<close> (Scan.succeed (extraction_expand false)) |
33704
6aeb8454efc1
add_expand_thm: explicit indication of is_def instead of fragile heuristic, tuned signature;
wenzelm
parents:
33522
diff
changeset
|
488 |
"specify theorems to be expanded during extraction" #> |
67147 | 489 |
Attrib.setup \<^binding>\<open>extraction_expand_def\<close> (Scan.succeed (extraction_expand true)) |
53171 | 490 |
"specify definitions to be expanded during extraction"); |
15801 | 491 |
|
492 |
||
13402 | 493 |
(**** extract program ****) |
494 |
||
495 |
val dummyt = Const ("dummy", dummyT); |
|
496 |
||
58436 | 497 |
fun extract thm_vss thy = |
13402 | 498 |
let |
16458 | 499 |
val thy' = add_syntax thy; |
62922 | 500 |
|
13402 | 501 |
val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} = |
502 |
ExtractionData.get thy; |
|
22717 | 503 |
val procs = maps (rev o fst o snd) types; |
13732 | 504 |
val rtypes = map fst types; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
505 |
val typroc = typeof_proc []; |
70915
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70840
diff
changeset
|
506 |
fun expand_name ({name, ...}: Proofterm.thm_header) = |
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70840
diff
changeset
|
507 |
if name = "" orelse member (op =) expand name then SOME "" else NONE; |
61094 | 508 |
val prep = the_default (K I) prep thy' o |
70840 | 509 |
Proof_Rewrite_Rules.elim_defs thy' false (map (Thm.transfer thy) defs) o |
70915
bd4d37edfee4
clarified expand_proof/expand_name: allow more detailed control via thm_header;
wenzelm
parents:
70840
diff
changeset
|
510 |
Proofterm.expand_proof thy' expand_name; |
16800 | 511 |
val rrews = Net.merge (K false) (#net realizes_eqns, #net typeof_eqns); |
13402 | 512 |
|
513 |
fun find_inst prop Ts ts vs = |
|
514 |
let |
|
13732 | 515 |
val rvs = relevant_vars rtypes prop; |
13402 | 516 |
val vars = vars_of prop; |
517 |
val n = Int.min (length vars, length ts); |
|
518 |
||
33337 | 519 |
fun add_args (Var ((a, i), _), t) (vs', tye) = |
20664 | 520 |
if member (op =) rvs a then |
16458 | 521 |
let val T = etype_of thy' vs Ts t |
13402 | 522 |
in if T = nullT then (vs', tye) |
523 |
else (a :: vs', (("'" ^ a, i), T) :: tye) |
|
524 |
end |
|
525 |
else (vs', tye) |
|
526 |
||
33957 | 527 |
in fold_rev add_args (take n vars ~~ take n ts) ([], []) end; |
13402 | 528 |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
529 |
fun mk_shyps tye = maps (fn (ixn, _) => |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
530 |
Logic.mk_of_sort (TVar (ixn, []), Sign.defaultS thy)) tye; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
531 |
|
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
532 |
fun mk_sprfs cs tye = maps (fn (_, T) => |
70840 | 533 |
Proof_Rewrite_Rules.expand_of_sort_proof thy' (map SOME cs) |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
534 |
(T, Sign.defaultS thy)) tye; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
535 |
|
33038 | 536 |
fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst); |
28375 | 537 |
fun find' (s: string) = map_filter (fn (s', x) => if s = s' then SOME x else NONE); |
13402 | 538 |
|
46219
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
539 |
fun app_rlz_rews Ts vs t = |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
540 |
strip_abs (length Ts) |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
541 |
(freeze_thaw (condrew thy' rrews (procs @ [typroc vs, rlz_proc])) |
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
542 |
(fold (Term.abs o pair "x") Ts t)); |
13732 | 543 |
|
544 |
fun realizes_null vs prop = app_rlz_rews [] vs |
|
545 |
(Const ("realizes", nullT --> propT --> propT) $ nullt $ prop); |
|
13402 | 546 |
|
49960 | 547 |
fun corr d vs ts Ts hs cs _ (PBound i) _ defs = (PBound i, defs) |
13402 | 548 |
|
49960 | 549 |
| corr d vs ts Ts hs cs t (Abst (s, SOME T, prf)) (Abst (_, _, prf')) defs = |
550 |
let val (corr_prf, defs') = corr d vs [] (T :: Ts) |
|
551 |
(dummyt :: hs) cs (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE) |
|
552 |
prf (Proofterm.incr_pboundvars 1 0 prf') defs |
|
553 |
in (Abst (s, SOME T, corr_prf), defs') end |
|
13402 | 554 |
|
49960 | 555 |
| corr d vs ts Ts hs cs t (AbsP (s, SOME prop, prf)) (AbsP (_, _, prf')) defs = |
13402 | 556 |
let |
16458 | 557 |
val T = etype_of thy' vs Ts prop; |
42407
5b9dd52f5dca
prefer internal types, via Simple_Syntax.read_typ;
wenzelm
parents:
42406
diff
changeset
|
558 |
val u = if T = nullT then |
15531 | 559 |
(case t of SOME u => SOME (incr_boundvars 1 u) | NONE => NONE) |
560 |
else (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE); |
|
49960 | 561 |
val (corr_prf, defs') = |
562 |
corr d vs [] (T :: Ts) (prop :: hs) |
|
563 |
(prop :: cs) u (Proofterm.incr_pboundvars 0 1 prf) |
|
564 |
(Proofterm.incr_pboundvars 0 1 prf') defs; |
|
13402 | 565 |
val rlz = Const ("realizes", T --> propT --> propT) |
49960 | 566 |
in ( |
13732 | 567 |
if T = nullT then AbsP ("R", |
15531 | 568 |
SOME (app_rlz_rews Ts vs (rlz $ nullt $ prop)), |
37310 | 569 |
Proofterm.prf_subst_bounds [nullt] corr_prf) |
15531 | 570 |
else Abst (s, SOME T, AbsP ("R", |
571 |
SOME (app_rlz_rews (T :: Ts) vs |
|
49960 | 572 |
(rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf)), defs') |
13402 | 573 |
end |
574 |
||
49960 | 575 |
| corr d vs ts Ts hs cs t' (prf % SOME t) (prf' % _) defs = |
13732 | 576 |
let |
577 |
val (Us, T) = strip_type (fastype_of1 (Ts, t)); |
|
49960 | 578 |
val (corr_prf, defs') = corr d vs (t :: ts) Ts hs cs |
20664 | 579 |
(if member (op =) rtypes (tname_of T) then t' |
49960 | 580 |
else (case t' of SOME (u $ _) => SOME u | _ => NONE)) |
581 |
prf prf' defs; |
|
20664 | 582 |
val u = if not (member (op =) rtypes (tname_of T)) then t else |
13732 | 583 |
let |
16458 | 584 |
val eT = etype_of thy' vs Ts t; |
13732 | 585 |
val (r, Us') = if eT = nullT then (nullt, Us) else |
586 |
(Bound (length Us), eT :: Us); |
|
587 |
val u = list_comb (incr_boundvars (length Us') t, |
|
588 |
map Bound (length Us - 1 downto 0)); |
|
17271 | 589 |
val u' = (case AList.lookup (op =) types (tname_of T) of |
15531 | 590 |
SOME ((_, SOME f)) => f r eT u T |
13732 | 591 |
| _ => Const ("realizes", eT --> T --> T) $ r $ u) |
46219
426ed18eba43
discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents:
44057
diff
changeset
|
592 |
in app_rlz_rews Ts vs (fold_rev (Term.abs o pair "x") Us' u') end |
49960 | 593 |
in (corr_prf % SOME u, defs') end |
13402 | 594 |
|
49960 | 595 |
| corr d vs ts Ts hs cs t (prf1 %% prf2) (prf1' %% prf2') defs = |
13402 | 596 |
let |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
597 |
val prop = Proofterm.prop_of' hs prf2'; |
16458 | 598 |
val T = etype_of thy' vs Ts prop; |
49960 | 599 |
val (f, u, defs1) = if T = nullT then (t, NONE, defs) else |
13402 | 600 |
(case t of |
49960 | 601 |
SOME (f $ u) => (SOME f, SOME u, defs) |
13402 | 602 |
| _ => |
49960 | 603 |
let val (u, defs1) = extr d vs [] Ts hs prf2' defs |
604 |
in (NONE, SOME u, defs1) end) |
|
605 |
val ((corr_prf1, corr_prf2), defs2) = |
|
606 |
defs1 |
|
607 |
|> corr d vs [] Ts hs cs f prf1 prf1' |
|
608 |
||>> corr d vs [] Ts hs cs u prf2 prf2'; |
|
13402 | 609 |
in |
49960 | 610 |
if T = nullT then (corr_prf1 %% corr_prf2, defs2) else |
611 |
(corr_prf1 % u %% corr_prf2, defs2) |
|
13402 | 612 |
end |
613 |
||
70494 | 614 |
| corr d vs ts Ts hs cs _ (prf0 as PThm (thm_header as {types = SOME Ts', ...}, thm_body)) _ defs = |
13402 | 615 |
let |
70538
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
616 |
val {pos, theory_name, name, prop, ...} = thm_header; |
70493 | 617 |
val prf = Proofterm.thm_body_proof_open thm_body; |
13402 | 618 |
val (vs', tye) = find_inst prop Ts ts vs; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
619 |
val shyps = mk_shyps tye; |
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
620 |
val sprfs = mk_sprfs cs tye; |
36042
85efdadee8ae
switched PThm/PAxm etc. to use canonical order of type variables (term variables unchanged)
krauss
parents:
35985
diff
changeset
|
621 |
val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye; |
16458 | 622 |
val T = etype_of thy' vs' [] prop; |
13402 | 623 |
val defs' = if T = nullT then defs |
49960 | 624 |
else snd (extr d vs ts Ts hs prf0 defs) |
13402 | 625 |
in |
49960 | 626 |
if T = nullT andalso realizes_null vs' prop aconv prop then (prf0, defs) |
627 |
else (case Symtab.lookup realizers name of |
|
15531 | 628 |
NONE => (case find vs' (find' name defs') of |
629 |
NONE => |
|
13402 | 630 |
let |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
631 |
val _ = T = nullT orelse error "corr: internal error"; |
13402 | 632 |
val _ = msg d ("Building correctness proof for " ^ quote name ^ |
633 |
(if null vs' then "" |
|
634 |
else " (relevant variables: " ^ commas_quote vs' ^ ")")); |
|
70449 | 635 |
val prf' = prep (Proofterm.reconstruct_proof thy' prop prf); |
49960 | 636 |
val (corr_prf0, defs'') = corr (d + 1) vs' [] [] [] |
637 |
(rev shyps) NONE prf' prf' defs'; |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
638 |
val corr_prf = mkabsp shyps corr_prf0; |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
639 |
val corr_prop = Proofterm.prop_of corr_prf; |
70493 | 640 |
val corr_header = |
70577
ed651a58afe4
back to uniform serial (reverting 913b4afb6ac2): this allows to treat derivation id like name space entity id;
wenzelm
parents:
70538
diff
changeset
|
641 |
Proofterm.thm_header (serial ()) pos theory_name |
70538
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
642 |
(corr_name name vs') corr_prop |
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
643 |
(SOME (map TVar (Term.add_tvars corr_prop [] |> rev))); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
644 |
val corr_prf' = |
70493 | 645 |
Proofterm.proof_combP |
646 |
(Proofterm.proof_combt |
|
70589 | 647 |
(PThm (corr_header, make_proof_body corr_prf), vfs_of corr_prop), |
70493 | 648 |
map PBound (length shyps - 1 downto 0)) |> |
37310 | 649 |
fold_rev Proofterm.forall_intr_proof' |
650 |
(map (get_var_type corr_prop) (vfs_of prop)) |> |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
651 |
mkabsp shyps |
13402 | 652 |
in |
49960 | 653 |
(Proofterm.proof_combP (prf_subst_TVars tye' corr_prf', sprfs), |
654 |
(name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'') |
|
13402 | 655 |
end |
37310 | 656 |
| SOME (_, (_, prf')) => |
49960 | 657 |
(Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs')) |
15531 | 658 |
| SOME rs => (case find vs' rs of |
49960 | 659 |
SOME (_, prf') => (Proofterm.proof_combP (prf_subst_TVars tye' prf', sprfs), defs') |
15531 | 660 |
| NONE => error ("corr: no realizer for instance of theorem " ^ |
70449 | 661 |
quote name ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
662 |
(Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))))) |
13402 | 663 |
end |
664 |
||
49960 | 665 |
| corr d vs ts Ts hs cs _ (prf0 as PAxm (s, prop, SOME Ts')) _ defs = |
13402 | 666 |
let |
667 |
val (vs', tye) = find_inst prop Ts ts vs; |
|
36042
85efdadee8ae
switched PThm/PAxm etc. to use canonical order of type variables (term variables unchanged)
krauss
parents:
35985
diff
changeset
|
668 |
val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye |
13402 | 669 |
in |
16458 | 670 |
if etype_of thy' vs' [] prop = nullT andalso |
49960 | 671 |
realizes_null vs' prop aconv prop then (prf0, defs) |
18956 | 672 |
else case find vs' (Symtab.lookup_list realizers s) of |
49960 | 673 |
SOME (_, prf) => (Proofterm.proof_combP (prf_subst_TVars tye' prf, mk_sprfs cs tye), |
674 |
defs) |
|
15531 | 675 |
| NONE => error ("corr: no realizer for instance of axiom " ^ |
70449 | 676 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
677 |
(Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))) |
13402 | 678 |
end |
679 |
||
49960 | 680 |
| corr d vs ts Ts hs _ _ _ _ defs = error "corr: bad proof" |
13402 | 681 |
|
49960 | 682 |
and extr d vs ts Ts hs (PBound i) defs = (Bound i, defs) |
13402 | 683 |
|
49960 | 684 |
| extr d vs ts Ts hs (Abst (s, SOME T, prf)) defs = |
685 |
let val (t, defs') = extr d vs [] |
|
686 |
(T :: Ts) (dummyt :: hs) (Proofterm.incr_pboundvars 1 0 prf) defs |
|
687 |
in (Abs (s, T, t), defs') end |
|
13402 | 688 |
|
49960 | 689 |
| extr d vs ts Ts hs (AbsP (s, SOME t, prf)) defs = |
13402 | 690 |
let |
16458 | 691 |
val T = etype_of thy' vs Ts t; |
49960 | 692 |
val (t, defs') = |
693 |
extr d vs [] (T :: Ts) (t :: hs) (Proofterm.incr_pboundvars 0 1 prf) defs |
|
694 |
in |
|
695 |
(if T = nullT then subst_bound (nullt, t) else Abs (s, T, t), defs') |
|
13402 | 696 |
end |
697 |
||
49960 | 698 |
| extr d vs ts Ts hs (prf % SOME t) defs = |
699 |
let val (u, defs') = extr d vs (t :: ts) Ts hs prf defs |
|
700 |
in (if member (op =) rtypes (tname_of (body_type (fastype_of1 (Ts, t)))) then u |
|
701 |
else u $ t, defs') |
|
13732 | 702 |
end |
13402 | 703 |
|
49960 | 704 |
| extr d vs ts Ts hs (prf1 %% prf2) defs = |
13402 | 705 |
let |
49960 | 706 |
val (f, defs') = extr d vs [] Ts hs prf1 defs; |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
707 |
val prop = Proofterm.prop_of' hs prf2; |
16458 | 708 |
val T = etype_of thy' vs Ts prop |
13402 | 709 |
in |
49960 | 710 |
if T = nullT then (f, defs') else |
711 |
let val (t, defs'') = extr d vs [] Ts hs prf2 defs' |
|
712 |
in (f $ t, defs'') end |
|
13402 | 713 |
end |
714 |
||
70494 | 715 |
| extr d vs ts Ts hs (prf0 as PThm (thm_header as {types = SOME Ts', ...}, thm_body)) defs = |
13402 | 716 |
let |
70538
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
717 |
val {pos, theory_name, name = s, prop, ...} = thm_header; |
70493 | 718 |
val prf = Proofterm.thm_body_proof_open thm_body; |
13402 | 719 |
val (vs', tye) = find_inst prop Ts ts vs; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
720 |
val shyps = mk_shyps tye; |
36042
85efdadee8ae
switched PThm/PAxm etc. to use canonical order of type variables (term variables unchanged)
krauss
parents:
35985
diff
changeset
|
721 |
val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye |
13402 | 722 |
in |
17412 | 723 |
case Symtab.lookup realizers s of |
15531 | 724 |
NONE => (case find vs' (find' s defs) of |
725 |
NONE => |
|
13402 | 726 |
let |
727 |
val _ = msg d ("Extracting " ^ quote s ^ |
|
728 |
(if null vs' then "" |
|
729 |
else " (relevant variables: " ^ commas_quote vs' ^ ")")); |
|
70449 | 730 |
val prf' = prep (Proofterm.reconstruct_proof thy' prop prf); |
49960 | 731 |
val (t, defs') = extr (d + 1) vs' [] [] [] prf' defs; |
732 |
val (corr_prf, defs'') = corr (d + 1) vs' [] [] [] |
|
733 |
(rev shyps) (SOME t) prf' prf' defs'; |
|
13402 | 734 |
|
735 |
val nt = Envir.beta_norm t; |
|
20664 | 736 |
val args = filter_out (fn v => member (op =) rtypes |
737 |
(tname_of (body_type (fastype_of v)))) (vfs_of prop); |
|
33317 | 738 |
val args' = filter (fn v => Logic.occs (v, nt)) args; |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
739 |
val t' = mkabs args' nt; |
13402 | 740 |
val T = fastype_of t'; |
13732 | 741 |
val cname = extr_name s vs'; |
13402 | 742 |
val c = Const (cname, T); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
743 |
val u = mkabs args (list_comb (c, args')); |
13402 | 744 |
val eqn = Logic.mk_equals (c, t'); |
745 |
val rlz = |
|
746 |
Const ("realizes", fastype_of nt --> propT --> propT); |
|
13732 | 747 |
val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop); |
748 |
val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop); |
|
749 |
val f = app_rlz_rews [] vs' |
|
750 |
(Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop)); |
|
13402 | 751 |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
752 |
val corr_prf' = mkabsp shyps |
70806 | 753 |
(change_types [] Proofterm.equal_elim_axm %> lhs %> rhs %% |
754 |
(change_types [propT] Proofterm.symmetric_axm %> rhs %> lhs %% |
|
755 |
(change_types [T, propT] Proofterm.combination_axm %> f %> f %> c %> t' %% |
|
756 |
(change_types [T --> propT] Proofterm.reflexive_axm %> f) %% |
|
46909 | 757 |
PAxm (Thm.def_name cname, eqn, |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
758 |
SOME (map TVar (Term.add_tvars eqn [] |> rev))))) %% corr_prf); |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
759 |
val corr_prop = Proofterm.prop_of corr_prf'; |
70493 | 760 |
val corr_header = |
70577
ed651a58afe4
back to uniform serial (reverting 913b4afb6ac2): this allows to treat derivation id like name space entity id;
wenzelm
parents:
70538
diff
changeset
|
761 |
Proofterm.thm_header (serial ()) pos theory_name |
70538
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
762 |
(corr_name s vs') corr_prop |
fc9ba6fe367f
clarified PThm: theory_name simplifies retrieval from exports;
wenzelm
parents:
70501
diff
changeset
|
763 |
(SOME (map TVar (Term.add_tvars corr_prop [] |> rev))); |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
764 |
val corr_prf'' = |
37310 | 765 |
Proofterm.proof_combP (Proofterm.proof_combt |
70589 | 766 |
(PThm (corr_header, make_proof_body corr_prf), vfs_of corr_prop), |
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
767 |
map PBound (length shyps - 1 downto 0)) |> |
37310 | 768 |
fold_rev Proofterm.forall_intr_proof' |
769 |
(map (get_var_type corr_prop) (vfs_of prop)) |> |
|
37233
b78f31ca4675
Adapted to new format of proof terms containing explicit proofs of class membership.
berghofe
parents:
36953
diff
changeset
|
770 |
mkabsp shyps |
13402 | 771 |
in |
49960 | 772 |
(subst_TVars tye' u, |
773 |
(s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'') |
|
13402 | 774 |
end |
49960 | 775 |
| SOME ((_, u), _) => (subst_TVars tye' u, defs)) |
15531 | 776 |
| SOME rs => (case find vs' rs of |
49960 | 777 |
SOME (t, _) => (subst_TVars tye' t, defs) |
15531 | 778 |
| NONE => error ("extr: no realizer for instance of theorem " ^ |
70449 | 779 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
780 |
(Proofterm.prop_of (Proofterm.proof_combt (prf0, ts)))))) |
13402 | 781 |
end |
782 |
||
49960 | 783 |
| extr d vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) defs = |
13402 | 784 |
let |
785 |
val (vs', tye) = find_inst prop Ts ts vs; |
|
36042
85efdadee8ae
switched PThm/PAxm etc. to use canonical order of type variables (term variables unchanged)
krauss
parents:
35985
diff
changeset
|
786 |
val tye' = (map fst (Term.add_tvars prop [] |> rev) ~~ Ts') @ tye |
13402 | 787 |
in |
18956 | 788 |
case find vs' (Symtab.lookup_list realizers s) of |
49960 | 789 |
SOME (t, _) => (subst_TVars tye' t, defs) |
15531 | 790 |
| NONE => error ("extr: no realizer for instance of axiom " ^ |
70449 | 791 |
quote s ^ ":\n" ^ Syntax.string_of_term_global thy' (Envir.beta_norm |
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
792 |
(Proofterm.prop_of (Proofterm.proof_combt (prf0, ts))))) |
13402 | 793 |
end |
794 |
||
49960 | 795 |
| extr d vs ts Ts hs _ defs = error "extr: bad proof"; |
13402 | 796 |
|
60826 | 797 |
fun prep_thm vs raw_thm = |
13402 | 798 |
let |
60826 | 799 |
val thm = Thm.transfer thy raw_thm; |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
26481
diff
changeset
|
800 |
val prop = Thm.prop_of thm; |
28814 | 801 |
val prf = Thm.proof_of thm; |
36744
6e1f3d609a68
renamed Thm.get_name -> Thm.derivation_name and Thm.put_name -> Thm.name_derivation, to emphasize the true nature of these operations;
wenzelm
parents:
36620
diff
changeset
|
802 |
val name = Thm.derivation_name thm; |
21858
05f57309170c
avoid conflict with Alice keywords: renamed pack -> implode, unpack -> explode, any -> many, avoided assert;
wenzelm
parents:
21646
diff
changeset
|
803 |
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
|
804 |
val _ = etype_of thy' vs [] prop <> nullT orelse error ("theorem " ^ |
13402 | 805 |
quote name ^ " has no computational content") |
70449 | 806 |
in Proofterm.reconstruct_proof thy' prop prf end; |
13402 | 807 |
|
33245 | 808 |
val defs = |
58436 | 809 |
fold (fn (thm, vs) => snd o (extr 0 vs [] [] [] o prep_thm vs) thm) |
810 |
thm_vss []; |
|
13402 | 811 |
|
66145 | 812 |
fun add_def (s, (vs, ((t, u)))) thy = |
813 |
let |
|
814 |
val ft = Type.legacy_freeze t; |
|
815 |
val fu = Type.legacy_freeze u; |
|
66146
fd3e128b174f
register equations stemming from extracted proofs as specification rules
haftmann
parents:
66145
diff
changeset
|
816 |
val head = head_of (strip_abs_body fu); |
71179 | 817 |
val b = Binding.qualified_name (extr_name s vs); |
66145 | 818 |
in |
819 |
thy |
|
71179 | 820 |
|> Sign.add_consts [(b, fastype_of ft, NoSyn)] |
66145 | 821 |
|> Global_Theory.add_defs false |
822 |
[((Binding.qualified_name (Thm.def_name (extr_name s vs)), |
|
66146
fd3e128b174f
register equations stemming from extracted proofs as specification rules
haftmann
parents:
66145
diff
changeset
|
823 |
Logic.mk_equals (head, ft)), [])] |
fd3e128b174f
register equations stemming from extracted proofs as specification rules
haftmann
parents:
66145
diff
changeset
|
824 |
|-> (fn [def_thm] => |
71214
5727bcc3c47c
proper spec_rule name via naming/binding/Morphism.binding;
wenzelm
parents:
71206
diff
changeset
|
825 |
Spec_Rules.add_global b Spec_Rules.equational |
71206
20dce31fe7f4
proper spec rules via resulting def_thm, e.g. relevant for "isabelle build -o export_theory";
wenzelm
parents:
71179
diff
changeset
|
826 |
[Thm.term_of (Thm.lhs_of def_thm)] [def_thm] |
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
66146
diff
changeset
|
827 |
#> Code.declare_default_eqns_global [(def_thm, true)]) |
66145 | 828 |
end; |
829 |
||
830 |
fun add_corr (s, (vs, prf)) thy = |
|
831 |
let |
|
70447
755d58b48cec
clarified modules: provide reconstruct_proof / expand_proof at the bottom of proof term construction;
wenzelm
parents:
70436
diff
changeset
|
832 |
val corr_prop = Proofterm.prop_of prf; |
66145 | 833 |
in |
834 |
thy |
|
835 |
|> Global_Theory.store_thm (Binding.qualified_name (corr_name s vs), |
|
836 |
Thm.varifyT_global (funpow (length (vars_of corr_prop)) |
|
837 |
(Thm.forall_elim_var 0) (Thm.forall_intr_frees |
|
838 |
(Proof_Checker.thm_of_proof thy |
|
839 |
(fst (Proofterm.freeze_thaw_prf prf)))))) |
|
840 |
|> snd |
|
841 |
end; |
|
842 |
||
843 |
fun add_def_and_corr (s, (vs, ((t, u), (prf, _)))) thy = |
|
844 |
if is_none (Sign.const_type thy (extr_name s vs)) |
|
845 |
then |
|
846 |
thy |
|
847 |
|> not (t = nullt) ? add_def (s, (vs, ((t, u)))) |
|
848 |
|> add_corr (s, (vs, prf)) |
|
849 |
else |
|
850 |
thy; |
|
13402 | 851 |
|
16149 | 852 |
in |
853 |
thy |
|
30435
e62d6ecab6ad
explicit Binding.qualified_name -- prevents implicitly qualified bstring;
wenzelm
parents:
30364
diff
changeset
|
854 |
|> Sign.root_path |
66145 | 855 |
|> fold_rev add_def_and_corr defs |
22796 | 856 |
|> Sign.restore_naming thy |
13402 | 857 |
end; |
858 |
||
16458 | 859 |
val etype_of = etype_of o add_syntax; |
13714 | 860 |
|
13402 | 861 |
end; |