2 ID: $Id$ |
2 ID: $Id$ |
3 Author: Markus Wenzel, TU Muenchen |
3 Author: Markus Wenzel, TU Muenchen |
4 |
4 |
5 The key concept of Isar proof contexts: elevates primitive local |
5 The key concept of Isar proof contexts: elevates primitive local |
6 reasoning Gamma |- phi to a structured concept, with generic context |
6 reasoning Gamma |- phi to a structured concept, with generic context |
7 elements. |
7 elements. See also structure Variable and Assumption. |
8 *) |
8 *) |
9 |
9 |
10 signature PROOF_CONTEXT = |
10 signature PROOF_CONTEXT = |
11 sig |
11 sig |
12 type context (*= Context.proof*) |
12 type context (*= Context.proof*) |
13 type export |
|
14 val theory_of: context -> theory |
13 val theory_of: context -> theory |
15 val init: theory -> context |
14 val init: theory -> context |
16 val full_name: context -> bstring -> string |
15 val full_name: context -> bstring -> string |
17 val consts_of: context -> Consts.T |
16 val consts_of: context -> Consts.T |
18 val set_syntax_mode: string * bool -> context -> context |
17 val set_syntax_mode: string * bool -> context -> context |
19 val restore_syntax_mode: context -> context -> context |
18 val restore_syntax_mode: context -> context -> context |
20 val assms_of: context -> term list |
|
21 val prems_of: context -> thm list |
|
22 val fact_index_of: context -> FactIndex.T |
19 val fact_index_of: context -> FactIndex.T |
23 val transfer: theory -> context -> context |
20 val transfer: theory -> context -> context |
24 val map_theory: (theory -> theory) -> context -> context |
21 val map_theory: (theory -> theory) -> context -> context |
25 val pretty_term: context -> term -> Pretty.T |
22 val pretty_term: context -> term -> Pretty.T |
26 val pretty_typ: context -> typ -> Pretty.T |
23 val pretty_typ: context -> typ -> Pretty.T |
27 val pretty_sort: context -> sort -> Pretty.T |
24 val pretty_sort: context -> sort -> Pretty.T |
28 val pretty_classrel: context -> class list -> Pretty.T |
25 val pretty_classrel: context -> class list -> Pretty.T |
29 val pretty_arity: context -> arity -> Pretty.T |
26 val pretty_arity: context -> arity -> Pretty.T |
30 val pp: context -> Pretty.pp |
27 val pp: context -> Pretty.pp |
|
28 val legacy_pretty_thm: bool -> thm -> Pretty.T |
31 val pretty_thm: context -> thm -> Pretty.T |
29 val pretty_thm: context -> thm -> Pretty.T |
32 val pretty_thms: context -> thm list -> Pretty.T |
30 val pretty_thms: context -> thm list -> Pretty.T |
33 val pretty_fact: context -> string * thm list -> Pretty.T |
31 val pretty_fact: context -> string * thm list -> Pretty.T |
34 val pretty_proof: context -> Proofterm.proof -> Pretty.T |
32 val pretty_proof: context -> Proofterm.proof -> Pretty.T |
35 val pretty_proof_of: context -> bool -> thm -> Pretty.T |
33 val pretty_proof_of: context -> bool -> thm -> Pretty.T |
125 val add_fixes_i: (string * typ option * mixfix) list -> context -> string list * context |
123 val add_fixes_i: (string * typ option * mixfix) list -> context -> string list * context |
126 val add_fixes_legacy: (string * typ option * mixfix) list -> context -> string list * context |
124 val add_fixes_legacy: (string * typ option * mixfix) list -> context -> string list * context |
127 val fix_frees: term -> context -> context |
125 val fix_frees: term -> context -> context |
128 val auto_fixes: context * (term list list * 'a) -> context * (term list list * 'a) |
126 val auto_fixes: context * (term list list * 'a) -> context * (term list list * 'a) |
129 val bind_fixes: string list -> context -> (term -> term) * context |
127 val bind_fixes: string list -> context -> (term -> term) * context |
130 val assume_export: export |
128 val add_assms: Assumption.export -> |
131 val presume_export: export |
|
132 val add_assumes: cterm list -> context -> thm list * context |
|
133 val add_assms: export -> |
|
134 ((string * attribute list) * (string * string list) list) list -> |
129 ((string * attribute list) * (string * string list) list) list -> |
135 context -> (bstring * thm list) list * context |
130 context -> (bstring * thm list) list * context |
136 val add_assms_i: export -> |
131 val add_assms_i: Assumption.export -> |
137 ((string * attribute list) * (term * term list) list) list -> |
132 ((string * attribute list) * (term * term list) list) list -> |
138 context -> (bstring * thm list) list * context |
133 context -> (bstring * thm list) list * context |
139 val add_view: context -> cterm list -> context -> context |
|
140 val export_view: cterm list -> context -> context -> thm -> thm |
|
141 val add_cases: bool -> (string * RuleCases.T option) list -> context -> context |
134 val add_cases: bool -> (string * RuleCases.T option) list -> context -> context |
142 val apply_case: RuleCases.T -> context -> (string * term list) list * context |
135 val apply_case: RuleCases.T -> context -> (string * term list) list * context |
143 val get_case: context -> string -> string option list -> RuleCases.T |
136 val get_case: context -> string -> string option list -> RuleCases.T |
144 val expand_abbrevs: bool -> context -> context |
137 val expand_abbrevs: bool -> context -> context |
145 val add_const_syntax: string * bool -> (string * mixfix) list -> context -> context |
138 val add_const_syntax: string * bool -> (string * mixfix) list -> context -> context |
167 |
160 |
168 |
161 |
169 |
162 |
170 (** Isar proof context information **) |
163 (** Isar proof context information **) |
171 |
164 |
172 type export = bool -> cterm list -> thm -> thm Seq.seq; |
|
173 |
|
174 datatype ctxt = |
165 datatype ctxt = |
175 Ctxt of |
166 Ctxt of |
176 {naming: NameSpace.naming, (*local naming conventions*) |
167 {naming: NameSpace.naming, (*local naming conventions*) |
177 syntax: LocalSyntax.T, (*local syntax*) |
168 syntax: LocalSyntax.T, (*local syntax*) |
178 consts: Consts.T * Consts.T, (*global/local consts*) |
169 consts: Consts.T * Consts.T, (*global/local consts*) |
179 assms: |
|
180 ((cterm list * export) list * (*assumes and views: A ==> _*) |
|
181 thm list), (*prems: A |- A*) |
|
182 thms: thm list NameSpace.table * FactIndex.T, (*local thms*) |
170 thms: thm list NameSpace.table * FactIndex.T, (*local thms*) |
183 cases: (string * (RuleCases.T * bool)) list}; (*local contexts*) |
171 cases: (string * (RuleCases.T * bool)) list}; (*local contexts*) |
184 |
172 |
185 fun make_ctxt (naming, syntax, consts, assms, thms, cases) = |
173 fun make_ctxt (naming, syntax, consts, thms, cases) = |
186 Ctxt {naming = naming, syntax = syntax, consts = consts, assms = assms, |
174 Ctxt {naming = naming, syntax = syntax, consts = consts, thms = thms, cases = cases}; |
187 thms = thms, cases = cases}; |
|
188 |
175 |
189 val local_naming = NameSpace.default_naming |> NameSpace.add_path "local"; |
176 val local_naming = NameSpace.default_naming |> NameSpace.add_path "local"; |
190 |
177 |
191 structure ContextData = ProofDataFun |
178 structure ContextData = ProofDataFun |
192 ( |
179 ( |
193 val name = "Isar/context"; |
180 val name = "Isar/context"; |
194 type T = ctxt; |
181 type T = ctxt; |
195 fun init thy = |
182 fun init thy = |
196 make_ctxt (local_naming, LocalSyntax.init thy, |
183 make_ctxt (local_naming, LocalSyntax.init thy, |
197 (Sign.consts_of thy, Sign.consts_of thy), ([], []), |
184 (Sign.consts_of thy, Sign.consts_of thy), |
198 (NameSpace.empty_table, FactIndex.empty), []); |
185 (NameSpace.empty_table, FactIndex.empty), []); |
199 fun print _ _ = (); |
186 fun print _ _ = (); |
200 ); |
187 ); |
201 |
188 |
202 val _ = Context.add_setup ContextData.init; |
189 val _ = Context.add_setup ContextData.init; |
203 |
190 |
204 fun rep_context ctxt = ContextData.get ctxt |> (fn Ctxt args => args); |
191 fun rep_context ctxt = ContextData.get ctxt |> (fn Ctxt args => args); |
205 |
192 |
206 fun map_context f = |
193 fun map_context f = |
207 ContextData.map (fn Ctxt {naming, syntax, consts, assms, thms, cases} => |
194 ContextData.map (fn Ctxt {naming, syntax, consts, thms, cases} => |
208 make_ctxt (f (naming, syntax, consts, assms, thms, cases))); |
195 make_ctxt (f (naming, syntax, consts, thms, cases))); |
209 |
196 |
210 fun map_naming f = |
197 fun map_naming f = |
211 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
198 map_context (fn (naming, syntax, consts, thms, cases) => |
212 (f naming, syntax, consts, assms, thms, cases)); |
199 (f naming, syntax, consts, thms, cases)); |
213 |
200 |
214 fun map_syntax f = |
201 fun map_syntax f = |
215 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
202 map_context (fn (naming, syntax, consts, thms, cases) => |
216 (naming, f syntax, consts, assms, thms, cases)); |
203 (naming, f syntax, consts, thms, cases)); |
217 |
204 |
218 fun map_consts f = |
205 fun map_consts f = |
219 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
206 map_context (fn (naming, syntax, consts, thms, cases) => |
220 (naming, syntax, f consts, assms, thms, cases)); |
207 (naming, syntax, f consts, thms, cases)); |
221 |
|
222 fun map_assms f = |
|
223 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
|
224 (naming, syntax, consts, f assms, thms, cases)); |
|
225 |
208 |
226 fun map_thms f = |
209 fun map_thms f = |
227 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
210 map_context (fn (naming, syntax, consts, thms, cases) => |
228 (naming, syntax, consts, assms, f thms, cases)); |
211 (naming, syntax, consts, f thms, cases)); |
229 |
212 |
230 fun map_cases f = |
213 fun map_cases f = |
231 map_context (fn (naming, syntax, consts, assms, thms, cases) => |
214 map_context (fn (naming, syntax, consts, thms, cases) => |
232 (naming, syntax, consts, assms, thms, f cases)); |
215 (naming, syntax, consts, thms, f cases)); |
233 |
216 |
234 val naming_of = #naming o rep_context; |
217 val naming_of = #naming o rep_context; |
235 val full_name = NameSpace.full o naming_of; |
218 val full_name = NameSpace.full o naming_of; |
236 |
219 |
237 val syntax_of = #syntax o rep_context; |
220 val syntax_of = #syntax o rep_context; |
238 val syn_of = LocalSyntax.syn_of o syntax_of; |
221 val syn_of = LocalSyntax.syn_of o syntax_of; |
239 val set_syntax_mode = map_syntax o LocalSyntax.set_mode; |
222 val set_syntax_mode = map_syntax o LocalSyntax.set_mode; |
240 val restore_syntax_mode = map_syntax o LocalSyntax.restore_mode o syntax_of; |
223 val restore_syntax_mode = map_syntax o LocalSyntax.restore_mode o syntax_of; |
241 |
224 |
242 val consts_of = #2 o #consts o rep_context; |
225 val consts_of = #2 o #consts o rep_context; |
243 |
|
244 val assumptions_of = #1 o #assms o rep_context; |
|
245 val assms_of = map Thm.term_of o maps #1 o assumptions_of; |
|
246 val prems_of = #2 o #assms o rep_context; |
|
247 |
226 |
248 val thms_of = #thms o rep_context; |
227 val thms_of = #thms o rep_context; |
249 val fact_index_of = #2 o thms_of; |
228 val fact_index_of = #2 o thms_of; |
250 |
229 |
251 val cases_of = #cases o rep_context; |
230 val cases_of = #cases o rep_context; |
957 |
937 |
958 |
938 |
959 |
939 |
960 (** assumptions **) |
940 (** assumptions **) |
961 |
941 |
962 (* basic exports *) |
|
963 |
|
964 (* |
|
965 [A] |
|
966 : |
|
967 B |
|
968 -------- |
|
969 #A ==> B |
|
970 *) |
|
971 fun assume_export true = Seq.single oo Drule.implies_intr_protected |
|
972 | assume_export false = Seq.single oo Drule.implies_intr_list; |
|
973 |
|
974 (* |
|
975 [A] |
|
976 : |
|
977 B |
|
978 ------- |
|
979 A ==> B |
|
980 *) |
|
981 fun presume_export _ = assume_export false; |
|
982 |
|
983 |
|
984 (* plain assumptions *) |
|
985 |
|
986 fun new_prems new_asms new_prems = |
|
987 map_assms (fn (asms, prems) => (asms @ [new_asms], prems @ new_prems)) #> |
|
988 (fn ctxt => put_thms_internal (AutoBind.premsN, SOME (prems_of ctxt)) ctxt); |
|
989 |
|
990 fun add_assumes asms = |
|
991 let val prems = map (Goal.norm_hhf o Thm.assume) asms |
|
992 in new_prems (asms, assume_export) prems #> pair prems end; |
|
993 |
|
994 |
|
995 (* generic assms *) |
|
996 |
|
997 local |
942 local |
998 |
943 |
999 fun gen_assm ((name, attrs), props) ctxt = |
|
1000 let |
|
1001 val cprops = map (Thm.cterm_of (theory_of ctxt)) props; |
|
1002 val prems = map (Goal.norm_hhf o Thm.assume) cprops; |
|
1003 val ([(_, thms)], ctxt') = |
|
1004 ctxt |
|
1005 |> auto_bind_facts props |
|
1006 |> note_thmss_i [((name, attrs), map (fn th => ([th], [])) prems)]; |
|
1007 in ((cprops, prems, (name, thms)), ctxt') end; |
|
1008 |
|
1009 fun gen_assms prepp exp args ctxt = |
944 fun gen_assms prepp exp args ctxt = |
1010 let |
945 let |
|
946 val cert = Thm.cterm_of (theory_of ctxt); |
1011 val (propss, ctxt1) = swap (prepp (ctxt, map snd args)); |
947 val (propss, ctxt1) = swap (prepp (ctxt, map snd args)); |
1012 val (results, ctxt2) = fold_map gen_assm (map fst args ~~ propss) ctxt1; |
948 val _ = Variable.warn_extra_tfrees ctxt ctxt1; |
1013 val ctxt3 = new_prems (maps #1 results, exp) (maps #2 results) ctxt2; |
949 val (premss, ctxt2) = fold_burrow (Assumption.add_assms exp o map cert) propss ctxt1; |
1014 in (map #3 results, tap (Variable.warn_extra_tfrees ctxt) ctxt3) end; |
950 in |
|
951 ctxt2 |
|
952 |> auto_bind_facts (flat propss) |
|
953 |> put_thms_internal (AutoBind.premsN, SOME (Assumption.prems_of ctxt2)) |
|
954 |> note_thmss_i (map fst args ~~ map (map (fn th => ([th], []))) premss) |
|
955 end; |
1015 |
956 |
1016 in |
957 in |
1017 |
958 |
1018 val add_assms = gen_assms (apsnd #1 o bind_propp); |
959 val add_assms = gen_assms (apsnd #1 o bind_propp); |
1019 val add_assms_i = gen_assms (apsnd #1 o bind_propp_i); |
960 val add_assms_i = gen_assms (apsnd #1 o bind_propp_i); |
1020 |
961 |
1021 end; |
962 end; |
1022 |
|
1023 |
|
1024 (* additional views *) |
|
1025 |
|
1026 fun add_view outer view = map_assms (fn (asms, prems) => |
|
1027 let |
|
1028 val (asms1, asms2) = chop (length (assumptions_of outer)) asms; |
|
1029 val asms' = asms1 @ [(view, assume_export)] @ asms2; |
|
1030 in (asms', prems) end); |
|
1031 |
|
1032 fun export_view view inner outer = singleton (export_standard (add_view outer view inner) outer); |
|
1033 |
963 |
1034 |
964 |
1035 |
965 |
1036 (** cases **) |
966 (** cases **) |
1037 |
967 |