src/Pure/Isar/locale.ML
changeset 18190 b7748c77562f
parent 18137 cb916659c89b
child 18213 c22ee06ac1a7
equal deleted inserted replaced
18189:b44d53088108 18190:b7748c77562f
   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