204 val t = termify ts; |
204 val t = termify ts; |
205 val subs = subsumers sign t regs; |
205 val subs = subsumers sign t regs; |
206 in (case subs of |
206 in (case subs of |
207 [] => NONE |
207 [] => NONE |
208 | ((t', (attn, thms)) :: _) => let |
208 | ((t', (attn, thms)) :: _) => let |
209 val (tinst, inst) = Pattern.match sign (t', t); |
209 val (tinst, inst) = Pattern.match sign (t', t) (Vartab.empty, Vartab.empty); |
210 (* thms contain Frees, not Vars *) |
210 (* thms contain Frees, not Vars *) |
211 val tinst' = tinst |> Vartab.dest |
211 val tinst' = tinst |> Vartab.dest |
212 |> map (fn ((x, 0), (_, T)) => (x, Type.unvarifyT T)) |
212 |> map (fn ((x, 0), (_, T)) => (x, Type.unvarifyT T)) |
213 |> Symtab.make; |
213 |> Symtab.make; |
214 val inst' = inst |> Vartab.dest |
214 val inst' = inst |> Vartab.dest |
522 |
522 |
523 val (maxidx', Ts') = foldl_map paramify (maxidx, Ts); |
523 val (maxidx', Ts') = foldl_map paramify (maxidx, Ts); |
524 val (maxidx'', Us') = foldl_map paramify (maxidx', Us); |
524 val (maxidx'', Us') = foldl_map paramify (maxidx', Us); |
525 val thy = ProofContext.theory_of ctxt; |
525 val thy = ProofContext.theory_of ctxt; |
526 |
526 |
527 fun unify (env, (SOME T, SOME U)) = (Sign.typ_unify thy (U, T) env |
527 fun unify (SOME T, SOME U) env = (Sign.typ_unify thy (U, T) env |
528 handle Type.TUNIFY => |
528 handle Type.TUNIFY => raise TYPE ("unify_frozen: failed to unify types", [U, T], [])) |
529 raise TYPE ("unify_frozen: failed to unify types", [U, T], [])) |
529 | unify _ env = env; |
530 | unify (env, _) = env; |
530 val (unifier, _) = fold unify (Ts' ~~ Us') (Vartab.empty, maxidx''); |
531 val (unifier, _) = Library.foldl unify ((Vartab.empty, maxidx''), Ts' ~~ Us'); |
|
532 val Vs = map (Option.map (Envir.norm_type unifier)) Us'; |
531 val Vs = map (Option.map (Envir.norm_type unifier)) Us'; |
533 val unifier' = Vartab.extend (unifier, frozen_tvars ctxt (List.mapPartial I Vs)); |
532 val unifier' = Vartab.extend (unifier, frozen_tvars ctxt (List.mapPartial I Vs)); |
534 in map (Option.map (Envir.norm_type unifier')) Vs end; |
533 in map (Option.map (Envir.norm_type unifier')) Vs end; |
535 |
534 |
536 fun params_of elemss = gen_distinct (eq_fst (op =)) (List.concat (map (snd o fst) elemss)); |
535 fun params_of elemss = gen_distinct (eq_fst (op =)) (List.concat (map (snd o fst) elemss)); |
1059 in (Term.dest_Free f, eq') end; |
1058 in (Term.dest_Free f, eq') end; |
1060 |
1059 |
1061 fun abstract_thm thy eq = |
1060 fun abstract_thm thy eq = |
1062 Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def; |
1061 Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def; |
1063 |
1062 |
1064 fun bind_def ctxt (name, ps) ((xs, env, ths), eq) = |
1063 fun bind_def ctxt (name, ps) eq (xs, env, ths) = |
1065 let |
1064 let |
1066 val ((y, T), b) = abstract_term eq; |
1065 val ((y, T), b) = abstract_term eq; |
1067 val b' = norm_term env b; |
1066 val b' = norm_term env b; |
1068 val th = abstract_thm (ProofContext.theory_of ctxt) eq; |
1067 val th = abstract_thm (ProofContext.theory_of ctxt) eq; |
1069 fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)]; |
1068 fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)]; |
1077 |
1076 |
1078 |
1077 |
1079 (* CB: for finish_elems (Int and Ext), |
1078 (* CB: for finish_elems (Int and Ext), |
1080 extracts specification, only of assumed elements *) |
1079 extracts specification, only of assumed elements *) |
1081 |
1080 |
1082 fun eval_text _ _ _ (text, Fixes _) = text |
1081 fun eval_text _ _ _ (Fixes _) text = text |
1083 | eval_text _ _ _ (text, Constrains _) = text |
1082 | eval_text _ _ _ (Constrains _) text = text |
1084 | eval_text _ (_, Assumed _) is_ext ((((exts, exts'), (ints, ints')), (xs, env, defs)), Assumes asms) = |
1083 | eval_text _ (_, Assumed _) is_ext (Assumes asms) |
|
1084 (((exts, exts'), (ints, ints')), (xs, env, defs)) = |
1085 let |
1085 let |
1086 val ts = List.concat (map (map #1 o #2) asms); |
1086 val ts = List.concat (map (map #1 o #2) asms); |
1087 val ts' = map (norm_term env) ts; |
1087 val ts' = map (norm_term env) ts; |
1088 val spec' = |
1088 val spec' = |
1089 if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints')) |
1089 if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints')) |
1090 else ((exts, exts'), (ints @ ts, ints' @ ts')); |
1090 else ((exts, exts'), (ints @ ts, ints' @ ts')); |
1091 in (spec', (fold Term.add_frees ts' xs, env, defs)) end |
1091 in (spec', (fold Term.add_frees ts' xs, env, defs)) end |
1092 | eval_text _ (_, Derived _) _ (text, Assumes _) = text |
1092 | eval_text _ (_, Derived _) _ (Assumes _) text = text |
1093 | eval_text ctxt (id, Assumed _) _ ((spec, binds), Defines defs) = |
1093 | eval_text ctxt (id, Assumed _) _ (Defines defs) (spec, binds) = |
1094 (spec, Library.foldl (bind_def ctxt id) (binds, map (#1 o #2) defs)) |
1094 (spec, fold (bind_def ctxt id o #1 o #2) defs binds) |
1095 | eval_text _ (_, Derived _) _ (text, Defines _) = text |
1095 | eval_text _ (_, Derived _) _ (Defines _) text = text |
1096 | eval_text _ _ _ (text, Notes _) = text; |
1096 | eval_text _ _ _ (Notes _) text = text; |
1097 |
1097 |
1098 |
1098 |
1099 (* for finish_elems (Int), |
1099 (* for finish_elems (Int), |
1100 remove redundant elements of derived identifiers, |
1100 remove redundant elements of derived identifiers, |
1101 turn assumptions and definitions into facts, |
1101 turn assumptions and definitions into facts, |
1161 |
1161 |
1162 fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) = |
1162 fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) = |
1163 let |
1163 let |
1164 val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)]; |
1164 val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)]; |
1165 val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths; |
1165 val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths; |
1166 val text' = Library.foldl (eval_text ctxt id' false) (text, es); |
1166 val text' = fold (eval_text ctxt id' false) es text; |
1167 val es' = List.mapPartial |
1167 val es' = List.mapPartial |
1168 (finish_derived (ProofContext.theory_of ctxt) wits' mode) es; |
1168 (finish_derived (ProofContext.theory_of ctxt) wits' mode) es; |
1169 in ((text', wits'), (id', map Int es')) end |
1169 in ((text', wits'), (id', map Int es')) end |
1170 | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) = |
1170 | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) = |
1171 let |
1171 let |
1172 val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp); |
1172 val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp); |
1173 val text' = eval_text ctxt id true (text, e'); |
1173 val text' = eval_text ctxt id true e' text; |
1174 in ((text', wits), (id, [Ext e'])) end |
1174 in ((text', wits), (id, [Ext e'])) end |
1175 |
1175 |
1176 in |
1176 in |
1177 |
1177 |
1178 (* CB: only called by prep_elemss *) |
1178 (* CB: only called by prep_elemss *) |
1464 |
1464 |
1465 val regs = get_global_registrations thy target; |
1465 val regs = get_global_registrations thy target; |
1466 |
1466 |
1467 (* add args to thy for all registrations *) |
1467 (* add args to thy for all registrations *) |
1468 |
1468 |
1469 fun activate (thy, (vts, ((prfx, atts2), _))) = |
1469 fun activate (vts, ((prfx, atts2), _)) thy = |
1470 let |
1470 let |
1471 val (insts, prems) = collect_global_witnesses thy parms ids vts; |
1471 val (insts, prems) = collect_global_witnesses thy parms ids vts; |
1472 val inst_atts = |
1472 val inst_atts = |
1473 Args.map_values I (Element.instT_type (#1 insts)) |
1473 Args.map_values I (Element.instT_type (#1 insts)) |
1474 (Element.inst_term insts) (Element.inst_thm thy insts); |
1474 (Element.inst_term insts) (Element.inst_thm thy insts); |
1476 ((NameSpace.qualified prfx n, |
1476 ((NameSpace.qualified prfx n, |
1477 map (Attrib.global_attribute_i thy) (map inst_atts atts @ atts2)), |
1477 map (Attrib.global_attribute_i thy) (map inst_atts atts @ atts2)), |
1478 [(map (Drule.standard o satisfy_protected prems o |
1478 [(map (Drule.standard o satisfy_protected prems o |
1479 Element.inst_thm thy insts) ths, [])])); |
1479 Element.inst_thm thy insts) ths, [])])); |
1480 in global_note_accesses_i (Drule.kind kind) prfx args' thy |> fst end; |
1480 in global_note_accesses_i (Drule.kind kind) prfx args' thy |> fst end; |
1481 in Library.foldl activate (thy, regs) end; |
1481 in fold activate regs thy end; |
1482 |
1482 |
1483 |
1483 |
1484 fun smart_note_thmss kind NONE = PureThy.note_thmss_i (Drule.kind kind) |
1484 fun smart_note_thmss kind NONE = PureThy.note_thmss_i (Drule.kind kind) |
1485 | smart_note_thmss kind (SOME loc) = note_thmss_qualified kind loc; |
1485 | smart_note_thmss kind (SOME loc) = note_thmss_qualified kind loc; |
1486 |
1486 |