50 val declare_terms: term list -> context -> context |
40 val declare_terms: term list -> context -> context |
51 val warn_extra_tfrees: context -> context -> context |
41 val warn_extra_tfrees: context -> context -> context |
52 val generalizeT: context -> context -> typ -> typ |
42 val generalizeT: context -> context -> typ -> typ |
53 val generalize: context -> context -> term -> term |
43 val generalize: context -> context -> term -> term |
54 val find_free: term -> string -> term option |
44 val find_free: term -> string -> term option |
55 val norm_hhf: thm -> thm |
|
56 val export_wrt: bool -> context -> context option -> (thm -> thm Seq.seq) * (int -> tactic) list |
45 val export_wrt: bool -> context -> context option -> (thm -> thm Seq.seq) * (int -> tactic) list |
|
46 val drop_schematic: indexname * term option -> indexname * term option |
|
47 val add_binds: (indexname * string option) list -> context -> context |
|
48 val add_binds_i: (indexname * term option) list -> context -> context |
57 val auto_bind_goal: term -> context -> context |
49 val auto_bind_goal: term -> context -> context |
58 val auto_bind_facts: string -> term list -> context -> context |
50 val auto_bind_facts: string -> term list -> context -> context |
59 val match_bind: bool -> (string list * string) list -> context -> context |
51 val match_bind: bool -> (string list * string) list -> context -> context |
60 val match_bind_i: bool -> (term list * term) list -> context -> context |
52 val match_bind_i: bool -> (term list * term) list -> context -> context |
61 val read_propp: context * (string * (string list * string list)) list list |
53 val read_propp: context * (string * (string list * string list)) list list |
148 |
152 |
149 fun theory_of (Context {thy, ...}) = thy; |
153 fun theory_of (Context {thy, ...}) = thy; |
150 val sign_of = Theory.sign_of o theory_of; |
154 val sign_of = Theory.sign_of o theory_of; |
151 |
155 |
152 fun prems_of (Context {asms = ((_, asms), _), ...}) = flat (map #2 asms); |
156 fun prems_of (Context {asms = ((_, asms), _), ...}) = flat (map #2 asms); |
153 |
|
154 |
|
155 |
|
156 (** print context information **) |
|
157 |
|
158 val show_hyps = ref false; |
|
159 |
|
160 fun pretty_thm thm = |
|
161 if ! show_hyps then setmp Display.show_hyps true Display.pretty_thm_no_quote thm |
|
162 else Display.pretty_cterm (#prop (Thm.crep_thm thm)); |
|
163 |
|
164 val verbose = ref false; |
|
165 fun verb f x = if ! verbose then f (x ()) else []; |
|
166 fun verb_single x = verb Library.single x; |
|
167 |
|
168 fun setmp_verbose f x = Library.setmp verbose true f x; |
|
169 |
|
170 fun pretty_items prt name items = |
|
171 let |
|
172 fun prt_itms (name, [x]) = Pretty.block [Pretty.str (name ^ ":"), Pretty.brk 1, prt x] |
|
173 | prt_itms (name, xs) = Pretty.big_list (name ^ ":") (map prt xs); |
|
174 in |
|
175 if null items andalso not (! verbose) then [] |
|
176 else [Pretty.big_list name (map prt_itms items)] |
|
177 end; |
|
178 |
|
179 |
|
180 (* term bindings *) |
|
181 |
|
182 val smash_option = fn (_, None) => None | (xi, Some b) => Some (xi, b); |
|
183 |
|
184 fun pretty_binds (ctxt as Context {binds, ...}) = |
|
185 let |
|
186 val prt_term = Sign.pretty_term (sign_of ctxt); |
|
187 fun prt_bind (xi, (t, T)) = prt_term (Logic.mk_equals (Var (xi, T), t)); |
|
188 val bs = mapfilter smash_option (Vartab.dest binds); |
|
189 in |
|
190 if null bs andalso not (! verbose) then [] |
|
191 else [Pretty.big_list "term bindings:" (map prt_bind bs)] |
|
192 end; |
|
193 |
|
194 val print_binds = Pretty.writeln o Pretty.chunks o pretty_binds; |
|
195 |
|
196 |
|
197 (* local theorems *) |
|
198 |
|
199 fun pretty_thms (Context {thms, ...}) = |
|
200 pretty_items pretty_thm "facts:" (mapfilter smash_option (Symtab.dest thms)); |
|
201 |
|
202 val print_thms = Pretty.writeln o Pretty.chunks o pretty_thms; |
|
203 |
|
204 |
|
205 (* local contexts *) |
|
206 |
|
207 fun pretty_cases (ctxt as Context {cases, ...}) = |
|
208 let |
|
209 val prt_term = Sign.pretty_term (sign_of ctxt); |
|
210 |
|
211 fun prt_sect _ _ [] = [] |
|
212 | prt_sect s prt xs = [Pretty.block (Pretty.breaks (Pretty.str s :: map prt xs))]; |
|
213 |
|
214 fun prt_case (name, (xs, ts)) = Pretty.block (Pretty.breaks |
|
215 (Pretty.str (name ^ ":") :: |
|
216 prt_sect "fix" (prt_term o Free) xs @ |
|
217 prt_sect "assume" (Pretty.quote o prt_term) ts)); |
|
218 |
|
219 val cases' = rev (Library.gen_distinct Library.eq_fst cases); |
|
220 in |
|
221 if null cases andalso not (! verbose) then [] |
|
222 else [Pretty.big_list "cases:" (map prt_case cases')] |
|
223 end; |
|
224 |
|
225 val print_cases = Pretty.writeln o Pretty.chunks o pretty_cases; |
|
226 |
|
227 |
|
228 (* prems *) |
|
229 |
|
230 val prems_limit = ref 10; |
|
231 |
|
232 fun pretty_prems ctxt = |
|
233 let |
|
234 val limit = ! prems_limit; |
|
235 val prems = prems_of ctxt; |
|
236 val len = length prems; |
|
237 val prt_prems = |
|
238 (if len <= limit then [] else [Pretty.str "..."]) @ |
|
239 map pretty_thm (Library.drop (len - limit, prems)); |
|
240 in if null prems then [] else [Pretty.big_list "prems:" prt_prems] end; |
|
241 |
|
242 |
|
243 (* main context *) |
|
244 |
|
245 fun pretty_context (ctxt as Context {asms = (_, (fixes, _)), cases, |
|
246 defs = (types, sorts, (used, _)), ...}) = |
|
247 let |
|
248 val sign = sign_of ctxt; |
|
249 |
|
250 val prt_term = Sign.pretty_term sign; |
|
251 val prt_typ = Sign.pretty_typ sign; |
|
252 val prt_sort = Sign.pretty_sort sign; |
|
253 |
|
254 (*theory*) |
|
255 val pretty_thy = Pretty.block [Pretty.str "Theory:", Pretty.brk 1, Sign.pretty_sg sign]; |
|
256 |
|
257 (*fixes*) |
|
258 fun prt_fix (x, x') = Pretty.block |
|
259 [prt_term (Syntax.free x), Pretty.str " =", Pretty.brk 1, prt_term (Syntax.free x')]; |
|
260 |
|
261 fun prt_fixes [] = [] |
|
262 | prt_fixes xs = [Pretty.block (Pretty.str "fixed variables:" :: Pretty.brk 1 :: |
|
263 Pretty.commas (map prt_fix xs))]; |
|
264 |
|
265 (*defaults*) |
|
266 fun prt_atom prt prtT (x, X) = Pretty.block |
|
267 [prt x, Pretty.str " ::", Pretty.brk 1, prtT X]; |
|
268 |
|
269 fun prt_var (x, ~1) = prt_term (Syntax.free x) |
|
270 | prt_var xi = prt_term (Syntax.var xi); |
|
271 |
|
272 fun prt_varT (x, ~1) = prt_typ (TFree (x, [])) |
|
273 | prt_varT xi = prt_typ (TVar (xi, [])); |
|
274 |
|
275 val prt_defT = prt_atom prt_var prt_typ; |
|
276 val prt_defS = prt_atom prt_varT prt_sort; |
|
277 in |
|
278 verb_single (K pretty_thy) @ |
|
279 prt_fixes (rev (filter_out (can Syntax.dest_internal o #1) fixes)) @ |
|
280 pretty_prems ctxt @ |
|
281 verb pretty_binds (K ctxt) @ |
|
282 verb pretty_thms (K ctxt) @ |
|
283 verb pretty_cases (K ctxt) @ |
|
284 verb_single (fn () => Pretty.big_list "type constraints:" (map prt_defT (Vartab.dest types))) @ |
|
285 verb_single (fn () => Pretty.big_list "default sorts:" (map prt_defS (Vartab.dest sorts))) @ |
|
286 verb_single (fn () => Pretty.strs ("used type variable names:" :: used)) |
|
287 end; |
|
288 |
157 |
289 |
158 |
290 |
159 |
291 (** user data **) |
160 (** user data **) |
292 |
161 |
708 fun get_free x (None, t as Free (y, _)) = if x = y then Some t else None |
577 fun get_free x (None, t as Free (y, _)) = if x = y then Some t else None |
709 | get_free _ (opt, _) = opt; |
578 | get_free _ (opt, _) = opt; |
710 |
579 |
711 fun find_free t x = foldl_aterms (get_free x) (None, t); |
580 fun find_free t x = foldl_aterms (get_free x) (None, t); |
712 |
581 |
713 val norm_hhf = |
|
714 Drule.forall_elim_vars_safe o Tactic.rewrite_rule [Drule.norm_hhf_eq]; |
|
715 |
|
716 |
582 |
717 local |
583 local |
718 |
584 |
719 fun export tfrees fixes goal_asms thm = |
585 fun export tfrees fixes goal_asms thm = |
720 thm |
586 thm |
721 |> norm_hhf |
587 |> Tactic.norm_hhf |
722 |> Seq.EVERY (rev (map op |> goal_asms)) |
588 |> Seq.EVERY (rev (map op |> goal_asms)) |
723 |> Seq.map (fn rule => |
589 |> Seq.map (fn rule => |
724 let |
590 let |
725 val {sign, prop, maxidx, ...} = Thm.rep_thm rule; |
591 val {sign, prop, maxidx, ...} = Thm.rep_thm rule; |
726 val frees = map (Thm.cterm_of sign) (mapfilter (find_free prop) fixes); |
592 val frees = map (Thm.cterm_of sign) (mapfilter (find_free prop) fixes); |
727 in |
593 in |
728 rule |
594 rule |
729 |> Drule.forall_intr_list frees |
595 |> Drule.forall_intr_list frees |
730 |> norm_hhf |
596 |> Tactic.norm_hhf |
731 |> Drule.tvars_intr_list tfrees |
597 |> Drule.tvars_intr_list tfrees |
732 end); |
598 end); |
733 |
599 |
734 fun diff_context inner None = (gen_tfrees inner None, fixed_names inner, assumptions inner) |
600 fun diff_context inner None = (gen_tfrees inner None, fixed_names inner, assumptions inner) |
735 | diff_context inner (Some outer) = |
601 | diff_context inner (Some outer) = |
1083 |
949 |
1084 |
950 |
1085 |
951 |
1086 (** cases **) |
952 (** cases **) |
1087 |
953 |
1088 fun check_case ctxt name (xs, ts) = |
954 fun check_case ctxt name {fixes, assumes, binds} = |
1089 if null (foldr Term.add_typ_tvars (map snd xs, [])) andalso |
955 if null (foldr Term.add_typ_tvars (map snd fixes, [])) andalso |
1090 null (foldr Term.add_term_vars (ts, [])) then () |
956 null (foldr Term.add_term_vars (assumes, [])) then |
|
957 {fixes = fixes, assumes = assumes, binds = map drop_schematic binds} |
1091 else raise CONTEXT ("Illegal schematic variable(s) in case " ^ quote name, ctxt); |
958 else raise CONTEXT ("Illegal schematic variable(s) in case " ^ quote name, ctxt); |
1092 |
959 |
1093 fun get_case (ctxt as Context {cases, ...}) name = |
960 fun get_case (ctxt as Context {cases, ...}) name = |
1094 (case assoc (cases, name) of |
961 (case assoc (cases, name) of |
1095 None => raise CONTEXT ("Unknown case: " ^ quote name, ctxt) |
962 None => raise CONTEXT ("Unknown case: " ^ quote name, ctxt) |
1096 | Some c => (check_case ctxt name c; c)); |
963 | Some c => check_case ctxt name c); |
1097 |
964 |
1098 |
965 |
1099 fun add_cases xs = map_context (fn (thy, data, asms, binds, thms, cases, defs) => |
966 fun add_cases xs = map_context (fn (thy, data, asms, binds, thms, cases, defs) => |
1100 (thy, data, asms, binds, thms, rev (filter_out (equal "" o #1) xs) @ cases, defs)); |
967 (thy, data, asms, binds, thms, rev (filter_out (equal "" o #1) xs) @ cases, defs)); |
1101 |
968 |
1102 |
969 |
1103 |
970 |
|
971 (** print context information **) |
|
972 |
|
973 val show_hyps = ref false; |
|
974 |
|
975 fun pretty_thm thm = |
|
976 if ! show_hyps then setmp Display.show_hyps true Display.pretty_thm_no_quote thm |
|
977 else Display.pretty_cterm (#prop (Thm.crep_thm thm)); |
|
978 |
|
979 val verbose = ref false; |
|
980 fun verb f x = if ! verbose then f (x ()) else []; |
|
981 fun verb_single x = verb Library.single x; |
|
982 |
|
983 fun setmp_verbose f x = Library.setmp verbose true f x; |
|
984 |
|
985 fun pretty_items prt name items = |
|
986 let |
|
987 fun prt_itms (name, [x]) = Pretty.block [Pretty.str (name ^ ":"), Pretty.brk 1, prt x] |
|
988 | prt_itms (name, xs) = Pretty.big_list (name ^ ":") (map prt xs); |
|
989 in |
|
990 if null items andalso not (! verbose) then [] |
|
991 else [Pretty.big_list name (map prt_itms items)] |
|
992 end; |
|
993 |
|
994 |
|
995 (* term bindings *) |
|
996 |
|
997 val smash_option = fn (_, None) => None | (xi, Some b) => Some (xi, b); |
|
998 |
|
999 fun pretty_binds (ctxt as Context {binds, ...}) = |
|
1000 let |
|
1001 val prt_term = Sign.pretty_term (sign_of ctxt); |
|
1002 fun prt_bind (xi, (t, T)) = prt_term (Logic.mk_equals (Var (xi, T), t)); |
|
1003 val bs = mapfilter smash_option (Vartab.dest binds); |
|
1004 in |
|
1005 if null bs andalso not (! verbose) then [] |
|
1006 else [Pretty.big_list "term bindings:" (map prt_bind bs)] |
|
1007 end; |
|
1008 |
|
1009 val print_binds = Pretty.writeln o Pretty.chunks o pretty_binds; |
|
1010 |
|
1011 |
|
1012 (* local theorems *) |
|
1013 |
|
1014 fun pretty_thms (Context {thms, ...}) = |
|
1015 pretty_items pretty_thm "facts:" (mapfilter smash_option (Symtab.dest thms)); |
|
1016 |
|
1017 val print_thms = Pretty.writeln o Pretty.chunks o pretty_thms; |
|
1018 |
|
1019 |
|
1020 (* local contexts *) |
|
1021 |
|
1022 fun apply_case ctxt ({fixes, assumes, binds}: RuleCases.T) = |
|
1023 let |
|
1024 val xs = map (bind_skolem ctxt (map #1 fixes) o Free) fixes; |
|
1025 fun app t = foldl Term.betapply (t, xs); |
|
1026 in (fixes, map (apsnd (apsome app)) binds, map app assumes) end; |
|
1027 |
|
1028 fun pretty_cases (ctxt as Context {cases, ...}) = |
|
1029 let |
|
1030 val prt_term = Sign.pretty_term (sign_of ctxt); |
|
1031 fun prt_let (xi, t) = Pretty.block |
|
1032 [prt_term (Var (xi, Term.fastype_of t)), Pretty.str " =", Pretty.brk 1, |
|
1033 Pretty.quote (prt_term t)]; |
|
1034 |
|
1035 fun prt_sect _ _ _ [] = [] |
|
1036 | prt_sect s sep prt xs = [Pretty.block (Pretty.breaks (Pretty.str s :: |
|
1037 flat (Library.separate sep (map (Library.single o prt) xs))))]; |
|
1038 |
|
1039 fun prt_case (name, (xs, lets, asms)) = Pretty.block (Pretty.fbreaks |
|
1040 (Pretty.str (name ^ ":") :: |
|
1041 prt_sect "fix" [] (prt_term o Free) xs @ |
|
1042 prt_sect "let" [Pretty.str "and"] prt_let |
|
1043 (mapfilter (fn (xi, Some t) => Some (xi, t) | _ => None) lets) @ |
|
1044 prt_sect "assume" [] (Pretty.quote o prt_term) asms)); |
|
1045 |
|
1046 val cases' = rev (Library.gen_distinct Library.eq_fst cases); |
|
1047 in |
|
1048 if null cases andalso not (! verbose) then [] |
|
1049 else [Pretty.big_list "cases:" (map (prt_case o apsnd (apply_case ctxt)) cases')] |
|
1050 end; |
|
1051 |
|
1052 val print_cases = Pretty.writeln o Pretty.chunks o pretty_cases; |
|
1053 |
|
1054 |
|
1055 (* prems *) |
|
1056 |
|
1057 val prems_limit = ref 10; |
|
1058 |
|
1059 fun pretty_prems ctxt = |
|
1060 let |
|
1061 val limit = ! prems_limit; |
|
1062 val prems = prems_of ctxt; |
|
1063 val len = length prems; |
|
1064 val prt_prems = |
|
1065 (if len <= limit then [] else [Pretty.str "..."]) @ |
|
1066 map pretty_thm (Library.drop (len - limit, prems)); |
|
1067 in if null prems then [] else [Pretty.big_list "prems:" prt_prems] end; |
|
1068 |
|
1069 |
|
1070 (* main context *) |
|
1071 |
|
1072 fun pretty_context (ctxt as Context {asms = (_, (fixes, _)), cases, |
|
1073 defs = (types, sorts, (used, _)), ...}) = |
|
1074 let |
|
1075 val sign = sign_of ctxt; |
|
1076 |
|
1077 val prt_term = Sign.pretty_term sign; |
|
1078 val prt_typ = Sign.pretty_typ sign; |
|
1079 val prt_sort = Sign.pretty_sort sign; |
|
1080 |
|
1081 (*theory*) |
|
1082 val pretty_thy = Pretty.block [Pretty.str "Theory:", Pretty.brk 1, Sign.pretty_sg sign]; |
|
1083 |
|
1084 (*fixes*) |
|
1085 fun prt_fix (x, x') = Pretty.block |
|
1086 [prt_term (Syntax.free x), Pretty.str " =", Pretty.brk 1, prt_term (Syntax.free x')]; |
|
1087 |
|
1088 fun prt_fixes [] = [] |
|
1089 | prt_fixes xs = [Pretty.block (Pretty.str "fixed variables:" :: Pretty.brk 1 :: |
|
1090 Pretty.commas (map prt_fix xs))]; |
|
1091 |
|
1092 (*defaults*) |
|
1093 fun prt_atom prt prtT (x, X) = Pretty.block |
|
1094 [prt x, Pretty.str " ::", Pretty.brk 1, prtT X]; |
|
1095 |
|
1096 fun prt_var (x, ~1) = prt_term (Syntax.free x) |
|
1097 | prt_var xi = prt_term (Syntax.var xi); |
|
1098 |
|
1099 fun prt_varT (x, ~1) = prt_typ (TFree (x, [])) |
|
1100 | prt_varT xi = prt_typ (TVar (xi, [])); |
|
1101 |
|
1102 val prt_defT = prt_atom prt_var prt_typ; |
|
1103 val prt_defS = prt_atom prt_varT prt_sort; |
|
1104 in |
|
1105 verb_single (K pretty_thy) @ |
|
1106 prt_fixes (rev (filter_out (can Syntax.dest_internal o #1) fixes)) @ |
|
1107 pretty_prems ctxt @ |
|
1108 verb pretty_binds (K ctxt) @ |
|
1109 verb pretty_thms (K ctxt) @ |
|
1110 verb pretty_cases (K ctxt) @ |
|
1111 verb_single (fn () => Pretty.big_list "type constraints:" (map prt_defT (Vartab.dest types))) @ |
|
1112 verb_single (fn () => Pretty.big_list "default sorts:" (map prt_defS (Vartab.dest sorts))) @ |
|
1113 verb_single (fn () => Pretty.strs ("used type variable names:" :: used)) |
|
1114 end; |
|
1115 |
|
1116 |
|
1117 |
1104 (** theory setup **) |
1118 (** theory setup **) |
1105 |
1119 |
1106 val setup = [ProofDataData.init]; |
1120 val setup = [ProofDataData.init]; |
1107 |
1121 |
1108 |
1122 |