1 (* Title: Pure/Isar/locale.ML
3 Author: Clemens Ballarin, TU Muenchen; Markus Wenzel, LMU/TU Muenchen
5 Locales -- Isar proof contexts as meta-level predicates, with local
6 syntax and implicit structures.
8 Draws basic ideas from Florian Kammueller's original version of
9 locales, but uses the richer infrastructure of Isar instead of the raw
10 meta-logic. Furthermore, structured import of contexts (with merge
11 and rename operations) are provided, as well as type-inference of the
12 signature parts, and predicate definitions of the specification text.
14 Interpretation enables the reuse of theorems of locales in other
15 contexts, namely those defined by theories, structured proofs and
20 [1] Clemens Ballarin. Locales and Locale Expressions in Isabelle/Isar.
21 In Stefano Berardi et al., Types for Proofs and Programs: International
22 Workshop, TYPES 2003, Torino, Italy, LNCS 3085, pages 34-50, 2004.
23 [2] Clemens Ballarin. Interpretation of Locales in Isabelle: Managing
24 Dependencies between Locales. Technical Report TUM-I0607, Technische
25 Universitaet Muenchen, 2006.
26 [3] Clemens Ballarin. Interpretation of Locales in Isabelle: Theories and
27 Proof Contexts. In J.M. Borwein and W.M. Farmer, MKM 2006, LNAI 4108,
32 - beta-eta normalisation of interpretation parameters
33 - dangling type frees in locales
34 - test subsumption of interpretations when merging theories
41 Rename of expr * (string * mixfix option) option list |
44 datatype 'a element = Elem of 'a | Expr of expr
45 val map_elem: ('a -> 'b) -> 'a element -> 'b element
47 val intern: theory -> xstring -> string
48 val intern_expr: theory -> expr -> expr
49 val extern: theory -> string -> xstring
50 val init: string -> theory -> Proof.context
52 (* The specification of a locale *)
53 val parameters_of: theory -> string ->
54 ((string * typ) * mixfix) list
55 val parameters_of_expr: theory -> expr ->
56 ((string * typ) * mixfix) list
57 val local_asms_of: theory -> string ->
58 ((string * Attrib.src list) * term list) list
59 val global_asms_of: theory -> string ->
60 ((string * Attrib.src list) * term list) list
61 val intros: theory -> string -> thm list * thm list
62 val dests: theory -> string -> thm list
64 (* Processing of locale statements *)
65 val read_context_statement: xstring option -> Element.context element list ->
66 (string * string list) list list -> Proof.context ->
67 string option * Proof.context * Proof.context * (term * term list) list list
68 val read_context_statement_i: string option -> Element.context element list ->
69 (string * string list) list list -> Proof.context ->
70 string option * Proof.context * Proof.context * (term * term list) list list
71 val cert_context_statement: string option -> Element.context_i element list ->
72 (term * term list) list list -> Proof.context ->
73 string option * Proof.context * Proof.context * (term * term list) list list
74 val read_expr: expr -> Element.context list -> Proof.context ->
75 Element.context_i list * Proof.context
76 val cert_expr: expr -> Element.context_i list -> Proof.context ->
77 Element.context_i list * Proof.context
79 (* Diagnostic functions *)
80 val print_locales: theory -> unit
81 val print_locale: theory -> bool -> expr -> Element.context list -> unit
82 val print_registrations: bool -> string -> Proof.context -> unit
84 val add_locale: string option -> bstring -> expr -> Element.context list -> theory
85 -> string * Proof.context
86 val add_locale_i: string option -> bstring -> expr -> Element.context_i list -> theory
87 -> string * Proof.context
90 val intro_locales_tac: bool -> Proof.context -> thm list -> tactic
93 val add_thmss: string -> string ->
94 ((string * Attrib.src list) * (thm list * Attrib.src list) list) list ->
95 Proof.context -> Proof.context
96 val add_type_syntax: string -> declaration -> Proof.context -> Proof.context
97 val add_term_syntax: string -> declaration -> Proof.context -> Proof.context
98 val add_declaration: string -> declaration -> Proof.context -> Proof.context
100 val interpretation_i: (Proof.context -> Proof.context) ->
101 (bool * string) * Attrib.src list -> expr ->
102 term option list * ((bstring * Attrib.src list) * term) list ->
103 theory -> Proof.state
104 val interpretation: (Proof.context -> Proof.context) ->
105 (bool * string) * Attrib.src list -> expr ->
106 string option list * ((bstring * Attrib.src list) * string) list ->
107 theory -> Proof.state
108 val interpretation_in_locale: (Proof.context -> Proof.context) ->
109 xstring * expr -> theory -> Proof.state
110 val interpret_i: (Proof.state -> Proof.state Seq.seq) ->
111 (bool * string) * Attrib.src list -> expr ->
112 term option list * ((bstring * Attrib.src list) * term) list ->
113 bool -> Proof.state -> Proof.state
114 val interpret: (Proof.state -> Proof.state Seq.seq) ->
115 (bool * string) * Attrib.src list -> expr ->
116 string option list * ((bstring * Attrib.src list) * string) list ->
117 bool -> Proof.state -> Proof.state
120 structure Locale: LOCALE =
123 (* legacy operations *)
125 fun gen_merge_lists _ xs [] = xs
126 | gen_merge_lists _ [] ys = ys
127 | gen_merge_lists eq xs ys = xs @ filter_out (member eq xs) ys;
129 fun merge_lists xs ys = gen_merge_lists (op =) xs ys;
130 fun merge_alists xs = gen_merge_lists (eq_fst (op =)) xs;
132 fun legacy_unvarifyT thm =
134 val cT = Thm.ctyp_of (Thm.theory_of_thm thm);
135 val tvars = rev (Thm.fold_terms Term.add_tvars thm []);
136 val tfrees = map (fn ((x, _), S) => SOME (cT (TFree (x, S)))) tvars;
137 in Drule.instantiate' tfrees [] thm end;
139 fun legacy_unvarify raw_thm =
141 val thm = legacy_unvarifyT raw_thm;
142 val ct = Thm.cterm_of (Thm.theory_of_thm thm);
143 val vars = rev (Thm.fold_terms Term.add_vars thm []);
144 val frees = map (fn ((x, _), T) => SOME (ct (Free (x, T)))) vars;
145 in Drule.instantiate' [] frees thm end;
148 (** locale elements and expressions **)
150 datatype ctxt = datatype Element.ctxt;
154 Rename of expr * (string * mixfix option) option list |
157 val empty = Merge [];
159 datatype 'a element =
160 Elem of 'a | Expr of expr;
162 fun map_elem f (Elem e) = Elem (f e)
163 | map_elem _ (Expr e) = Expr e;
165 type decl = declaration * stamp;
168 {axiom: Element.witness list,
169 (* For locales that define predicates this is [A [A]], where A is the locale
170 specification. Otherwise [].
171 Only required to generate the right witnesses for locales with predicates. *)
172 imports: expr, (*dynamic imports*)
173 elems: (Element.context_i * stamp) list,
174 (* Static content, neither Fixes nor Constrains elements *)
175 params: ((string * typ) * mixfix) list, (*all params*)
176 lparams: string list, (*local params*)
177 decls: decl list * decl list, (*type/term_syntax declarations*)
178 regs: ((string * string list) * Element.witness list) list,
179 (* Registrations: indentifiers and witnesses of locales interpreted in the locale. *)
180 intros: thm list * thm list,
181 (* Introduction rules: of delta predicate and locale predicate. *)
183 (* Destruction rules relative to canonical order in locale context. *)
185 (* CB: an internal (Int) locale element was either imported or included,
186 an external (Ext) element appears directly in the locale text. *)
188 datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b;
192 (** substitutions on Frees and Vars -- clone from element.ML **)
194 (* instantiate types *)
196 fun var_instT_type env =
197 if Vartab.is_empty env then I
198 else Term.map_type_tvar (fn (x, S) => the_default (TVar (x, S)) (Vartab.lookup env x));
200 fun var_instT_term env =
201 if Vartab.is_empty env then I
202 else Term.map_types (var_instT_type env);
204 fun var_inst_term (envT, env) =
205 if Vartab.is_empty env then var_instT_term envT
208 val instT = var_instT_type envT;
209 fun inst (Const (x, T)) = Const (x, instT T)
210 | inst (Free (x, T)) = Free(x, instT T)
211 | inst (Var (xi, T)) =
212 (case Vartab.lookup env xi of
213 NONE => Var (xi, instT T)
215 | inst (b as Bound _) = b
216 | inst (Abs (x, T, t)) = Abs (x, instT T, inst t)
217 | inst (t $ u) = inst t $ inst u;
218 in Envir.beta_norm o inst end;
221 (** management of registrations in theories and proof contexts **)
223 structure Registrations :
228 val dest: theory -> T ->
230 (((bool * string) * Attrib.src list) *
231 (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) *
232 Element.witness list *
233 thm Termtab.table)) list
234 val test: theory -> T * term list -> bool
235 val lookup: theory ->
236 T * (term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
237 (((bool * string) * Attrib.src list) *
238 Element.witness list *
239 thm Termtab.table) option
240 val insert: theory -> term list -> ((bool * string) * Attrib.src list) ->
241 (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) -> T ->
242 T * (term list * (((bool * string) * Attrib.src list) * Element.witness list)) list
243 val add_witness: term list -> Element.witness -> T -> T
244 val add_equation: term list -> thm -> T -> T
247 (* A registration is indexed by parameter instantiation. Its components are:
248 - parameters and prefix
249 (if the Boolean flag is set, only accesses containing the prefix are generated,
250 otherwise the prefix may be omitted when accessing theorems etc.)
251 - pair of export and import morphisms, export maps content to its originating
252 context, import is its inverse
253 - theorems (actually witnesses) instantiating locale assumptions
254 - theorems (equations) interpreting derived concepts and indexed by lhs.
255 NB: index is exported while content is internalised.
257 type T = (((bool * string) * Attrib.src list) *
258 (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) *
259 Element.witness list *
260 thm Termtab.table) Termtab.table;
262 val empty = Termtab.empty;
264 (* term list represented as single term, for simultaneous matching *)
266 Term.list_comb (Const ("", map fastype_of ts ---> propT), ts);
268 let fun ut (Const _) ts = ts
269 | ut (s $ t) ts = ut s (t::ts)
272 (* joining of registrations:
273 - prefix, attributes and morphisms of right theory;
274 - witnesses are equal, no attempt to subsumption testing;
275 - union of equalities, if conflicting (i.e. two eqns with equal lhs)
276 eqn of right theory takes precedence *)
277 fun join (r1, r2) = Termtab.join (fn _ => fn ((_, _, _, e1), (n, m, w, e2)) =>
278 (n, m, w, Termtab.join (fn _ => fn (_, e) => e) (e1, e2))) (r1, r2);
280 fun dest_transfer thy regs =
281 Termtab.dest regs |> map (apsnd (fn (n, m, ws, es) =>
282 (n, m, map (Element.transfer_witness thy) ws, Termtab.map (transfer thy) es)));
284 fun dest thy regs = dest_transfer thy regs |> map (apfst untermify);
286 (* registrations that subsume t *)
287 fun subsumers thy t regs =
288 filter (fn (t', _) => Pattern.matches thy (t', t)) (dest_transfer thy regs);
290 (* test if registration that subsumes the query is present *)
291 fun test thy (regs, ts) =
292 not (null (subsumers thy (termify ts) regs));
294 (* look up registration, pick one that subsumes the query *)
295 fun lookup thy (regs, (ts, ((impT, _), (imp, _)))) =
298 val subs = subsumers thy t regs;
302 | ((t', ((prfx, atts), (exp', ((impT', domT'), (imp', dom'))), thms, eqns)) :: _) =>
304 val (tinst, inst) = Pattern.match thy (t', t) (Vartab.empty, Vartab.empty);
305 val tinst' = domT' |> map (fn (T as TFree (x, _)) =>
306 (x, T |> Morphism.typ exp' |> Envir.typ_subst_TVars tinst
307 |> var_instT_type impT)) |> Symtab.make;
308 val inst' = dom' |> map (fn (t as Free (x, _)) =>
309 (x, t |> Morphism.term exp' |> Envir.subst_vars (tinst, inst)
310 |> var_inst_term (impT, imp))) |> Symtab.make;
311 val inst'_morph = Element.inst_morphism thy (tinst', inst');
312 in SOME ((prfx, map (Args.morph_values inst'_morph) atts),
313 map (Element.morph_witness inst'_morph) thms,
314 Termtab.map (Morphism.thm inst'_morph) eqns)
318 (* add registration if not subsumed by ones already present,
319 additionally returns registrations that are strictly subsumed *)
320 fun insert thy ts attn m regs =
323 val subs = subsumers thy t regs ;
327 filter (fn (t', _) => Pattern.matches thy (t, t')) (dest_transfer thy regs);
328 val sups' = map (apfst untermify) sups |> map (fn (ts, (n, _, w, _)) => (ts, (n, w)))
329 in (Termtab.update (t, (attn, m, [], Termtab.empty)) regs, sups') end
333 fun gen_add f ts thm regs =
337 Termtab.update (t, f thm (the (Termtab.lookup regs t))) regs
340 (* add witness theorem to registration,
341 only if instantiation is exact, otherwise exception Option raised *)
342 fun add_witness ts thm regs =
343 gen_add (fn thm => fn (x, m, thms, eqns) => (x, m, thm::thms, eqns)) ts thm regs;
345 (* add equation to registration, replaces previous equation with same lhs;
346 only if instantiation is exact, otherwise exception Option raised;
347 exception TERM raised if not a meta equality *)
348 fun add_equation ts thm regs =
349 gen_add (fn thm => fn (x, m, thms, eqns) =>
350 (x, m, thms, Termtab.update (thm |> prop_of |> Logic.dest_equals |> fst, thm) eqns))
355 (** theory data : locales **)
357 structure LocalesData = TheoryDataFun
359 type T = NameSpace.T * locale Symtab.table;
360 (* 1st entry: locale namespace,
361 2nd entry: locales of the theory *)
363 val empty = (NameSpace.empty, Symtab.empty);
368 ({axiom, imports, elems, params, lparams, decls = (decls1, decls2), regs, intros, dests}: locale,
369 {elems = elems', decls = (decls1', decls2'), regs = regs', ...}: locale) =
372 elems = gen_merge_lists (eq_snd (op =)) elems elems',
376 (Library.merge (eq_snd (op =)) (decls1, decls1'),
377 Library.merge (eq_snd (op =)) (decls2, decls2')),
378 regs = merge_alists regs regs',
381 fun merge _ ((space1, locs1), (space2, locs2)) =
382 (NameSpace.merge (space1, space2), Symtab.join join_locales (locs1, locs2));
387 (** context data : registrations **)
389 structure RegistrationsData = GenericDataFun
391 type T = Registrations.T Symtab.table; (*registrations, indexed by locale name*)
392 val empty = Symtab.empty;
394 fun merge _ = Symtab.join (K Registrations.join);
398 (** access locales **)
400 fun print_locales thy =
401 let val (space, locs) = LocalesData.get thy in
402 Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (space, locs)))
406 val intern = NameSpace.intern o #1 o LocalesData.get;
407 val extern = NameSpace.extern o #1 o LocalesData.get;
409 fun declare_locale name thy =
410 thy |> LocalesData.map (fn (space, locs) =>
411 (Sign.declare_name thy name space, locs));
413 fun put_locale name loc =
414 LocalesData.map (fn (space, locs) =>
415 (space, Symtab.update (name, loc) locs));
417 fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy)) name;
419 fun the_locale thy name =
420 (case get_locale thy name of
422 | NONE => error ("Unknown locale " ^ quote name));
424 fun change_locale name f thy =
426 val {axiom, imports, elems, params, lparams, decls, regs, intros, dests} =
428 val (axiom', imports', elems', params', lparams', decls', regs', intros', dests') =
429 f (axiom, imports, elems, params, lparams, decls, regs, intros, dests);
431 put_locale name {axiom = axiom', imports = imports', elems = elems',
432 params = params', lparams = lparams', decls = decls', regs = regs',
433 intros = intros', dests = dests'} thy
437 (* access registrations *)
439 (* retrieve registration from theory or context *)
441 fun get_registrations ctxt name =
442 case Symtab.lookup (RegistrationsData.get ctxt) name of
444 | SOME reg => Registrations.dest (Context.theory_of ctxt) reg;
446 fun get_global_registrations thy = get_registrations (Context.Theory thy);
447 fun get_local_registrations ctxt = get_registrations (Context.Proof ctxt);
450 fun get_registration ctxt imprt (name, ps) =
451 case Symtab.lookup (RegistrationsData.get ctxt) name of
453 | SOME reg => Registrations.lookup (Context.theory_of ctxt) (reg, (ps, imprt));
455 fun get_global_registration thy = get_registration (Context.Theory thy);
456 fun get_local_registration ctxt = get_registration (Context.Proof ctxt);
459 fun test_registration ctxt (name, ps) =
460 case Symtab.lookup (RegistrationsData.get ctxt) name of
462 | SOME reg => Registrations.test (Context.theory_of ctxt) (reg, ps);
464 fun test_global_registration thy = test_registration (Context.Theory thy);
465 fun test_local_registration ctxt = test_registration (Context.Proof ctxt);
468 (* add registration to theory or context, ignored if subsumed *)
470 fun put_registration (name, ps) attn morphs ctxt =
471 RegistrationsData.map (fn regs =>
473 val thy = Context.theory_of ctxt;
474 val reg = the_default Registrations.empty (Symtab.lookup regs name);
475 val (reg', sups) = Registrations.insert thy ps attn morphs reg;
476 val _ = if not (null sups) then warning
477 ("Subsumed interpretation(s) of locale " ^
478 quote (extern thy name) ^
479 "\nwith the following prefix(es):" ^
480 commas_quote (map (fn (_, (((_, s), _), _)) => s) sups))
482 in Symtab.update (name, reg') regs end) ctxt;
484 fun put_global_registration id attn morphs =
485 Context.theory_map (put_registration id attn morphs);
486 fun put_local_registration id attn morphs =
487 Context.proof_map (put_registration id attn morphs);
490 fun put_registration_in_locale name id =
491 change_locale name (fn (axiom, imports, elems, params, lparams, decls, regs, intros, dests) =>
492 (axiom, imports, elems, params, lparams, decls, regs @ [(id, [])], intros, dests));
495 (* add witness theorem to registration, ignored if registration not present *)
497 fun add_witness (name, ps) thm =
498 RegistrationsData.map (Symtab.map_entry name (Registrations.add_witness ps thm));
500 fun add_global_witness id thm = Context.theory_map (add_witness id thm);
501 fun add_local_witness id thm = Context.proof_map (add_witness id thm);
504 fun add_witness_in_locale name id thm =
505 change_locale name (fn (axiom, imports, elems, params, lparams, decls, regs, intros, dests) =>
507 fun add (id', thms) =
508 if id = id' then (id', thm :: thms) else (id', thms);
509 in (axiom, imports, elems, params, lparams, decls, map add regs, intros, dests) end);
512 (* add equation to registration, ignored if registration not present *)
514 fun add_equation (name, ps) thm =
515 RegistrationsData.map (Symtab.map_entry name (Registrations.add_equation ps thm));
517 fun add_global_equation id thm = Context.theory_map (add_equation id thm);
518 fun add_local_equation id thm = Context.proof_map (add_equation id thm);
521 (* printing of registrations *)
523 fun print_registrations show_wits loc ctxt =
525 val thy = ProofContext.theory_of ctxt;
526 val prt_term = Pretty.quote o Syntax.pretty_term ctxt;
527 fun prt_term' t = if !show_types
528 then Pretty.block [prt_term t, Pretty.brk 1, Pretty.str "::",
529 Pretty.brk 1, (Pretty.quote o Syntax.pretty_typ ctxt) (type_of t)]
531 val prt_thm = prt_term o prop_of;
533 Pretty.enclose "(" ")" (Pretty.breaks (map prt_term' ts));
534 fun prt_attn ((false, prfx), atts) =
535 Pretty.breaks (Pretty.str prfx :: Pretty.str "(optional)" ::
536 Attrib.pretty_attribs ctxt atts)
537 | prt_attn ((true, prfx), atts) =
538 Pretty.breaks (Pretty.str prfx :: Attrib.pretty_attribs ctxt atts);
539 fun prt_eqns [] = Pretty.str "no equations."
540 | prt_eqns eqns = Pretty.block (Pretty.str "equations:" :: Pretty.brk 1 ::
541 Pretty.breaks (map prt_thm eqns));
542 fun prt_core ts eqns =
543 [prt_inst ts, Pretty.fbrk, prt_eqns (Termtab.dest eqns |> map snd)];
544 fun prt_witns [] = Pretty.str "no witnesses."
545 | prt_witns witns = Pretty.block (Pretty.str "witnesses:" :: Pretty.brk 1 ::
546 Pretty.breaks (map (Element.pretty_witness ctxt) witns))
547 fun prt_reg (ts, (((_, ""), []), _, witns, eqns)) =
549 then Pretty.block (prt_core ts eqns @ [Pretty.fbrk, prt_witns witns])
550 else Pretty.block (prt_core ts eqns)
551 | prt_reg (ts, (attn, _, witns, eqns)) =
553 then Pretty.block ((prt_attn attn @ [Pretty.str ":", Pretty.brk 1] @
554 prt_core ts eqns @ [Pretty.fbrk, prt_witns witns]))
555 else Pretty.block ((prt_attn attn @
556 [Pretty.str ":", Pretty.brk 1] @ prt_core ts eqns));
558 val loc_int = intern thy loc;
559 val regs = RegistrationsData.get (Context.Proof ctxt);
560 val loc_regs = Symtab.lookup regs loc_int;
563 NONE => Pretty.str ("no interpretations")
565 val r' = Registrations.dest thy r;
566 val r'' = Library.sort_wrt (fn (_, (((_, prfx), _), _, _, _)) => prfx) r';
567 in Pretty.big_list ("interpretations:") (map prt_reg r'') end)
574 fun err_in_locale ctxt msg ids =
576 val thy = ProofContext.theory_of ctxt;
577 fun prt_id (name, parms) =
578 [Pretty.block (Pretty.breaks (map Pretty.str (extern thy name :: parms)))];
579 val prt_ids = flat (separate [Pretty.str " +", Pretty.brk 1] (map prt_id ids));
581 if forall (equal "" o #1) ids then msg
582 else msg ^ "\n" ^ Pretty.string_of (Pretty.block
583 (Pretty.str "The error(s) above occurred in locale:" :: Pretty.brk 1 :: prt_ids));
584 in error err_msg end;
586 fun err_in_locale' ctxt msg ids' = err_in_locale ctxt msg (map fst ids');
589 fun pretty_ren NONE = Pretty.str "_"
590 | pretty_ren (SOME (x, NONE)) = Pretty.str x
591 | pretty_ren (SOME (x, SOME syn)) =
592 Pretty.block [Pretty.str x, Pretty.brk 1, Syntax.pretty_mixfix syn];
594 fun pretty_expr thy (Locale name) = Pretty.str (extern thy name)
595 | pretty_expr thy (Rename (expr, xs)) =
596 Pretty.block [pretty_expr thy expr, Pretty.brk 1, Pretty.block (map pretty_ren xs |> Pretty.breaks)]
597 | pretty_expr thy (Merge es) =
598 Pretty.separate "+" (map (pretty_expr thy) es) |> Pretty.block;
600 fun err_in_expr _ msg (Merge []) = error msg
601 | err_in_expr ctxt msg expr =
602 error (msg ^ "\n" ^ Pretty.string_of (Pretty.block
603 [Pretty.str "The error(s) above occured in locale expression:", Pretty.brk 1,
604 pretty_expr (ProofContext.theory_of ctxt) expr]));
607 (** structured contexts: rename + merge + implicit type instantiation **)
609 (* parameter types *)
611 fun frozen_tvars ctxt Ts =
612 #1 (Variable.importT_inst (map Logic.mk_type Ts) ctxt)
613 |> map (fn ((xi, S), T) => (xi, (S, T)));
615 fun unify_frozen ctxt maxidx Ts Us =
617 fun paramify NONE i = (NONE, i)
618 | paramify (SOME T) i = apfst SOME (TypeInfer.paramify_dummies T i);
620 val (Ts', maxidx') = fold_map paramify Ts maxidx;
621 val (Us', maxidx'') = fold_map paramify Us maxidx';
622 val thy = ProofContext.theory_of ctxt;
624 fun unify (SOME T, SOME U) env = (Sign.typ_unify thy (U, T) env
625 handle Type.TUNIFY => raise TYPE ("unify_frozen: failed to unify types", [U, T], []))
627 val (unifier, _) = fold unify (Ts' ~~ Us') (Vartab.empty, maxidx'');
628 val Vs = map (Option.map (Envir.norm_type unifier)) Us';
629 val unifier' = Vartab.extend (unifier, frozen_tvars ctxt (map_filter I Vs));
630 in map (Option.map (Envir.norm_type unifier')) Vs end;
632 fun params_of elemss =
633 distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst) elemss);
635 fun params_of' elemss =
636 distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst o fst) elemss);
639 fun params_prefix params = space_implode "_" params;
642 (* CB: param_types has the following type:
643 ('a * 'b option) list -> ('a * 'b) list *)
644 fun param_types ps = map_filter (fn (_, NONE) => NONE | (x, SOME T) => SOME (x, T)) ps;
647 fun merge_syntax ctxt ids ss = Symtab.merge (op = : mixfix * mixfix -> bool) ss
648 handle Symtab.DUP x => err_in_locale ctxt
649 ("Conflicting syntax for parameter: " ^ quote x) (map fst ids);
652 (* Distinction of assumed vs. derived identifiers.
653 The former may have axioms relating assumptions of the context to
654 assumptions of the specification fragment (for locales with
655 predicates). The latter have witnesses relating assumptions of the
656 specification fragment to assumptions of other (assumed) specification
659 datatype 'a mode = Assumed of 'a | Derived of 'a;
661 fun map_mode f (Assumed x) = Assumed (f x)
662 | map_mode f (Derived x) = Derived (f x);
665 (* flatten expressions *)
669 fun unify_parms ctxt fixed_parms raw_parmss =
671 val thy = ProofContext.theory_of ctxt;
672 val maxidx = length raw_parmss;
673 val idx_parmss = (0 upto maxidx - 1) ~~ raw_parmss;
675 fun varify i = Term.map_type_tfree (fn (a, S) => TVar ((a, i), S));
676 fun varify_parms (i, ps) = map (apsnd (varify i)) (param_types ps);
677 val parms = fixed_parms @ maps varify_parms idx_parmss;
679 fun unify T U envir = Sign.typ_unify thy (U, T) envir
680 handle Type.TUNIFY =>
682 val T' = Envir.norm_type (fst envir) T;
683 val U' = Envir.norm_type (fst envir) U;
684 val prt = Sign.string_of_typ thy;
686 raise TYPE ("unify_parms: failed to unify types " ^
687 prt U' ^ " and " ^ prt T', [U', T'], [])
689 fun unify_list (T :: Us) = fold (unify T) Us
691 val (unifier, _) = fold unify_list (map #2 (Symtab.dest (Symtab.make_list parms)))
692 (Vartab.empty, maxidx);
694 val parms' = map (apsnd (Envir.norm_type unifier)) (distinct (eq_fst (op =)) parms);
695 val unifier' = Vartab.extend (unifier, frozen_tvars ctxt (map #2 parms'));
697 fun inst_parms (i, ps) =
698 List.foldr Term.add_typ_tfrees [] (map_filter snd ps)
699 |> map_filter (fn (a, S) =>
700 let val T = Envir.norm_type unifier' (TVar ((a, i), S))
701 in if T = TFree (a, S) then NONE else SOME (a, T) end)
703 in map inst_parms idx_parmss end;
707 fun unify_elemss _ _ [] = []
708 | unify_elemss _ [] [elems] = [elems]
709 | unify_elemss ctxt fixed_parms elemss =
711 val thy = ProofContext.theory_of ctxt;
712 val phis = unify_parms ctxt fixed_parms (map (snd o fst o fst) elemss)
713 |> map (Element.instT_morphism thy);
714 fun inst ((((name, ps), mode), elems), phi) =
715 (((name, map (apsnd (Option.map (Morphism.typ phi))) ps),
716 map_mode (map (Element.morph_witness phi)) mode),
717 map (Element.morph_ctxt phi) elems);
718 in map inst (elemss ~~ phis) end;
721 fun renaming xs parms = zip_options parms xs
722 handle Library.UnequalLengths =>
723 error ("Too many arguments in renaming: " ^
724 commas (map (fn NONE => "_" | SOME x => quote (fst x)) xs));
728 Compute parameters (with types and syntax) of locale expression.
731 fun params_of_expr ctxt fixed_params expr (prev_parms, prev_types, prev_syn) =
733 val thy = ProofContext.theory_of ctxt;
735 fun merge_tenvs fixed tenv1 tenv2 =
737 val [env1, env2] = unify_parms ctxt fixed
738 [tenv1 |> Symtab.dest |> map (apsnd SOME),
739 tenv2 |> Symtab.dest |> map (apsnd SOME)]
741 Symtab.merge (op =) (Symtab.map (Element.instT_type env1) tenv1,
742 Symtab.map (Element.instT_type env2) tenv2)
745 fun merge_syn expr syn1 syn2 =
746 Symtab.merge (op = : mixfix * mixfix -> bool) (syn1, syn2)
747 handle Symtab.DUP x => err_in_expr ctxt
748 ("Conflicting syntax for parameter: " ^ quote x) expr;
750 fun params_of (expr as Locale name) =
752 val {imports, params, ...} = the_locale thy name;
753 val parms = map (fst o fst) params;
754 val (parms', types', syn') = params_of imports;
755 val all_parms = merge_lists parms' parms;
756 val all_types = merge_tenvs [] types' (params |> map fst |> Symtab.make);
757 val all_syn = merge_syn expr syn' (params |> map (apfst fst) |> Symtab.make);
758 in (all_parms, all_types, all_syn) end
759 | params_of (expr as Rename (e, xs)) =
761 val (parms', types', syn') = params_of e;
762 val ren = renaming xs parms';
763 (* renaming may reduce number of parameters *)
764 val new_parms = map (Element.rename ren) parms' |> distinct (op =);
765 val ren_syn = syn' |> Symtab.dest |> map (Element.rename_var ren);
766 val new_syn = fold (Symtab.insert (op =)) ren_syn Symtab.empty
767 handle Symtab.DUP x =>
768 err_in_expr ctxt ("Conflicting syntax for parameter: " ^ quote x) expr;
769 val syn_types = map (apsnd (fn mx =>
770 SOME (Type.freeze_type (#1 (TypeInfer.paramify_dummies (Syntax.mixfixT mx) 0)))))
771 (Symtab.dest new_syn);
772 val ren_types = types' |> Symtab.dest |> map (apfst (Element.rename ren));
773 val (env :: _) = unify_parms ctxt []
774 ((ren_types |> map (apsnd SOME)) :: map single syn_types);
775 val new_types = fold (Symtab.insert (op =))
776 (map (apsnd (Element.instT_type env)) ren_types) Symtab.empty;
777 in (new_parms, new_types, new_syn) end
778 | params_of (Merge es) =
779 fold (fn e => fn (parms, types, syn) =>
781 val (parms', types', syn') = params_of e
783 (merge_lists parms parms', merge_tenvs [] types types',
784 merge_syn e syn syn')
786 es ([], Symtab.empty, Symtab.empty)
788 val (parms, types, syn) = params_of expr;
790 (merge_lists prev_parms parms, merge_tenvs fixed_params prev_types types,
791 merge_syn expr prev_syn syn)
794 fun make_params_ids params = [(("", params), ([], Assumed []))];
795 fun make_raw_params_elemss (params, tenv, syn) =
796 [((("", map (fn p => (p, Symtab.lookup tenv p)) params), Assumed []),
797 Int [Fixes (map (fn p =>
798 (p, Symtab.lookup tenv p, Symtab.lookup syn p |> the)) params)])];
802 Extend list of identifiers by those new in locale expression expr.
803 Compute corresponding list of lists of locale elements (one entry per
806 Identifiers represent locale fragments and are in an extended form:
807 ((name, ps), (ax_ps, axs))
808 (name, ps) is the locale name with all its parameters.
809 (ax_ps, axs) is the locale axioms with its parameters;
810 axs are always taken from the top level of the locale hierarchy,
811 hence axioms may contain additional parameters from later fragments:
812 ps subset of ax_ps. axs is either singleton or empty.
814 Elements are enriched by identifier-like information:
815 (((name, ax_ps), axs), elems)
816 The parameters in ax_ps are the axiom parameters, but enriched by type
817 info: now each entry is a pair of string and typ option. Axioms are
822 fun flatten_expr ctxt ((prev_idents, prev_syntax), expr) =
824 val thy = ProofContext.theory_of ctxt;
826 fun rename_parms top ren ((name, ps), (parms, mode)) =
827 ((name, map (Element.rename ren) ps),
829 then (map (Element.rename ren) parms,
830 map_mode (map (Element.morph_witness (Element.rename_morphism ren))) mode)
833 (* add (name, ps) and its registrations, recursively; adjust hyps of witnesses *)
835 fun add_with_regs ((name, pTs), mode) (wits, ids, visited) =
836 if member (fn (a, (b, _)) => a = b) visited (name, map #1 pTs)
837 then (wits, ids, visited)
840 val {params, regs, ...} = the_locale thy name;
841 val pTs' = map #1 params;
842 val ren = map #1 pTs' ~~ map (fn (x, _) => (x, NONE)) pTs;
843 (* dummy syntax, since required by rename *)
844 val pTs'' = map (fn ((p, _), (_, T)) => (p, T)) (pTs ~~ pTs');
845 val [env] = unify_parms ctxt pTs [map (apsnd SOME) pTs''];
846 (* propagate parameter types, to keep them consistent *)
847 val regs' = map (fn ((name, ps), wits) =>
848 ((name, map (Element.rename ren) ps),
849 map (Element.transfer_witness thy) wits)) regs;
850 val new_regs = regs';
851 val new_ids = map fst new_regs;
853 map (apsnd (map (fn p => (p, (the o AList.lookup (op =) pTs) p)))) new_ids;
855 val new_wits = new_regs |> map (#2 #> map
856 (Element.morph_witness
857 (Element.instT_morphism thy env $>
858 Element.rename_morphism ren $>
859 Element.satisfy_morphism wits)));
860 val new_ids' = map (fn (id, wits) =>
861 (id, ([], Derived wits))) (new_ids ~~ new_wits);
862 val new_idTs' = map (fn ((n, pTs), (_, ([], mode))) =>
863 ((n, pTs), mode)) (new_idTs ~~ new_ids');
864 val new_id = ((name, map #1 pTs), ([], mode));
865 val (wits', ids', visited') = fold add_with_regs new_idTs'
866 (wits @ flat new_wits, ids, visited @ [new_id]);
868 (wits', ids' @ [new_id], visited')
871 (* distribute top-level axioms over assumed ids *)
873 fun axiomify all_ps ((name, parms), (_, Assumed _)) axioms =
875 val {elems, ...} = the_locale thy name;
877 (fn (Assumes asms, _) => maps (map #1 o #2) asms
880 val (axs1, axs2) = chop (length ts) axioms;
881 in (((name, parms), (all_ps, Assumed axs1)), axs2) end
882 | axiomify all_ps (id, (_, Derived ths)) axioms =
883 ((id, (all_ps, Derived ths)), axioms);
885 (* identifiers of an expression *)
887 fun identify top (Locale name) =
888 (* CB: ids_ax is a list of tuples of the form ((name, ps), axs),
889 where name is a locale name, ps a list of parameter names and axs
890 a list of axioms relating to the identifier, axs is empty unless
891 identify at top level (top = true);
892 parms is accumulated list of parameters *)
894 val {axiom, imports, params, ...} = the_locale thy name;
895 val ps = map (#1 o #1) params;
896 val (ids', parms') = identify false imports;
897 (* acyclic import dependencies *)
899 val (_, ids'', _) = add_with_regs ((name, map #1 params), Assumed []) ([], ids', ids');
900 val ids_ax = if top then fst (fold_map (axiomify ps) ids'' axiom) else ids'';
901 in (ids_ax, merge_lists parms' ps) end
902 | identify top (Rename (e, xs)) =
904 val (ids', parms') = identify top e;
905 val ren = renaming xs parms'
906 handle ERROR msg => err_in_locale' ctxt msg ids';
908 val ids'' = distinct (eq_fst (op =)) (map (rename_parms top ren) ids');
909 val parms'' = distinct (op =) (maps (#2 o #1) ids'');
910 in (ids'', parms'') end
911 | identify top (Merge es) =
912 fold (fn e => fn (ids, parms) =>
914 val (ids', parms') = identify top e
916 (merge_alists ids ids', merge_lists parms parms')
920 fun inst_wit all_params (t, th) = let
921 val {hyps, prop, ...} = Thm.rep_thm th;
922 val ps = map (apsnd SOME) (fold Term.add_frees (prop :: hyps) []);
923 val [env] = unify_parms ctxt all_params [ps];
924 val t' = Element.instT_term env t;
925 val th' = Element.instT_thm thy env th;
928 fun eval all_params tenv syn ((name, params), (locale_params, mode)) =
930 val {params = ps_mx, elems = elems_stamped, ...} = the_locale thy name;
931 val elems = map fst elems_stamped;
932 val ps = map fst ps_mx;
933 fun lookup_syn x = (case Symtab.lookup syn x of SOME Structure => NONE | opt => opt);
934 val locale_params' = map (fn p => (p, Symtab.lookup tenv p |> the)) locale_params;
935 val mode' = map_mode (map (Element.map_witness (inst_wit all_params))) mode;
936 val ren = map fst ps ~~ map (fn p => (p, lookup_syn p)) params;
937 val [env] = unify_parms ctxt all_params [map (apfst (Element.rename ren) o apsnd SOME) ps];
939 Element.rename_morphism ren $>
940 Morphism.name_morphism (NameSpace.qualified (params_prefix params)) $>
941 Element.instT_morphism thy env;
942 val elems' = map (Element.morph_ctxt elem_morphism) elems;
943 in (((name, map (apsnd SOME) locale_params'), mode'), elems') end;
945 (* parameters, their types and syntax *)
946 val (all_params', tenv, syn) = params_of_expr ctxt [] expr ([], Symtab.empty, Symtab.empty);
947 val all_params = map (fn p => (p, Symtab.lookup tenv p |> the)) all_params';
948 (* compute identifiers and syntax, merge with previous ones *)
949 val (ids, _) = identify true expr;
950 val idents = subtract (eq_fst (op =)) prev_idents ids;
951 val syntax = merge_syntax ctxt ids (syn, prev_syntax);
952 (* type-instantiate elements *)
953 val final_elemss = map (eval all_params tenv syntax) idents;
954 in ((prev_idents @ idents, syntax), final_elemss) end;
959 (* activate elements *)
963 fun axioms_export axs _ As =
964 (Element.satisfy_thm axs #> Drule.implies_intr_list (Library.drop (length axs, As)), fn t => t);
967 (* NB: derived ids contain only facts at this stage *)
969 fun activate_elem _ _ ((ctxt, mode), Fixes fixes) =
970 ((ctxt |> ProofContext.add_fixes_i fixes |> snd, mode), [])
971 | activate_elem _ _ ((ctxt, mode), Constrains _) =
973 | activate_elem ax_in_ctxt _ ((ctxt, Assumed axs), Assumes asms) =
975 val asms' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) asms;
976 val ts = maps (map #1 o #2) asms';
977 val (ps, qs) = chop (length ts) axs;
979 ctxt |> fold Variable.auto_fixes ts
980 |> ProofContext.add_assms_i (axioms_export (if ax_in_ctxt then ps else [])) asms';
981 in ((ctxt', Assumed qs), []) end
982 | activate_elem _ _ ((ctxt, Derived ths), Assumes asms) =
983 ((ctxt, Derived ths), [])
984 | activate_elem _ _ ((ctxt, Assumed axs), Defines defs) =
986 val defs' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) defs;
987 val asms = defs' |> map (fn ((name, atts), (t, ps)) =>
988 let val ((c, _), t') = LocalDefs.cert_def ctxt t
989 in (t', ((Thm.def_name_optional c name, atts), [(t', ps)])) end);
991 ctxt |> fold (Variable.auto_fixes o #1) asms
992 |> ProofContext.add_assms_i LocalDefs.def_export (map #2 asms);
993 in ((ctxt', Assumed axs), []) end
994 | activate_elem _ _ ((ctxt, Derived ths), Defines defs) =
995 ((ctxt, Derived ths), [])
996 | activate_elem _ is_ext ((ctxt, mode), Notes (kind, facts)) =
998 val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts;
999 val (res, ctxt') = ctxt |> ProofContext.note_thmss_i kind facts';
1000 in ((ctxt', mode), if is_ext then res else []) end;
1002 fun activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt =
1004 val thy = ProofContext.theory_of ctxt;
1005 val ((ctxt', _), res) =
1006 foldl_map (activate_elem ax_in_ctxt (name = ""))
1007 ((ProofContext.qualified_names ctxt, mode), elems)
1008 handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)];
1009 val ctxt'' = if name = "" then ctxt'
1011 val ps' = map (fn (n, SOME T) => Free (n, T)) ps;
1012 in if test_local_registration ctxt' (name, ps') then ctxt'
1014 val ctxt'' = put_local_registration (name, ps') ((true, ""), [])
1015 (Morphism.identity, ((Vartab.empty, []), (Vartab.empty, []) )) ctxt'
1018 fold (add_local_witness (name, ps') o
1019 Element.assume_witness thy o Element.witness_prop) axs ctxt''
1020 | Derived ths => fold (add_local_witness (name, ps')) ths ctxt''
1023 in (ProofContext.restore_naming ctxt ctxt'', res) end;
1025 fun activate_elemss ax_in_ctxt prep_facts =
1026 fold_map (fn (((name, ps), mode), raw_elems) => fn ctxt =>
1028 val elems = map (prep_facts ctxt) raw_elems;
1029 val (ctxt', res) = apsnd flat
1030 (activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt);
1031 val elems' = elems |> map (Element.map_ctxt_attrib Args.closure);
1032 in (((((name, ps), mode), elems'), res), ctxt') end);
1036 (* CB: activate_facts prep_facts (ctxt, elemss),
1037 where elemss is a list of pairs consisting of identifiers and
1038 context elements, extends ctxt by the context elements yielding
1039 ctxt' and returns (ctxt', (elemss', facts)).
1040 Identifiers in the argument are of the form ((name, ps), axs) and
1041 assumptions use the axioms in the identifiers to set up exporters
1042 in ctxt'. elemss' does not contain identifiers and is obtained
1043 from elemss and the intermediate context with prep_facts.
1044 If read_facts or cert_facts is used for prep_facts, these also remove
1045 the internal/external markers from elemss. *)
1047 fun activate_facts ax_in_ctxt prep_facts (ctxt, args) =
1048 let val ((elemss, factss), ctxt') = activate_elemss ax_in_ctxt prep_facts args ctxt |>> split_list
1049 in (ctxt', (elemss, flat factss)) end;
1055 (** prepare locale elements **)
1059 fun intern_expr thy (Locale xname) = Locale (intern thy xname)
1060 | intern_expr thy (Merge exprs) = Merge (map (intern_expr thy) exprs)
1061 | intern_expr thy (Rename (expr, xs)) = Rename (intern_expr thy expr, xs);
1064 (* propositions and bindings *)
1066 (* flatten (ctxt, prep_expr) ((ids, syn), expr)
1067 normalises expr (which is either a locale
1068 expression or a single context element) wrt.
1069 to the list ids of already accumulated identifiers.
1070 It returns ((ids', syn'), elemss) where ids' is an extension of ids
1071 with identifiers generated for expr, and elemss is the list of
1072 context elements generated from expr.
1073 syn and syn' are symtabs mapping parameter names to their syntax. syn'
1074 is an extension of syn.
1075 For details, see flatten_expr.
1077 Additionally, for a locale expression, the elems are grouped into a single
1078 Int; individual context elements are marked Ext. In this case, the
1079 identifier-like information of the element is as follows:
1080 - for Fixes: (("", ps), []) where the ps have type info NONE
1081 - for other elements: (("", []), []).
1082 The implementation of activate_facts relies on identifier names being
1083 empty strings for external elements.
1086 fun flatten (ctxt, _) ((ids, syn), Elem (Fixes fixes)) = let
1087 val ids' = ids @ [(("", map #1 fixes), ([], Assumed []))]
1090 merge_syntax ctxt ids'
1091 (syn, Symtab.make (map (fn fx => (#1 fx, #3 fx)) fixes))
1092 handle Symtab.DUP x => err_in_locale ctxt
1093 ("Conflicting syntax for parameter: " ^ quote x)
1095 [((("", map (rpair NONE o #1) fixes), Assumed []), Ext (Fixes fixes))])
1097 | flatten _ ((ids, syn), Elem elem) =
1098 ((ids @ [(("", []), ([], Assumed []))], syn), [((("", []), Assumed []), Ext elem)])
1099 | flatten (ctxt, prep_expr) ((ids, syn), Expr expr) =
1100 apsnd (map (apsnd Int)) (flatten_expr ctxt ((ids, syn), prep_expr expr));
1106 fun declare_int_elem (ctxt, Fixes fixes) =
1107 (ctxt |> ProofContext.add_fixes_i (map (fn (x, T, mx) =>
1108 (x, Option.map (Term.map_type_tfree (TypeInfer.param 0)) T, mx)) fixes) |> snd, [])
1109 | declare_int_elem (ctxt, _) = (ctxt, []);
1111 fun declare_ext_elem prep_vars (ctxt, Fixes fixes) =
1112 let val (vars, _) = prep_vars fixes ctxt
1113 in (ctxt |> ProofContext.add_fixes_i vars |> snd, []) end
1114 | declare_ext_elem prep_vars (ctxt, Constrains csts) =
1115 let val (_, ctxt') = prep_vars (map (fn (x, T) => (x, SOME T, NoSyn)) csts) ctxt
1117 | declare_ext_elem _ (ctxt, Assumes asms) = (ctxt, map #2 asms)
1118 | declare_ext_elem _ (ctxt, Defines defs) = (ctxt, map (fn (_, (t, ps)) => [(t, ps)]) defs)
1119 | declare_ext_elem _ (ctxt, Notes _) = (ctxt, []);
1121 fun declare_elems prep_vars (ctxt, (((name, ps), Assumed _), elems)) =
1122 let val (ctxt', propps) =
1124 Int es => foldl_map declare_int_elem (ctxt, es)
1125 | Ext e => foldl_map (declare_ext_elem prep_vars) (ctxt, [e]))
1126 handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)]
1127 in (ctxt', propps) end
1128 | declare_elems _ (ctxt, ((_, Derived _), elems)) = (ctxt, []);
1132 fun declare_elemss prep_vars fixed_params raw_elemss ctxt =
1134 (* CB: fix of type bug of goal in target with context elements.
1135 Parameters new in context elements must receive types that are
1136 distinct from types of parameters in target (fixed_params). *)
1137 val ctxt_with_fixed =
1138 fold Variable.declare_term (map Free fixed_params) ctxt;
1141 |> map_filter (fn (id, Int es) => SOME (id, es) | _ => NONE)
1142 |> unify_elemss ctxt_with_fixed fixed_params;
1143 val (_, raw_elemss') =
1144 foldl_map (fn ((_, es) :: elemss, (id, Int _)) => (elemss, (id, Int es)) | x => x)
1145 (int_elemss, raw_elemss);
1146 in foldl_map (declare_elems prep_vars) (ctxt, raw_elemss') end;
1152 val norm_term = Envir.beta_norm oo Term.subst_atomic;
1154 fun abstract_thm thy eq =
1155 Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def;
1157 fun bind_def ctxt (name, ps) eq (xs, env, ths) =
1159 val ((y, T), b) = LocalDefs.abs_def eq;
1160 val b' = norm_term env b;
1161 val th = abstract_thm (ProofContext.theory_of ctxt) eq;
1162 fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)];
1164 exists (equal y o #1) xs andalso
1165 err "Attempt to define previously specified variable";
1166 exists (fn (Free (y', _), _) => y = y' | _ => false) env andalso
1167 err "Attempt to redefine variable";
1168 (Term.add_frees b' xs, (Free (y, T), b') :: env, th :: ths)
1172 (* CB: for finish_elems (Int and Ext),
1173 extracts specification, only of assumed elements *)
1175 fun eval_text _ _ _ (Fixes _) text = text
1176 | eval_text _ _ _ (Constrains _) text = text
1177 | eval_text _ (_, Assumed _) is_ext (Assumes asms)
1178 (((exts, exts'), (ints, ints')), (xs, env, defs)) =
1180 val ts = maps (map #1 o #2) asms;
1181 val ts' = map (norm_term env) ts;
1183 if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints'))
1184 else ((exts, exts'), (ints @ ts, ints' @ ts'));
1185 in (spec', (fold Term.add_frees ts' xs, env, defs)) end
1186 | eval_text _ (_, Derived _) _ (Assumes _) text = text
1187 | eval_text ctxt (id, Assumed _) _ (Defines defs) (spec, binds) =
1188 (spec, fold (bind_def ctxt id o #1 o #2) defs binds)
1189 | eval_text _ (_, Derived _) _ (Defines _) text = text
1190 | eval_text _ _ _ (Notes _) text = text;
1193 (* for finish_elems (Int),
1194 remove redundant elements of derived identifiers,
1195 turn assumptions and definitions into facts,
1196 satisfy hypotheses of facts *)
1198 fun finish_derived _ _ (Assumed _) (Fixes fixes) = SOME (Fixes fixes)
1199 | finish_derived _ _ (Assumed _) (Constrains csts) = SOME (Constrains csts)
1200 | finish_derived _ _ (Assumed _) (Assumes asms) = SOME (Assumes asms)
1201 | finish_derived _ _ (Assumed _) (Defines defs) = SOME (Defines defs)
1203 | finish_derived _ _ (Derived _) (Fixes _) = NONE
1204 | finish_derived _ _ (Derived _) (Constrains _) = NONE
1205 | finish_derived sign satisfy (Derived _) (Assumes asms) = asms
1206 |> map (apsnd (map (fn (a, _) => ([Thm.assume (cterm_of sign a)], []))))
1207 |> pair Thm.assumptionK |> Notes
1208 |> Element.morph_ctxt satisfy |> SOME
1209 | finish_derived sign satisfy (Derived _) (Defines defs) = defs
1210 |> map (apsnd (fn (d, _) => [([Thm.assume (cterm_of sign d)], [])]))
1211 |> pair Thm.definitionK |> Notes
1212 |> Element.morph_ctxt satisfy |> SOME
1214 | finish_derived _ satisfy _ (Notes facts) = Notes facts
1215 |> Element.morph_ctxt satisfy |> SOME;
1217 (* CB: for finish_elems (Ext) *)
1219 fun closeup _ false elem = elem
1220 | closeup ctxt true elem =
1223 let val frees = rev (filter_out (Variable.is_fixed ctxt o #1) (Term.add_frees t []))
1224 in Term.list_all_free (frees, t) end;
1226 fun no_binds [] = []
1227 | no_binds _ = error "Illegal term bindings in locale element";
1230 Assumes asms => Assumes (asms |> map (fn (a, propps) =>
1231 (a, map (fn (t, ps) => (close_frees t, no_binds ps)) propps)))
1232 | Defines defs => Defines (defs |> map (fn (a, (t, ps)) =>
1233 (a, (close_frees (#2 (LocalDefs.cert_def ctxt t)), no_binds ps))))
1238 fun finish_ext_elem parms _ (Fixes fixes, _) = Fixes (map (fn (x, _, mx) =>
1239 (x, AList.lookup (op =) parms x, mx)) fixes)
1240 | finish_ext_elem parms _ (Constrains _, _) = Constrains []
1241 | finish_ext_elem _ close (Assumes asms, propp) =
1242 close (Assumes (map #1 asms ~~ propp))
1243 | finish_ext_elem _ close (Defines defs, propp) =
1244 close (Defines (map #1 defs ~~ map (fn [(t, ps)] => (t, ps)) propp))
1245 | finish_ext_elem _ _ (Notes facts, _) = Notes facts;
1248 (* CB: finish_parms introduces type info from parms to identifiers *)
1249 (* CB: only needed for types that have been NONE so far???
1250 If so, which are these??? *)
1252 fun finish_parms parms (((name, ps), mode), elems) =
1253 (((name, map (fn (x, _) => (x, AList.lookup (op = : string * string -> bool) parms x)) ps), mode), elems);
1255 fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) =
1257 val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)];
1258 val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths;
1259 val text' = fold (eval_text ctxt id' false) es text;
1260 val es' = map_filter
1261 (finish_derived (ProofContext.theory_of ctxt) (Element.satisfy_morphism wits') mode) es;
1262 in ((text', wits'), (id', map Int es')) end
1263 | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) =
1265 val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp);
1266 val text' = eval_text ctxt id true e' text;
1267 in ((text', wits), (id, [Ext e'])) end
1271 (* CB: only called by prep_elemss *)
1273 fun finish_elemss ctxt parms do_close =
1274 foldl_map (apsnd (finish_parms parms) o finish_elems ctxt parms do_close);
1279 (* Remove duplicate Defines elements: temporary workaround to fix Afp/Category. *)
1281 fun defs_ord (defs1, defs2) =
1282 list_ord (fn ((_, (d1, _)), (_, (d2, _))) =>
1283 Term.fast_term_ord (d1, d2)) (defs1, defs2);
1285 TableFun(type key = ((string * Attrib.src list) * (term * term list)) list
1286 val ord = defs_ord);
1288 fun rem_dup_defs es ds =
1289 fold_map (fn e as (Defines defs) => (fn ds =>
1290 if Defstab.defined ds defs
1291 then (Defines [], ds)
1292 else (e, Defstab.update (defs, ()) ds))
1293 | e => (fn ds => (e, ds))) es ds;
1294 fun rem_dup_elemss (Int es) ds = apfst Int (rem_dup_defs es ds)
1295 | rem_dup_elemss (Ext e) ds = (Ext e, ds);
1296 fun rem_dup_defines raw_elemss =
1297 fold_map (fn (id as (_, (Assumed _)), es) => (fn ds =>
1298 apfst (pair id) (rem_dup_elemss es ds))
1299 | (id as (_, (Derived _)), es) => (fn ds =>
1300 ((id, es), ds))) raw_elemss Defstab.empty |> #1;
1302 (* CB: type inference and consistency checks for locales.
1304 Works by building a context (through declare_elemss), extracting the
1305 required information and adjusting the context elements (finish_elemss).
1306 Can also universally close free vars in assms and defs. This is only
1307 needed for Ext elements and controlled by parameter do_close.
1309 Only elements of assumed identifiers are considered.
1312 fun prep_elemss prep_vars prepp do_close context fixed_params raw_elemss raw_concl =
1314 (* CB: contexts computed in the course of this function are discarded.
1315 They are used for type inference and consistency checks only. *)
1316 (* CB: fixed_params are the parameters (with types) of the target locale,
1317 empty list if there is no target. *)
1318 (* CB: raw_elemss are list of pairs consisting of identifiers and
1319 context elements, the latter marked as internal or external. *)
1320 val raw_elemss = rem_dup_defines raw_elemss;
1321 val (raw_ctxt, raw_proppss) = declare_elemss prep_vars fixed_params raw_elemss context;
1322 (* CB: raw_ctxt is context with additional fixed variables derived from
1323 the fixes elements in raw_elemss,
1324 raw_proppss contains assumptions and definitions from the
1325 external elements in raw_elemss. *)
1326 fun prep_prop raw_propp (raw_ctxt, raw_concl) =
1328 (* CB: add type information from fixed_params to context (declare_term) *)
1329 (* CB: process patterns (conclusion and external elements only) *)
1330 val (ctxt, all_propp) =
1331 prepp (fold Variable.declare_term (map Free fixed_params) raw_ctxt, raw_concl @ raw_propp);
1332 (* CB: add type information from conclusion and external elements to context *)
1333 val ctxt = fold Variable.declare_term (maps (map fst) all_propp) ctxt;
1334 (* CB: resolve schematic variables (patterns) in conclusion and external elements. *)
1335 val all_propp' = map2 (curry (op ~~))
1336 (#1 (#2 (ProofContext.bind_propp_schematic_i (ctxt, all_propp)))) (map (map snd) all_propp);
1337 val (concl, propp) = chop (length raw_concl) all_propp';
1338 in (propp, (ctxt, concl)) end
1340 val (proppss, (ctxt, concl)) =
1341 (fold_burrow o fold_burrow) prep_prop raw_proppss (raw_ctxt, raw_concl);
1343 (* CB: obtain all parameters from identifier part of raw_elemss *)
1344 val xs = map #1 (params_of' raw_elemss);
1345 val typing = unify_frozen ctxt 0
1346 (map (Variable.default_type raw_ctxt) xs)
1347 (map (Variable.default_type ctxt) xs);
1348 val parms = param_types (xs ~~ typing);
1349 (* CB: parms are the parameters from raw_elemss, with correct typing. *)
1351 (* CB: extract information from assumes and defines elements
1352 (fixes, constrains and notes in raw_elemss don't have an effect on
1353 text and elemss), compute final form of context elements. *)
1354 val ((text, _), elemss) = finish_elemss ctxt parms do_close
1355 ((((([], []), ([], [])), ([], [], [])), []), raw_elemss ~~ proppss);
1356 (* CB: text has the following structure:
1357 (((exts, exts'), (ints, ints')), (xs, env, defs))
1359 exts: external assumptions (terms in external assumes elements)
1360 exts': dito, normalised wrt. env
1361 ints: internal assumptions (terms in internal assumes elements)
1362 ints': dito, normalised wrt. env
1363 xs: the free variables in exts' and ints' and rhss of definitions,
1364 this includes parameters except defined parameters
1365 env: list of term pairs encoding substitutions, where the first term
1366 is a free variable; substitutions represent defines elements and
1367 the rhs is normalised wrt. the previous env
1368 defs: theorems representing the substitutions from defines elements
1369 (thms are normalised wrt. env).
1370 elemss is an updated version of raw_elemss:
1371 - type info added to Fixes and modified in Constrains
1372 - axiom and definition statement replaced by corresponding one
1373 from proppss in Assumes and Defines
1376 in ((parms, elemss, concl), text) end;
1380 fun read_elemss x = prep_elemss ProofContext.read_vars ProofContext.read_propp_schematic x;
1381 fun cert_elemss x = prep_elemss ProofContext.cert_vars ProofContext.cert_propp_schematic x;
1386 (* facts and attributes *)
1390 fun check_name name =
1391 if NameSpace.is_qualified name then error ("Illegal qualified name: " ^ quote name)
1394 fun prep_facts _ _ _ ctxt (Int elem) = elem
1395 |> Element.morph_ctxt (Morphism.thm_morphism (Thm.transfer (ProofContext.theory_of ctxt)))
1396 | prep_facts prep_name get intern ctxt (Ext elem) = elem |> Element.map_ctxt
1397 {var = I, typ = I, term = I,
1400 attrib = Args.assignable o intern (ProofContext.theory_of ctxt)};
1404 fun read_facts x = prep_facts check_name ProofContext.get_thms Attrib.intern_src x;
1405 fun cert_facts x = prep_facts I (K I) (K I) x;
1410 (* Get the specification of a locale *)
1412 (*The global specification is made from the parameters and global
1413 assumptions, the local specification from the parameters and the
1414 local assumptions.*)
1418 fun gen_asms_of get thy name =
1420 val ctxt = ProofContext.init thy;
1421 val (_, raw_elemss) = flatten (ctxt, I) (([], Symtab.empty), Expr (Locale name));
1422 val ((_, elemss, _), _) = read_elemss false ctxt [] raw_elemss [];
1425 |> maps (fn (_, es) => map (fn Int e => e) es)
1426 |> maps (fn Assumes asms => asms | _ => [])
1427 |> map (apsnd (map fst))
1432 fun parameters_of thy = #params o the_locale thy;
1434 fun intros thy = #intros o the_locale thy;
1435 (*returns introduction rule for delta predicate and locale predicate
1436 as a pair of singleton lists*)
1438 fun dests thy = #dests o the_locale thy;
1441 fun parameters_of_expr thy expr =
1443 val ctxt = ProofContext.init thy;
1444 val pts = params_of_expr ctxt [] (intern_expr thy expr)
1445 ([], Symtab.empty, Symtab.empty);
1446 val raw_params_elemss = make_raw_params_elemss pts;
1447 val ((_, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
1448 (([], Symtab.empty), Expr expr);
1449 val ((parms, _, _), _) =
1450 read_elemss false ctxt [] (raw_params_elemss @ raw_elemss) [];
1451 in map (fn p as (n, _) => (p, Symtab.lookup syn n |> the)) parms end;
1453 fun local_asms_of thy name =
1454 gen_asms_of (single o Library.last_elem) thy name;
1456 fun global_asms_of thy name =
1457 gen_asms_of I thy name;
1462 (* full context statements: imports + elements + conclusion *)
1466 fun prep_context_statement prep_expr prep_elemss prep_facts
1467 do_close fixed_params imports elements raw_concl context =
1469 val thy = ProofContext.theory_of context;
1471 val (import_params, import_tenv, import_syn) =
1472 params_of_expr context fixed_params (prep_expr thy imports)
1473 ([], Symtab.empty, Symtab.empty);
1474 val includes = map_filter (fn Expr e => SOME e | Elem _ => NONE) elements;
1475 val (incl_params, incl_tenv, incl_syn) = fold (params_of_expr context fixed_params)
1476 (map (prep_expr thy) includes) (import_params, import_tenv, import_syn);
1478 val ((import_ids, _), raw_import_elemss) =
1479 flatten (context, prep_expr thy) (([], Symtab.empty), Expr imports);
1480 (* CB: normalise "includes" among elements *)
1481 val ((ids, syn), raw_elemsss) = foldl_map (flatten (context, prep_expr thy))
1482 ((import_ids, incl_syn), elements);
1484 val raw_elemss = flat raw_elemsss;
1485 (* CB: raw_import_elemss @ raw_elemss is the normalised list of
1486 context elements obtained from import and elements. *)
1487 (* Now additional elements for parameters are inserted. *)
1488 val import_params_ids = make_params_ids import_params;
1489 val incl_params_ids =
1490 make_params_ids (incl_params \\ import_params);
1491 val raw_import_params_elemss =
1492 make_raw_params_elemss (import_params, incl_tenv, incl_syn);
1493 val raw_incl_params_elemss =
1494 make_raw_params_elemss (incl_params \\ import_params, incl_tenv, incl_syn);
1495 val ((parms, all_elemss, concl), (spec, (_, _, defs))) = prep_elemss do_close
1496 context fixed_params
1497 (raw_import_params_elemss @ raw_import_elemss @ raw_incl_params_elemss @ raw_elemss) raw_concl;
1499 (* replace extended ids (for axioms) by ids *)
1500 val (import_ids', incl_ids) = chop (length import_ids) ids;
1501 val all_ids = import_params_ids @ import_ids' @ incl_params_ids @ incl_ids;
1502 val all_elemss' = map (fn (((_, ps), _), (((n, ps'), mode), elems)) =>
1503 (((n, map (fn p => (p, (the o AList.lookup (op =) ps') p)) ps), mode), elems))
1504 (all_ids ~~ all_elemss);
1505 (* CB: all_elemss and parms contain the correct parameter types *)
1507 val (ps, qs) = chop (length raw_import_params_elemss + length raw_import_elemss) all_elemss';
1508 val (import_ctxt, (import_elemss, _)) =
1509 activate_facts false prep_facts (context, ps);
1511 val (ctxt, (elemss, _)) =
1512 activate_facts false prep_facts (ProofContext.set_stmt true import_ctxt, qs);
1514 ((((import_ctxt, import_elemss), (ctxt, elemss, syn)),
1515 (parms, spec, defs)), concl)
1518 fun prep_statement prep_locale prep_ctxt raw_locale elems concl ctxt =
1520 val thy = ProofContext.theory_of ctxt;
1521 val locale = Option.map (prep_locale thy) raw_locale;
1522 val (fixed_params, imports) =
1526 let val {params = ps, ...} = the_locale thy name
1527 in (map fst ps, Locale name) end);
1528 val ((((locale_ctxt, _), (elems_ctxt, _, _)), _), concl') =
1529 prep_ctxt false fixed_params imports elems concl ctxt;
1530 in (locale, locale_ctxt, elems_ctxt, concl') end;
1532 fun prep_expr prep imports body ctxt =
1534 val (((_, import_elemss), (ctxt', elemss, _)), _) = prep imports body ctxt;
1535 val all_elems = maps snd (import_elemss @ elemss);
1536 in (all_elems, ctxt') end;
1540 val read_ctxt = prep_context_statement intern_expr read_elemss read_facts;
1541 val cert_ctxt = prep_context_statement (K I) cert_elemss cert_facts;
1543 fun read_context imports body ctxt = #1 (read_ctxt true [] imports (map Elem body) [] ctxt);
1544 fun cert_context imports body ctxt = #1 (cert_ctxt true [] imports (map Elem body) [] ctxt);
1546 val read_expr = prep_expr read_context;
1547 val cert_expr = prep_expr cert_context;
1549 fun read_context_statement loc = prep_statement intern read_ctxt loc;
1550 fun read_context_statement_i loc = prep_statement (K I) read_ctxt loc;
1551 fun cert_context_statement loc = prep_statement (K I) cert_ctxt loc;
1560 #> (#2 o cert_context_statement (SOME loc) [] []);
1565 fun print_locale thy show_facts imports body =
1566 let val (all_elems, ctxt) = read_expr imports body (ProofContext.init thy) in
1567 Pretty.big_list "locale elements:" (all_elems
1568 |> (if show_facts then I else filter (fn Notes _ => false | _ => true))
1569 |> map (Element.pretty_ctxt ctxt) |> filter_out null
1570 |> map Pretty.chunks)
1576 (** store results **)
1578 (* naming of interpreted theorems *)
1580 fun global_note_prefix_i kind (fully_qualified, prfx) args thy =
1582 |> Sign.qualified_names
1583 |> (if fully_qualified then Sign.sticky_prefix prfx else Sign.add_path prfx)
1584 |> PureThy.note_thmss_i kind args
1585 ||> Sign.restore_naming thy;
1587 fun local_note_prefix_i kind (fully_qualified, prfx) args ctxt =
1589 |> ProofContext.qualified_names
1590 |> (if fully_qualified then ProofContext.sticky_prefix prfx else ProofContext.add_path prfx)
1591 |> ProofContext.note_thmss_i kind args
1592 ||> ProofContext.restore_naming ctxt;
1595 (* join equations of an id with already accumulated ones *)
1597 fun join_eqns get_reg prep_id ctxt id eqns =
1599 val id' = prep_id id
1600 val eqns' = case get_reg id'
1602 | SOME (_, _, eqns') => Termtab.join (fn t => fn (_, e) => e) (eqns, eqns')
1603 handle Termtab.DUP t =>
1604 error ("Conflicting interpreting equations for term " ^
1605 quote (Syntax.string_of_term ctxt t))
1606 in ((id', eqns'), eqns') end;
1609 (* collect witnesses and equations up to a particular target for global
1610 registration; requires parameters and flattened list of identifiers
1611 instead of recomputing it from the target *)
1613 fun collect_global_witnesses thy imprt parms ids vts = let
1614 val ts = map Logic.unvarify vts;
1615 val (parms, parmTs) = split_list parms;
1616 val parmvTs = map Logic.varifyT parmTs;
1617 val vtinst = fold (Sign.typ_match thy) (parmvTs ~~ map Term.fastype_of ts) Vartab.empty;
1618 val tinst = Vartab.dest vtinst |> map (fn ((x, 0), (_, T)) => (x, T))
1620 (* replace parameter names in ids by instantiations *)
1621 val vinst = Symtab.make (parms ~~ vts);
1622 fun vinst_names ps = map (the o Symtab.lookup vinst) ps;
1623 val inst = Symtab.make (parms ~~ ts);
1624 val inst_ids = map (apfst (apsnd vinst_names)) ids;
1625 val assumed_ids' = map_filter (fn (id, (_, Assumed _)) => SOME id | _ => NONE) inst_ids;
1626 val wits = maps (#2 o the o get_global_registration thy imprt) assumed_ids';
1628 val ids' = map fst inst_ids;
1630 fold_map (join_eqns (get_global_registration thy imprt) I (ProofContext.init thy))
1631 ids' Termtab.empty |> snd |> Termtab.dest |> map snd;
1632 in ((tinst, inst), wits, eqns) end;
1635 (* standardise export morphism *)
1637 (* clone from Element.generalize_facts *)
1638 fun standardize thy export facts =
1640 val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export;
1641 val exp_term = TermSubst.zero_var_indexes o Morphism.term export;
1642 (* FIXME sync with exp_fact *)
1643 val exp_typ = Logic.type_map exp_term;
1645 Morphism.morphism {name = I, var = I, typ = exp_typ, term = exp_term, fact = exp_fact};
1646 in Element.facts_map (Element.morph_ctxt morphism) facts end;
1649 (* suppress application of name morphism: workaroud for class package *) (* FIXME *)
1651 fun morph_ctxt' phi = Element.map_ctxt
1653 var = Morphism.var phi,
1654 typ = Morphism.typ phi,
1655 term = Morphism.term phi,
1656 fact = Morphism.fact phi,
1657 attrib = Args.morph_values phi};
1660 (* compute morphism and apply to args *)
1662 fun interpret_args thy prfx insts prems eqns atts2 exp attrib args =
1664 val inst = Morphism.name_morphism (NameSpace.qualified prfx) $>
1665 Element.inst_morphism thy insts $> Element.satisfy_morphism prems $>
1666 Morphism.term_morphism (MetaSimplifier.rewrite_term thy eqns []) $>
1667 Morphism.thm_morphism (MetaSimplifier.rewrite_rule eqns)
1669 args |> Element.facts_map (morph_ctxt' inst) |>
1670 map (fn (attn, bs) => (attn,
1671 bs |> map (fn (ths, atts) => (ths, (atts @ atts2))))) |>
1672 standardize thy exp |> Attrib.map_facts attrib
1676 (* store instantiations of args for all registered interpretations
1679 fun note_thmss_registrations target (kind, args) thy =
1681 val parms = the_locale thy target |> #params |> map fst;
1682 val ids = flatten (ProofContext.init thy, intern_expr thy)
1683 (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
1685 val regs = get_global_registrations thy target;
1686 (* add args to thy for all registrations *)
1688 fun activate (vts, (((fully_qualified, prfx), atts2), (exp, imp), _, _)) thy =
1690 val (insts, prems, eqns) = collect_global_witnesses thy imp parms ids vts;
1691 val attrib = Attrib.attribute_i thy;
1692 val args' = interpret_args thy prfx insts prems eqns atts2 exp attrib args;
1693 in global_note_prefix_i kind (fully_qualified, prfx) args' thy |> snd end;
1694 in fold activate regs thy end;
1697 (* locale results *)
1699 fun add_thmss loc kind args ctxt =
1701 val (ctxt', ([(_, [Notes args'])], _)) =
1702 activate_facts true cert_facts
1703 (ctxt, [((("", []), Assumed []), [Ext (Notes (kind, args))])]);
1704 val ctxt'' = ctxt' |> ProofContext.theory
1706 (fn (axiom, imports, elems, params, lparams, decls, regs, intros, dests) =>
1707 (axiom, imports, elems @ [(Notes args', stamp ())],
1708 params, lparams, decls, regs, intros, dests))
1709 #> note_thmss_registrations loc args');
1717 fun decl_attrib decl phi = Thm.declaration_attribute (K (decl phi));
1719 fun add_decls add loc decl =
1720 ProofContext.theory (change_locale loc
1721 (fn (axiom, imports, elems, params, lparams, decls, regs, intros, dests) =>
1722 (axiom, imports, elems, params, lparams, add (decl, stamp ()) decls, regs, intros, dests))) #>
1723 add_thmss loc Thm.internalK
1724 [(("", [Attrib.internal (decl_attrib decl)]), [([Drule.dummy_thm], [])])];
1728 val add_type_syntax = add_decls (apfst o cons);
1729 val add_term_syntax = add_decls (apsnd o cons);
1730 val add_declaration = add_decls (K I);
1736 (** define locales **)
1738 (* predicate text *)
1739 (* CB: generate locale predicates and delta predicates *)
1743 (* introN: name of theorems for introduction rules of locale and
1745 axiomsN: name of theorem set with destruct rules for locale predicates,
1746 also name suffix of delta predicates. *)
1748 val introN = "intro";
1749 val axiomsN = "axioms";
1751 fun atomize_spec thy ts =
1753 val t = Logic.mk_conjunction_balanced ts;
1754 val body = ObjectLogic.atomize_term thy t;
1755 val bodyT = Term.fastype_of body;
1757 if bodyT = propT then (t, propT, Thm.reflexive (Thm.cterm_of thy t))
1758 else (body, bodyT, ObjectLogic.atomize (Thm.cterm_of thy t))
1761 fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args =>
1762 if length args = n then
1763 Syntax.const "_aprop" $
1764 Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args)
1767 (* CB: define one predicate including its intro rule and axioms
1768 - bname: predicate name
1769 - parms: locale parameters
1770 - defs: thms representing substitutions from defines elements
1771 - ts: terms representing locale assumptions (not normalised wrt. defs)
1772 - norm_ts: terms representing locale assumptions (normalised wrt. defs)
1776 fun def_pred bname parms defs ts norm_ts thy =
1778 val name = Sign.full_name thy bname;
1780 val (body, bodyT, body_eq) = atomize_spec thy norm_ts;
1781 val env = Term.add_term_free_names (body, []);
1782 val xs = filter (member (op =) env o #1) parms;
1784 val extraTs = (Term.term_tfrees body \\ List.foldr Term.add_typ_tfrees [] Ts)
1785 |> Library.sort_wrt #1 |> map TFree;
1786 val predT = map Term.itselfT extraTs ---> Ts ---> bodyT;
1788 val args = map Logic.mk_type extraTs @ map Free xs;
1789 val head = Term.list_comb (Const (name, predT), args);
1790 val statement = ObjectLogic.ensure_propT thy head;
1792 val ([pred_def], defs_thy) =
1794 |> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
1795 |> Sign.declare_const [] (bname, predT, NoSyn) |> snd
1796 |> PureThy.add_defs_i false [((Thm.def_name bname, Logic.mk_equals (head, body)), [])];
1797 val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;
1799 val cert = Thm.cterm_of defs_thy;
1801 val intro = Goal.prove_global defs_thy [] norm_ts statement (fn _ =>
1802 MetaSimplifier.rewrite_goals_tac [pred_def] THEN
1803 Tactic.compose_tac (false, body_eq RS Drule.equal_elim_rule1, 1) 1 THEN
1804 Tactic.compose_tac (false,
1805 Conjunction.intr_balanced (map (Thm.assume o cert) norm_ts), 0) 1);
1808 (Drule.equal_elim_rule2 OF [body_eq,
1809 MetaSimplifier.rewrite_rule [pred_def] (Thm.assume (cert statement))])
1810 |> Conjunction.elim_balanced (length ts);
1811 val axioms = ts ~~ conjuncts |> map (fn (t, ax) =>
1812 Element.prove_witness defs_ctxt t
1813 (MetaSimplifier.rewrite_goals_tac defs THEN
1814 Tactic.compose_tac (false, ax, 0) 1));
1815 in ((statement, intro, axioms), defs_thy) end;
1817 fun assumes_to_notes (Assumes asms) axms =
1818 fold_map (fn (a, spec) => fn axs =>
1819 let val (ps, qs) = chop (length spec) axs
1820 in ((a, [(ps, [])]), qs) end) asms axms
1821 |> apfst (curry Notes Thm.assumptionK)
1822 | assumes_to_notes e axms = (e, axms);
1824 (* CB: the following two change only "new" elems, these have identifier ("", _). *)
1826 (* turn Assumes into Notes elements *)
1828 fun change_assumes_elemss axioms elemss =
1830 val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
1831 fun change (id as ("", _), es) =
1832 fold_map assumes_to_notes (map satisfy es)
1833 #-> (fn es' => pair (id, es'))
1834 | change e = pair e;
1836 fst (fold_map change elemss (map Element.conclude_witness axioms))
1839 (* adjust hyps of Notes elements *)
1841 fun change_elemss_hyps axioms elemss =
1843 val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
1844 fun change (id as ("", _), es) = (id, map (fn e as Notes _ => satisfy e | e => e) es)
1846 in map change elemss end;
1850 (* CB: main predicate definition function *)
1852 fun define_preds pname (parms, ((exts, exts'), (ints, ints')), defs) elemss thy =
1854 val ((elemss', more_ts), a_elem, a_intro, thy'') =
1855 if null exts then ((elemss, []), [], [], thy)
1858 val aname = if null ints then pname else pname ^ "_" ^ axiomsN;
1859 val ((statement, intro, axioms), thy') =
1861 |> def_pred aname parms defs exts exts';
1862 val elemss' = change_assumes_elemss axioms elemss;
1863 val a_elem = [(("", []), [Assumes [((pname ^ "_" ^ axiomsN, []), [(statement, [])])]])];
1866 |> PureThy.note_thmss_qualified Thm.internalK aname [((introN, []), [([intro], [])])];
1867 in ((elemss', [statement]), a_elem, [intro], thy'') end;
1868 val (predicate, stmt', elemss'', b_intro, thy'''') =
1869 if null ints then (([], []), more_ts, elemss' @ a_elem, [], thy'')
1872 val ((statement, intro, axioms), thy''') =
1874 |> def_pred pname parms defs (ints @ more_ts) (ints' @ more_ts);
1875 val cstatement = Thm.cterm_of thy''' statement;
1876 val elemss'' = change_elemss_hyps axioms elemss';
1877 val b_elem = [(("", []),
1878 [Assumes [((pname ^ "_" ^ axiomsN, []), [(statement, [])])]])];
1881 |> PureThy.note_thmss_qualified Thm.internalK pname
1882 [((introN, []), [([intro], [])]),
1883 ((axiomsN, []), [(map (Drule.standard o Element.conclude_witness) axioms, [])])];
1884 in (([cstatement], axioms), [statement], elemss'' @ b_elem, [intro], thy'''') end;
1885 in (((elemss'', predicate, stmt'), (a_intro, b_intro)), thy'''') end;
1890 (* add_locale(_i) *)
1894 (* turn Defines into Notes elements, accumulate definition terms *)
1896 fun defines_to_notes is_ext thy (Defines defs) defns =
1898 val defs' = map (fn (_, (def, _)) => (("", []), (def, []))) defs
1899 val notes = map (fn (a, (def, _)) =>
1900 (a, [([assume (cterm_of thy def)], [])])) defs
1902 (if is_ext then SOME (Notes (Thm.definitionK, notes)) else NONE, defns @ [Defines defs'])
1904 | defines_to_notes _ _ e defns = (SOME e, defns);
1906 fun change_defines_elemss thy elemss defns =
1908 fun change (id as (n, _), es) defns =
1910 val (es', defns') = fold_map (defines_to_notes (n="") thy) es defns
1911 in ((id, map_filter I es'), defns') end
1912 in fold_map change elemss defns end;
1914 fun gen_add_locale prep_ctxt prep_expr
1915 predicate_name bname raw_imports raw_body thy =
1916 (* predicate_name: NONE - open locale without predicate
1917 SOME "" - locale with predicate named as locale
1918 SOME "name" - locale with predicate named "name" *)
1920 val name = Sign.full_name thy bname;
1921 val _ = is_some (get_locale thy name) andalso
1922 error ("Duplicate definition of locale " ^ quote name);
1924 val thy_ctxt = ProofContext.init thy;
1925 val (((import_ctxt, import_elemss), (body_ctxt, body_elemss, syn)),
1926 text as (parms, ((_, exts'), _), defs)) =
1927 prep_ctxt raw_imports raw_body thy_ctxt;
1928 val elemss = import_elemss @ body_elemss |>
1929 map_filter (fn ((id, Assumed axs), elems) => SOME (id, elems) | _ => NONE);
1930 val imports = prep_expr thy raw_imports;
1932 val extraTs = List.foldr Term.add_term_tfrees [] exts' \\
1933 List.foldr Term.add_typ_tfrees [] (map snd parms);
1934 val _ = if null extraTs then ()
1935 else warning ("Additional type variable(s) in locale specification " ^ quote bname);
1937 val ((((elemss', predicate as (predicate_statement, predicate_axioms), stmt'), intros),
1938 pred_thy), (imports, regs)) =
1940 of SOME predicate_name =>
1942 val predicate_name' = case predicate_name of "" => bname | _ => predicate_name;
1943 val (elemss', defns) = change_defines_elemss thy elemss [];
1944 val elemss'' = elemss' @ [(("", []), defns)];
1945 val (((elemss''', predicate as (_, axioms), stmt'), intros), thy') =
1946 define_preds predicate_name' text elemss'' thy;
1947 fun mk_regs elemss wits =
1948 fold_map (fn (id, elems) => fn wts => let
1949 val ts = List.concat (List.mapPartial (fn (Assumes asms) =>
1950 SOME (List.concat (map (map #1 o #2) asms)) | _ => NONE) elems);
1951 val (wts1, wts2) = chop (length ts) wts
1952 in ((apsnd (map fst) id, wts1), wts2) end) elemss wits |> fst;
1953 val regs = mk_regs elemss''' axioms |>
1954 map_filter (fn (("", _), _) => NONE | e => SOME e);
1955 in ((((elemss''', predicate, stmt'), intros), thy'), (empty, regs)) end
1956 | NONE => ((((elemss, ([], []), []), ([], [])), thy), (imports, []));
1958 fun axiomify axioms elemss =
1959 (axioms, elemss) |> foldl_map (fn (axs, (id, elems)) => let
1960 val ts = flat (map_filter (fn (Assumes asms) =>
1961 SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
1962 val (axs1, axs2) = chop (length ts) axs;
1963 in (axs2, ((id, Assumed axs1), elems)) end)
1965 val (ctxt, (_, facts)) = activate_facts true (K I)
1966 (ProofContext.init pred_thy, axiomify predicate_axioms elemss');
1967 val view_ctxt = Assumption.add_view thy_ctxt predicate_statement ctxt;
1968 val export = Goal.close_result o Goal.norm_result o
1969 singleton (ProofContext.export view_ctxt thy_ctxt);
1970 val facts' = facts |> map (fn (a, ths) => ((a, []), [(map export ths, [])]));
1971 val elems' = maps #2 (filter (equal "" o #1 o #1) elemss');
1972 val elems'' = map_filter (fn (Fixes _) => NONE | e => SOME e) elems';
1973 val axs' = map (Element.assume_witness pred_thy) stmt';
1974 val loc_ctxt = pred_thy
1975 |> PureThy.note_thmss_qualified Thm.assumptionK bname facts' |> snd
1976 |> declare_locale name
1980 elems = map (fn e => (e, stamp ())) elems'',
1981 params = params_of elemss' |> map (fn (x, SOME T) => ((x, T), the (Symtab.lookup syn x))),
1982 lparams = map #1 (params_of' body_elemss),
1986 dests = map Element.conclude_witness predicate_axioms}
1988 in (name, loc_ctxt) end;
1992 val add_locale = gen_add_locale read_context intern_expr;
1993 val add_locale_i = gen_add_locale cert_context (K I);
1997 val _ = Context.add_setup
1998 (add_locale_i (SOME "") "var" empty [Fixes [(Name.internal "x", NONE, NoSyn)]] #>
1999 snd #> ProofContext.theory_of #>
2000 add_locale_i (SOME "") "struct" empty [Fixes [(Name.internal "S", NONE, Structure)]] #>
2001 snd #> ProofContext.theory_of);
2006 (** Normalisation of locale statements ---
2007 discharges goals implied by interpretations **)
2011 fun locale_assm_intros thy =
2012 Symtab.fold (fn (_, {intros = (a, _), ...}) => fn intros => (a @ intros))
2013 (#2 (LocalesData.get thy)) [];
2014 fun locale_base_intros thy =
2015 Symtab.fold (fn (_, {intros = (_, b), ...}) => fn intros => (b @ intros))
2016 (#2 (LocalesData.get thy)) [];
2018 fun all_witnesses ctxt =
2020 val thy = ProofContext.theory_of ctxt;
2021 fun get registrations = Symtab.fold (fn (_, regs) => fn thms =>
2022 (Registrations.dest thy regs |> map (fn (_, (_, (exp, _), wits, _)) =>
2023 map (Element.conclude_witness #> Morphism.thm exp) wits) |> flat) @ thms)
2025 in get (RegistrationsData.get (Context.Proof ctxt)) end;
2029 fun intro_locales_tac eager ctxt facts st =
2031 val wits = all_witnesses ctxt;
2032 val thy = ProofContext.theory_of ctxt;
2033 val intros = locale_base_intros thy @ (if eager then locale_assm_intros thy else []);
2035 Method.intros_tac (wits @ intros) facts st
2038 val _ = Context.add_setup (Method.add_methods
2040 Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac false ctxt)),
2041 "back-chain introduction rules of locales without unfolding predicates"),
2043 Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac true ctxt)),
2044 "back-chain all introduction rules of locales")]);
2049 (** Interpretation commands **)
2053 (* extract proof obligations (assms and defs) from elements *)
2055 fun extract_asms_elems ((id, Assumed _), elems) = (id, maps Element.prems_of elems)
2056 | extract_asms_elems ((id, Derived _), _) = (id, []);
2059 (* activate instantiated facts in theory or context *)
2062 TableFun(type key = string * term list
2063 val ord = prod_ord string_ord (list_ord Term.fast_term_ord));
2065 fun gen_activate_facts_elemss mk_ctxt get_reg note note_interp attrib put_reg add_wit add_eqn
2066 attn all_elemss new_elemss propss eq_attns (exp, imp) thmss thy_ctxt =
2068 val ctxt = mk_ctxt thy_ctxt;
2069 val (propss, eq_props) = chop (length new_elemss) propss;
2070 val (thmss, eq_thms) = chop (length new_elemss) thmss;
2072 fun activate_elem prems eqns exp ((fully_qualified, prfx), atts) (Notes (kind, facts)) thy_ctxt =
2074 val ctxt = mk_ctxt thy_ctxt;
2075 val facts' = interpret_args (ProofContext.theory_of ctxt) prfx
2076 (Symtab.empty, Symtab.empty) prems eqns atts
2077 exp (attrib thy_ctxt) facts;
2078 in snd (note_interp kind (fully_qualified, prfx) facts' thy_ctxt) end
2079 | activate_elem _ _ _ _ _ thy_ctxt = thy_ctxt;
2081 fun activate_elems prems eqns exp ((id, _), elems) thy_ctxt =
2083 val (prfx_atts, _, _) = case get_reg thy_ctxt imp id
2085 | NONE => sys_error ("Unknown registration of " ^ quote (fst id)
2086 ^ " while activating facts.");
2087 in fold (activate_elem prems (the (Idtab.lookup eqns id)) exp prfx_atts) elems thy_ctxt end;
2089 val thy_ctxt' = thy_ctxt
2090 (* add registrations *)
2091 |> fold (fn ((id, _), _) => put_reg id attn (exp, imp)) new_elemss
2092 (* add witnesses of Assumed elements (only those generate proof obligations) *)
2093 |> fold (fn (id, thms) => fold (add_wit id) thms) (map fst propss ~~ thmss)
2095 |> fold (fn (id, thms) => fold (add_eqn id) thms) (map fst eq_props ~~
2096 (map o map) (Drule.abs_def o LocalDefs.meta_rewrite_rule ctxt o
2097 Element.conclude_witness) eq_thms);
2099 val prems = flat (map_filter
2100 (fn ((id, Assumed _), _) => Option.map #2 (get_reg thy_ctxt' imp id)
2101 | ((_, Derived _), _) => NONE) all_elemss);
2102 val thy_ctxt'' = thy_ctxt'
2103 (* add witnesses of Derived elements *)
2104 |> fold (fn (id, thms) => fold (add_wit id o Element.morph_witness (Element.satisfy_morphism prems)) thms)
2105 (map_filter (fn ((_, Assumed _), _) => NONE
2106 | ((id, Derived thms), _) => SOME (id, thms)) new_elemss)
2108 (* Accumulate equations *)
2110 fold_map (join_eqns (get_reg thy_ctxt'' imp) (fst o fst) ctxt) all_elemss Termtab.empty
2112 |> map (apsnd (map snd o Termtab.dest))
2113 |> (fn xs => fold Idtab.update xs Idtab.empty)
2114 (* Idtab.make wouldn't work here: can have conflicting duplicates,
2115 because instantiation may equate ids and equations are accumulated! *)
2119 |> fold (fn (attns, thms) =>
2120 fold (fn (attn, thm) => note "lemma"
2121 [(apsnd (map (attrib thy_ctxt'')) attn,
2122 [([Element.conclude_witness thm], [])])] #> snd)
2123 (attns ~~ thms)) (unflat eq_thms eq_attns ~~ eq_thms)
2125 |> fold (activate_elems prems all_eqns exp) new_elemss
2128 fun global_activate_facts_elemss x = gen_activate_facts_elemss
2130 get_global_registration
2131 PureThy.note_thmss_i
2132 global_note_prefix_i
2134 put_global_registration add_global_witness add_global_equation
2137 fun local_activate_facts_elemss x = gen_activate_facts_elemss
2139 get_local_registration
2140 ProofContext.note_thmss_i
2142 (Attrib.attribute_i o ProofContext.theory_of)
2143 put_local_registration
2148 fun prep_instantiations parse_term parse_prop ctxt parms (insts, eqns) =
2151 val (parm_names, parm_types) = parms |> split_list
2152 ||> map (TypeInfer.paramify_vars o Logic.varifyT);
2153 val type_parms = fold Term.add_tvarsT parm_types [] |> map (Logic.mk_type o TVar);
2154 val type_parm_names = fold Term.add_tfreesT (map snd parms) [] |> map fst;
2156 (* parameter instantiations *)
2157 val d = length parms - length insts;
2159 if d < 0 then error "More arguments than parameters in instantiation."
2160 else insts @ replicate d NONE;
2161 val (given_ps, given_insts) =
2162 ((parm_names ~~ parm_types) ~~ insts) |> map_filter
2163 (fn (_, NONE) => NONE
2164 | ((n, T), SOME inst) => SOME ((n, T), inst))
2166 val (given_parm_names, given_parm_types) = given_ps |> split_list;
2168 (* parse insts / eqns *)
2169 val given_insts' = map (parse_term ctxt) given_insts;
2170 val eqns' = map (parse_prop ctxt) eqns;
2172 (* type inference and contexts *)
2173 val arg = type_parms @ map2 TypeInfer.constrain given_parm_types given_insts' @ eqns';
2174 val res = Syntax.check_terms ctxt arg;
2175 val ctxt' = ctxt |> fold Variable.auto_fixes res;
2178 val (type_parms'', res') = chop (length type_parms) res;
2179 val (given_insts'', eqns'') = chop (length given_insts) res';
2180 val instT = Symtab.make (type_parm_names ~~ map Logic.dest_type type_parms'');
2181 val inst = Symtab.make (given_parm_names ~~ given_insts'');
2183 (* export from eigencontext *)
2184 val export = Variable.export_morphism ctxt' ctxt;
2186 (* import, its inverse *)
2187 val domT = fold Term.add_tfrees res [] |> map TFree;
2188 val importT = domT |> map (fn x => (Morphism.typ export x, x))
2189 |> map_filter (fn (TFree _, _) => NONE (* fixed point of export *)
2190 | (TVar y, x) => SOME (fst y, x)
2191 | _ => error "internal: illegal export in interpretation")
2193 val dom = fold Term.add_frees res [] |> map Free;
2194 val imprt = dom |> map (fn x => (Morphism.term export x, x))
2195 |> map_filter (fn (Free _, _) => NONE (* fixed point of export *)
2196 | (Var y, x) => SOME (fst y, x)
2197 | _ => error "internal: illegal export in interpretation")
2199 in (((instT, inst), eqns''), (export, ((importT, domT), (imprt, dom)))) end;
2201 val read_instantiations = prep_instantiations Syntax.parse_term Syntax.parse_prop;
2202 val check_instantiations = prep_instantiations (K I) (K I);
2204 fun gen_prep_registration mk_ctxt test_reg activate
2205 prep_attr prep_expr prep_insts
2206 thy_ctxt raw_attn raw_expr raw_insts =
2208 val ctxt = mk_ctxt thy_ctxt;
2209 val thy = ProofContext.theory_of ctxt;
2210 val ctxt' = ProofContext.init thy;
2211 fun prep_attn attn = (apsnd o map)
2212 (Attrib.crude_closure ctxt o Args.assignable o prep_attr thy) attn;
2214 val attn = prep_attn raw_attn;
2215 val expr = prep_expr thy raw_expr;
2217 val pts = params_of_expr ctxt' [] expr ([], Symtab.empty, Symtab.empty);
2218 val params_ids = make_params_ids (#1 pts);
2219 val raw_params_elemss = make_raw_params_elemss pts;
2220 val ((ids, _), raw_elemss) = flatten (ctxt', I) (([], Symtab.empty), Expr expr);
2221 val ((parms, all_elemss, _), (_, (_, defs, _))) =
2222 read_elemss false ctxt' [] (raw_params_elemss @ raw_elemss) [];
2224 (** compute instantiation **)
2226 (* consistency check: equations need to be stored in a particular locale,
2227 therefore if equations are present locale expression must be a name *)
2229 val _ = case (expr, snd raw_insts) of
2230 (Locale _, _) => () | (_, []) => ()
2231 | (_, _) => error "Interpretations with `where' only permitted if locale expression is a name.";
2233 (* read or certify instantiation *)
2234 val (raw_insts', raw_eqns) = raw_insts;
2235 val (raw_eq_attns, raw_eqns') = split_list raw_eqns;
2236 val (((instT, inst1), eqns), morphs) = prep_insts ctxt parms (raw_insts', raw_eqns');
2237 val eq_attns = map prep_attn raw_eq_attns;
2239 (* defined params without given instantiation *)
2240 val not_given = filter_out (Symtab.defined inst1 o fst) parms;
2241 fun add_def (p, pT) inst =
2243 val (t, T) = case find_first (fn (Free (a, _), _) => a = p) defs of
2244 NONE => error ("Instance missing for parameter " ^ quote p)
2245 | SOME (Free (_, T), t) => (t, T);
2246 val d = Element.inst_term (instT, inst) t;
2247 in Symtab.update_new (p, d) inst end;
2248 val inst2 = fold add_def not_given inst1;
2249 val inst_morphism = Element.inst_morphism thy (instT, inst2);
2250 (* Note: insts contain no vars. *)
2252 (** compute proof obligations **)
2254 (* restore "small" ids *)
2255 val ids' = map (fn ((n, ps), (_, mode)) =>
2256 ((n, map (fn p => Free (p, (the o AList.lookup (op =) parms) p)) ps), mode))
2258 val (_, all_elemss') = chop (length raw_params_elemss) all_elemss
2259 (* instantiate ids and elements *)
2260 val inst_elemss = (ids' ~~ all_elemss') |> map (fn (((n, ps), _), ((_, mode), elems)) =>
2261 ((n, map (Morphism.term (inst_morphism $> fst morphs)) ps),
2262 map (fn Int e => Element.morph_ctxt inst_morphism e) elems)
2263 |> apfst (fn id => (id, map_mode (map (Element.morph_witness inst_morphism)) mode)));
2265 (* remove fragments already registered with theory or context *)
2266 val new_inst_elemss = filter_out (fn ((id, _), _) =>
2267 test_reg thy_ctxt id) inst_elemss;
2270 val eqn_elems = if null eqns then []
2271 else [(Library.last_elem inst_elemss |> fst |> fst, eqns)];
2273 val propss = map extract_asms_elems new_inst_elemss @ eqn_elems;
2275 in (propss, activate attn inst_elemss new_inst_elemss propss eq_attns morphs) end;
2277 fun gen_prep_global_registration mk_ctxt = gen_prep_registration ProofContext.init
2278 test_global_registration
2279 global_activate_facts_elemss mk_ctxt;
2281 fun gen_prep_local_registration mk_ctxt = gen_prep_registration I
2282 test_local_registration
2283 local_activate_facts_elemss mk_ctxt;
2285 val prep_global_registration = gen_prep_global_registration
2286 Attrib.intern_src intern_expr read_instantiations;
2287 val prep_global_registration_i = gen_prep_global_registration
2288 (K I) (K I) check_instantiations;
2290 val prep_local_registration = gen_prep_local_registration
2291 Attrib.intern_src intern_expr read_instantiations;
2292 val prep_local_registration_i = gen_prep_local_registration
2293 (K I) (K I) check_instantiations;
2295 fun prep_registration_in_locale target expr thy =
2296 (* target already in internal form *)
2298 val ctxt = ProofContext.init thy;
2299 val ((raw_target_ids, target_syn), _) = flatten (ctxt, I)
2300 (([], Symtab.empty), Expr (Locale target));
2301 val fixed = the_locale thy target |> #params |> map #1;
2302 val ((all_ids, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
2303 ((raw_target_ids, target_syn), Expr expr);
2304 val (target_ids, ids) = chop (length raw_target_ids) all_ids;
2305 val ((parms, elemss, _), _) = read_elemss false ctxt fixed raw_elemss [];
2307 (** compute proof obligations **)
2309 (* restore "small" ids, with mode *)
2310 val ids' = map (apsnd snd) ids;
2311 (* remove Int markers *)
2312 val elemss' = map (fn (_, es) =>
2313 map (fn Int e => e) es) elemss
2314 (* extract assumptions and defs *)
2315 val ids_elemss = ids' ~~ elemss';
2316 val propss = map extract_asms_elems ids_elemss;
2318 (** activation function:
2319 - add registrations to the target locale
2320 - add induced registrations for all global registrations of
2321 the target, unless already present
2322 - add facts of induced registrations to theory **)
2324 fun activate thmss thy = let
2325 val satisfy = Element.satisfy_thm (flat thmss);
2326 val ids_elemss_thmss = ids_elemss ~~ thmss;
2327 val regs = get_global_registrations thy target;
2329 fun activate_id (((id, Assumed _), _), thms) thy =
2330 thy |> put_registration_in_locale target id
2331 |> fold (add_witness_in_locale target id) thms
2332 | activate_id _ thy = thy;
2334 fun activate_reg (vts, (((fully_qualified, prfx), atts2), (exp, imp), _, _)) thy =
2336 val (insts, wits, _) = collect_global_witnesses thy imp fixed target_ids vts;
2337 fun inst_parms ps = map
2338 (the o AList.lookup (op =) (map #1 fixed ~~ vts)) ps;
2339 val disch = Element.satisfy_thm wits;
2340 val new_elemss = filter (fn (((name, ps), _), _) =>
2341 not (test_global_registration thy (name, inst_parms ps))) (ids_elemss);
2342 fun activate_assumed_id (((_, Derived _), _), _) thy = thy
2343 | activate_assumed_id ((((name, ps), Assumed _), _), thms) thy = let
2344 val ps' = inst_parms ps;
2346 if test_global_registration thy (name, ps')
2349 |> put_global_registration (name, ps') ((fully_qualified, prfx), atts2) (exp, imp)
2350 |> fold (fn witn => fn thy => add_global_witness (name, ps')
2351 (Element.morph_witness (Element.inst_morphism thy insts) witn) thy) thms
2354 fun activate_derived_id ((_, Assumed _), _) thy = thy
2355 | activate_derived_id (((name, ps), Derived ths), _) thy = let
2356 val ps' = inst_parms ps;
2358 if test_global_registration thy (name, ps')
2361 |> put_global_registration (name, ps') ((fully_qualified, prfx), atts2) (exp, imp)
2362 |> fold (fn witn => fn thy => add_global_witness (name, ps')
2363 (witn |> Element.map_witness (fn (t, th) => (* FIXME *)
2364 (Element.inst_term insts t,
2365 disch (Element.inst_thm thy insts (satisfy th))))) thy) ths
2368 fun activate_elem (Notes (kind, facts)) thy =
2371 Morphism.name_morphism (NameSpace.qualified prfx) $>
2372 Morphism.thm_morphism satisfy $>
2373 Element.inst_morphism thy insts $>
2374 Morphism.thm_morphism disch;
2376 |> Attrib.map_facts (Attrib.attribute_i thy o Args.morph_values att_morphism)
2377 |> map (apfst (apsnd (fn a => a @ map (Attrib.attribute thy) atts2)))
2378 |> map (apsnd (map (apfst (map (disch o Element.inst_thm thy insts o satisfy)))))
2381 |> global_note_prefix_i kind (fully_qualified, prfx) facts'
2384 | activate_elem _ thy = thy;
2386 fun activate_elems (_, elems) thy = fold activate_elem elems thy;
2388 in thy |> fold activate_assumed_id ids_elemss_thmss
2389 |> fold activate_derived_id ids_elemss
2390 |> fold activate_elems new_elemss end;
2392 thy |> fold activate_id ids_elemss_thmss
2393 |> fold activate_reg regs
2396 in (propss, activate) end;
2398 fun prep_propp propss = propss |> map (fn (_, props) =>
2399 map (rpair [] o Element.mark_witness) props);
2401 fun prep_result propps thmss =
2402 ListPair.map (fn ((_, props), thms) => map2 Element.make_witness props thms) (propps, thmss);
2404 fun gen_interpretation prep_registration after_qed (prfx, raw_atts) raw_expr raw_insts thy =
2405 (* prfx = (flag indicating full qualification, name prefix) *)
2407 val (propss, activate) = prep_registration thy (prfx, raw_atts) raw_expr raw_insts;
2408 fun after_qed' results =
2409 ProofContext.theory (activate (prep_result propss results))
2413 |> ProofContext.init
2414 |> Proof.theorem_i NONE after_qed' (prep_propp propss)
2415 |> Element.refine_witness
2419 fun gen_interpret prep_registration after_qed (prfx, atts) expr insts int state =
2420 (* prfx = (flag indicating full qualification, name prefix) *)
2422 val _ = Proof.assert_forward_or_chain state;
2423 val ctxt = Proof.context_of state;
2424 val (propss, activate) = prep_registration ctxt (prfx, atts) expr insts;
2425 fun after_qed' results =
2426 Proof.map_context (K (ctxt |> activate (prep_result propss results)))
2427 #> Proof.put_facts NONE
2431 |> Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
2432 "interpret" NONE after_qed' (map (pair ("", [])) (prep_propp propss))
2433 |> Element.refine_witness |> Seq.hd
2438 val interpretation_i = gen_interpretation prep_global_registration_i;
2439 val interpretation = gen_interpretation prep_global_registration;
2442 fun interpretation_in_locale after_qed (raw_target, expr) thy =
2444 val target = intern thy raw_target;
2445 val (propss, activate) = prep_registration_in_locale target expr thy;
2446 val raw_propp = prep_propp propss;
2448 val (_, _, goal_ctxt, propp) = thy
2449 |> ProofContext.init
2450 |> cert_context_statement (SOME target) [] raw_propp;
2452 fun after_qed' results =
2453 ProofContext.theory (activate (prep_result propss results))
2457 |> Proof.theorem_i NONE after_qed' propp
2458 |> Element.refine_witness |> Seq.hd
2461 val interpret_i = gen_interpret prep_local_registration_i;
2462 val interpret = gen_interpret prep_local_registration;