41 type 'att element_i |
42 type 'att element_i |
42 type locale |
43 type locale |
43 val intern: Sign.sg -> xstring -> string |
44 val intern: Sign.sg -> xstring -> string |
44 val cond_extern: Sign.sg -> string -> xstring |
45 val cond_extern: Sign.sg -> string -> xstring |
45 val the_locale: theory -> string -> locale |
46 val the_locale: theory -> string -> locale |
46 val map_attrib_element: ('att -> context attribute) -> 'att element -> |
47 val map_attrib_element: ('att -> multi_attribute) -> 'att element -> |
47 context attribute element |
48 multi_attribute element |
48 val map_attrib_element_i: ('att -> context attribute) -> 'att element_i -> |
49 val map_attrib_element_i: ('att -> multi_attribute) -> 'att element_i -> |
49 context attribute element_i |
50 multi_attribute element_i |
50 val map_attrib_elem_or_expr: ('att -> context attribute) -> |
51 val map_attrib_elem_or_expr: ('att -> multi_attribute) -> |
51 'att element elem_expr -> context attribute element elem_expr |
52 'att element elem_expr -> multi_attribute element elem_expr |
52 val map_attrib_elem_or_expr_i: ('att -> context attribute) -> |
53 val map_attrib_elem_or_expr_i: ('att -> multi_attribute) -> |
53 'att element_i elem_expr -> context attribute element_i elem_expr |
54 'att element_i elem_expr -> multi_attribute element_i elem_expr |
54 |
55 |
|
56 (* Processing of locale statements *) |
55 val read_context_statement: xstring option -> |
57 val read_context_statement: xstring option -> |
56 context attribute element elem_expr list -> |
58 multi_attribute element elem_expr list -> |
57 (string * (string list * string list)) list list -> context -> |
59 (string * (string list * string list)) list list -> context -> |
58 string option * (cterm list * cterm list) * context * context * |
60 string option * (cterm list * cterm list) * context * context * |
59 (term * (term list * term list)) list list |
61 (term * (term list * term list)) list list |
60 val cert_context_statement: string option -> |
62 val cert_context_statement: string option -> |
61 context attribute element_i elem_expr list -> |
63 multi_attribute element_i elem_expr list -> |
62 (term * (term list * term list)) list list -> context -> |
64 (term * (term list * term list)) list list -> context -> |
63 string option * (cterm list * cterm list) * context * context * |
65 string option * (cterm list * cterm list) * context * context * |
64 (term * (term list * term list)) list list |
66 (term * (term list * term list)) list list |
|
67 |
|
68 (* Diagnostic functions *) |
65 val print_locales: theory -> unit |
69 val print_locales: theory -> unit |
66 val print_locale: theory -> expr -> context attribute element list -> unit |
70 val print_locale: theory -> expr -> multi_attribute element list -> unit |
67 val add_locale: bool -> bstring -> expr -> context attribute element list -> theory -> theory |
71 val print_global_registrations: theory -> string -> unit |
68 val add_locale_i: bool -> bstring -> expr -> context attribute element_i list |
72 |
|
73 val add_locale: bool -> bstring -> expr -> multi_attribute element list -> theory -> theory |
|
74 val add_locale_i: bool -> bstring -> expr -> multi_attribute element_i list |
69 -> theory -> theory |
75 -> theory -> theory |
70 val smart_note_thmss: string -> (string * 'a) option -> |
76 val smart_note_thmss: string -> (string * 'a) option -> |
71 ((bstring * theory attribute list) * (thm list * theory attribute list) list) list -> |
77 ((bstring * theory attribute list) * (thm list * theory attribute list) list) list -> |
72 theory -> theory * (bstring * thm list) list |
78 theory -> theory * (bstring * thm list) list |
73 val note_thmss: string -> xstring -> |
79 val note_thmss: string -> xstring -> |
74 ((bstring * context attribute list) * (thmref * context attribute list) list) list -> |
80 ((bstring * multi_attribute list) * (thmref * multi_attribute list) list) list -> |
75 theory -> theory * (bstring * thm list) list |
81 theory -> theory * (bstring * thm list) list |
76 val note_thmss_i: string -> string -> |
82 val note_thmss_i: string -> string -> |
77 ((bstring * context attribute list) * (thm list * context attribute list) list) list -> |
83 ((bstring * multi_attribute list) * (thm list * multi_attribute list) list) list -> |
78 theory -> theory * (bstring * thm list) list |
84 theory -> theory * (bstring * thm list) list |
79 val add_thmss: string -> ((string * thm list) * context attribute list) list -> |
85 val add_thmss: string -> ((string * thm list) * multi_attribute list) list -> |
80 theory * context -> (theory * context) * (string * thm list) list |
86 theory * context -> (theory * context) * (string * thm list) list |
|
87 |
81 val instantiate: string -> string * context attribute list |
88 val instantiate: string -> string * context attribute list |
82 -> thm list option -> context -> context |
89 -> thm list option -> context -> context |
|
90 val prep_registration: |
|
91 string * theory attribute list -> expr -> string option list -> theory -> |
|
92 theory * ((string * term list) * term list) list * (theory -> theory) |
|
93 val global_activate_thm: |
|
94 string * term list -> thm -> theory -> theory |
|
95 |
83 val setup: (theory -> theory) list |
96 val setup: (theory -> theory) list |
84 end; |
97 end; |
85 |
98 |
86 structure Locale: LOCALE = |
99 structure Locale: LOCALE = |
87 struct |
100 struct |
88 |
101 |
89 (** locale elements and expressions **) |
102 (** locale elements and expressions **) |
90 |
103 |
91 type context = ProofContext.context; |
104 type context = ProofContext.context; |
|
105 |
|
106 (* Locales store theory attributes (for activation in theories) |
|
107 and context attributes (for activation in contexts) *) |
|
108 type multi_attribute = theory attribute * context attribute; |
92 |
109 |
93 datatype ('typ, 'term, 'fact, 'att) elem = |
110 datatype ('typ, 'term, 'fact, 'att) elem = |
94 Fixes of (string * 'typ option * mixfix option) list | |
111 Fixes of (string * 'typ option * mixfix option) list | |
95 Assumes of ((string * 'att list) * ('term * ('term list * 'term list)) list) list | |
112 Assumes of ((string * 'att list) * ('term * ('term list * 'term list)) list) list | |
96 Defines of ((string * 'att list) * ('term * 'term list)) list | |
113 Defines of ((string * 'att list) * ('term * 'term list)) list | |
119 to the (assumed) locale parameters. Axioms contains the projections |
136 to the (assumed) locale parameters. Axioms contains the projections |
120 from the locale predicate to the normalised assumptions of the locale |
137 from the locale predicate to the normalised assumptions of the locale |
121 (cf. [1], normalisation of locale expressions.) |
138 (cf. [1], normalisation of locale expressions.) |
122 *) |
139 *) |
123 import: expr, (*dynamic import*) |
140 import: expr, (*dynamic import*) |
124 elems: (context attribute element_i * stamp) list, (*static content*) |
141 elems: (multi_attribute element_i * stamp) list, (*static content*) |
125 params: (string * typ option) list * string list} (*all/local params*) |
142 params: (string * typ option) list * string list} (*all/local params*) |
126 |
143 |
127 |
144 |
128 (** theory data **) |
145 (** theory data **) |
|
146 |
|
147 structure Termlisttab = TableFun(type key = term list |
|
148 val ord = Library.list_ord Term.term_ord); |
129 |
149 |
130 structure LocalesArgs = |
150 structure LocalesArgs = |
131 struct |
151 struct |
132 val name = "Isar/locales"; |
152 val name = "Isar/locales"; |
133 type T = NameSpace.T * locale Symtab.table; |
153 type T = NameSpace.T * locale Symtab.table * |
134 |
154 ((string * theory attribute list) * thm list) Termlisttab.table |
135 val empty = (NameSpace.empty, Symtab.empty); |
155 Symtab.table; |
|
156 (* 1st entry: locale namespace, |
|
157 2nd entry: locales of the theory, |
|
158 3rd entry: registrations: theorems instantiating locale assumptions, |
|
159 with prefix and attributes, indexed by locale name and parameter |
|
160 instantiation *) |
|
161 |
|
162 val empty = (NameSpace.empty, Symtab.empty, Symtab.empty); |
136 val copy = I; |
163 val copy = I; |
137 val prep_ext = I; |
164 val prep_ext = I; |
138 |
165 |
139 (*joining of locale elements: only facts may be added later!*) |
166 fun join_locs ({predicate, import, elems, params}: locale, |
140 fun join ({predicate, import, elems, params}: locale, {elems = elems', ...}: locale) = |
167 {elems = elems', ...}: locale) = |
141 SOME {predicate = predicate, import = import, elems = gen_merge_lists eq_snd elems elems', |
168 SOME {predicate = predicate, import = import, |
|
169 elems = gen_merge_lists eq_snd elems elems', |
142 params = params}; |
170 params = params}; |
143 fun merge ((space1, locs1), (space2, locs2)) = |
171 (* joining of registrations: prefix and attributes of left theory, |
144 (NameSpace.merge (space1, space2), Symtab.join join (locs1, locs2)); |
172 thmsss are equal *) |
145 |
173 fun join_regs (reg, _) = SOME reg; |
146 fun print _ (space, locs) = |
174 fun merge ((space1, locs1, regs1), (space2, locs2, regs2)) = |
|
175 (NameSpace.merge (space1, space2), Symtab.join join_locs (locs1, locs2), |
|
176 Symtab.join (SOME o Termlisttab.join join_regs) (regs1, regs2)); |
|
177 |
|
178 fun print _ (space, locs, _) = |
147 Pretty.strs ("locales:" :: map (NameSpace.cond_extern space o #1) (Symtab.dest locs)) |
179 Pretty.strs ("locales:" :: map (NameSpace.cond_extern space o #1) (Symtab.dest locs)) |
148 |> Pretty.writeln; |
180 |> Pretty.writeln; |
149 end; |
181 end; |
150 |
182 |
151 structure LocalesData = TheoryDataFun(LocalesArgs); |
183 structure LocalesData = TheoryDataFun(LocalesArgs); |
156 |
188 |
157 |
189 |
158 (* access locales *) |
190 (* access locales *) |
159 |
191 |
160 fun declare_locale name = |
192 fun declare_locale name = |
161 LocalesData.map (apfst (fn space => (NameSpace.extend (space, [name])))); |
193 LocalesData.map (fn (space, locs, regs) => |
162 |
194 (NameSpace.extend (space, [name]), locs, regs)); |
163 fun put_locale name loc = LocalesData.map (apsnd (fn locs => Symtab.update ((name, loc), locs))); |
195 |
|
196 fun put_locale name loc = |
|
197 LocalesData.map (fn (space, locs, regs) => |
|
198 (space, Symtab.update ((name, loc), locs), regs)); |
|
199 |
164 fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy), name); |
200 fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy), name); |
165 |
201 |
166 fun the_locale thy name = |
202 fun the_locale thy name = |
167 (case get_locale thy name of |
203 (case get_locale thy name of |
168 SOME loc => loc |
204 SOME loc => loc |
169 | NONE => error ("Unknown locale " ^ quote name)); |
205 | NONE => error ("Unknown locale " ^ quote name)); |
|
206 |
|
207 |
|
208 (* access registrations *) |
|
209 |
|
210 (* add registration to theory, ignored if already present *) |
|
211 |
|
212 fun global_put_registration (name, ps) attn = |
|
213 LocalesData.map (fn (space, locs, regs) => |
|
214 (space, locs, let |
|
215 val tab = getOpt (Symtab.lookup (regs, name), Termlisttab.empty); |
|
216 in |
|
217 Symtab.update ((name, Termlisttab.update_new ((ps, (attn, [])), tab)), |
|
218 regs) |
|
219 end handle Termlisttab.DUP _ => regs)); |
|
220 |
|
221 (* add theorem to registration in theory, |
|
222 ignored if registration not present *) |
|
223 |
|
224 fun global_put_registration_thm (name, ps) thm = |
|
225 LocalesData.map (fn (space, locs, regs) => |
|
226 (space, locs, let |
|
227 val tab = valOf (Symtab.lookup (regs, name)); |
|
228 val (x, thms) = valOf (Termlisttab.lookup (tab, ps)); |
|
229 in |
|
230 Symtab.update ((name, Termlisttab.update ((ps, (x, thm::thms)), tab)), |
|
231 regs) |
|
232 end handle Option => regs)) |
|
233 |
|
234 fun global_get_registration thy (name, ps) = |
|
235 case Symtab.lookup (#3 (LocalesData.get thy), name) of |
|
236 NONE => NONE |
|
237 | SOME tab => Termlisttab.lookup (tab, ps); |
170 |
238 |
171 |
239 |
172 (* import hierarchy |
240 (* import hierarchy |
173 implementation could be more efficient, eg. by maintaining a database |
241 implementation could be more efficient, eg. by maintaining a database |
174 of dependencies *) |
242 of dependencies *) |
532 |
678 |
533 fun activate_elem _ ((ctxt, axs), Fixes fixes) = |
679 fun activate_elem _ ((ctxt, axs), Fixes fixes) = |
534 ((ctxt |> ProofContext.add_fixes fixes, axs), []) |
680 ((ctxt |> ProofContext.add_fixes fixes, axs), []) |
535 | activate_elem _ ((ctxt, axs), Assumes asms) = |
681 | activate_elem _ ((ctxt, axs), Assumes asms) = |
536 let |
682 let |
|
683 (* extract context attributes *) |
|
684 val (Assumes asms) = map_attrib_element_i snd (Assumes asms); |
537 val ts = List.concat (map (map #1 o #2) asms); |
685 val ts = List.concat (map (map #1 o #2) asms); |
538 val (ps,qs) = splitAt (length ts, axs); |
686 val (ps,qs) = splitAt (length ts, axs); |
539 val (ctxt', _) = |
687 val (ctxt', _) = |
540 ctxt |> ProofContext.fix_frees ts |
688 ctxt |> ProofContext.fix_frees ts |
541 |> ProofContext.assume_i (export_axioms ps) asms; |
689 |> ProofContext.assume_i (export_axioms ps) asms; |
542 in ((ctxt', qs), []) end |
690 in ((ctxt', qs), []) end |
543 | activate_elem _ ((ctxt, axs), Defines defs) = |
691 | activate_elem _ ((ctxt, axs), Defines defs) = |
544 let val (ctxt', _) = |
692 let |
|
693 (* extract context attributes *) |
|
694 val (Defines defs) = map_attrib_element_i snd (Defines defs); |
|
695 val (ctxt', _) = |
545 ctxt |> ProofContext.assume_i ProofContext.export_def |
696 ctxt |> ProofContext.assume_i ProofContext.export_def |
546 (defs |> map (fn ((name, atts), (t, ps)) => |
697 (defs |> map (fn ((name, atts), (t, ps)) => |
547 let val (c, t') = ProofContext.cert_def ctxt t |
698 let val (c, t') = ProofContext.cert_def ctxt t |
548 in ((if name = "" then Thm.def_name c else name, atts), [(t', (ps, []))]) end)) |
699 in ((if name = "" then Thm.def_name c else name, atts), [(t', (ps, []))]) end)) |
549 in ((ctxt', axs), []) end |
700 in ((ctxt', axs), []) end |
550 | activate_elem is_ext ((ctxt, axs), Notes facts) = |
701 | activate_elem is_ext ((ctxt, axs), Notes facts) = |
551 let val (ctxt', res) = ctxt |> ProofContext.note_thmss_i facts |
702 let |
|
703 (* extract context attributes *) |
|
704 val (Notes facts) = map_attrib_element_i snd (Notes facts); |
|
705 val (ctxt', res) = ctxt |> ProofContext.note_thmss_i facts |
552 in ((ctxt', axs), if is_ext then res else []) end; |
706 in ((ctxt', axs), if is_ext then res else []) end; |
553 |
707 |
554 fun activate_elems (((name, ps), axs), elems) ctxt = |
708 fun activate_elems (((name, ps), axs), elems) ctxt = |
555 let val ((ctxt', _), res) = |
709 let val ((ctxt', _), res) = |
556 foldl_map (activate_elem (name = "")) ((ProofContext.qualified true ctxt, axs), elems) |
710 foldl_map (activate_elem (name = "")) ((ProofContext.qualified true ctxt, axs), elems) |
642 (* CB: an internal (Int) locale element was either imported or included, |
766 (* CB: an internal (Int) locale element was either imported or included, |
643 an external (Ext) element appears directly in the locale. *) |
767 an external (Ext) element appears directly in the locale. *) |
644 |
768 |
645 datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b; |
769 datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b; |
646 |
770 |
647 (* CB: flatten (ids, expr) normalises expr (which is either a locale |
771 (* flatten (ids, expr) normalises expr (which is either a locale |
648 expression or a single context element) wrt. |
772 expression or a single context element) wrt. |
649 to the list ids of already accumulated identifiers. |
773 to the list ids of already accumulated identifiers. |
650 It returns (ids', elemss) where ids' is an extension of ids |
774 It returns (ids', elemss) where ids' is an extension of ids |
651 with identifiers generated for expr, and elemss is the list of |
775 with identifiers generated for expr, and elemss is the list of |
652 context elements generated from expr, decorated with additional |
776 context elements generated from expr. For details, see flatten_expr. |
653 information (for expr it is the identifier, where parameters additionially |
777 Additionally, for a locale expression, the elems are grouped into a single |
654 contain type information (extracted from the locale record), for a Fixes |
778 Int; individual context elements are marked Ext. In this case, the |
655 element, it is an identifier with name = "" and parameters with type |
779 identifier-like information of the element is as follows: |
656 information NONE, for other elements it is simply ("", [])). |
780 - for Fixes: (("", ps), []) where the ps have type info NONE |
|
781 - for other elements: (("", []), []). |
657 The implementation of activate_facts relies on identifier names being |
782 The implementation of activate_facts relies on identifier names being |
658 empty strings for external elements. |
783 empty strings for external elements. |
659 TODO: correct this comment wrt axioms. *) |
784 *) |
660 |
785 |
661 fun flatten _ (ids, Elem (Fixes fixes)) = |
786 fun flatten _ (ids, Elem (Fixes fixes)) = |
662 (ids, [((("", map (rpair NONE o #1) fixes), []), Ext (Fixes fixes))]) |
787 (ids, [((("", map (rpair NONE o #1) fixes), []), Ext (Fixes fixes))]) |
663 | flatten _ (ids, Elem elem) = (ids, [((("", []), []), Ext elem)]) |
788 | flatten _ (ids, Elem elem) = (ids, [((("", []), []), Ext elem)]) |
664 | flatten (ctxt, prep_expr) (ids, Expr expr) = |
789 | flatten (ctxt, prep_expr) (ids, Expr expr) = |
1449 |
1608 |
1450 end; |
1609 end; |
1451 |
1610 |
1452 |
1611 |
1453 |
1612 |
|
1613 (** Registration commands **) |
|
1614 |
|
1615 local |
|
1616 |
|
1617 (** instantiate free vars **) |
|
1618 |
|
1619 (* instantiate TFrees *) |
|
1620 |
|
1621 fun tinst_type tinst T = if Symtab.is_empty tinst |
|
1622 then T |
|
1623 else Term.map_type_tfree |
|
1624 (fn (v as (x, _)) => getOpt (Symtab.lookup (tinst, x), (TFree v))) T; |
|
1625 |
|
1626 fun tinst_term tinst t = if Symtab.is_empty tinst |
|
1627 then t |
|
1628 else Term.map_term_types (tinst_type tinst) t; |
|
1629 |
|
1630 fun tinst_thm sg tinst thm = if Symtab.is_empty tinst |
|
1631 then thm |
|
1632 else let |
|
1633 val cert = Thm.cterm_of sg; |
|
1634 val certT = Thm.ctyp_of sg; |
|
1635 val {hyps, prop, ...} = Thm.rep_thm thm; |
|
1636 val tfrees = foldr Term.add_term_tfree_names [] (prop :: hyps); |
|
1637 val tinst' = Symtab.dest tinst |> |
|
1638 List.filter (fn (a, _) => a mem_string tfrees); |
|
1639 in |
|
1640 if null tinst' then thm |
|
1641 else thm |> Drule.implies_intr_list (map cert hyps) |
|
1642 |> Drule.tvars_intr_list (map #1 tinst') |
|
1643 |> (fn (th, al) => th |> Thm.instantiate |
|
1644 ((map (fn (a, T) => (valOf (assoc (al, a)), certT T)) tinst'), |
|
1645 [])) |
|
1646 |> (fn th => Drule.implies_elim_list th |
|
1647 (map (Thm.assume o cert o tinst_term tinst) hyps)) |
|
1648 end; |
|
1649 |
|
1650 fun tinst_elem _ tinst (Fixes fixes) = |
|
1651 Fixes (map (fn (x, T, mx) => (x, Option.map (tinst_type tinst) T, mx)) fixes) |
|
1652 | tinst_elem _ tinst (Assumes asms) = |
|
1653 Assumes (map (apsnd (map (fn (t, (ps, qs)) => |
|
1654 (tinst_term tinst t, |
|
1655 (map (tinst_term tinst) ps, map (tinst_term tinst) qs))))) asms) |
|
1656 | tinst_elem _ tinst (Defines defs) = |
|
1657 Defines (map (apsnd (fn (t, ps) => |
|
1658 (tinst_term tinst t, map (tinst_term tinst) ps))) defs) |
|
1659 | tinst_elem sg tinst (Notes facts) = |
|
1660 Notes (map (apsnd (map (apfst (map (tinst_thm sg tinst))))) facts); |
|
1661 |
|
1662 (* instantiate TFrees and Frees *) |
|
1663 |
|
1664 fun inst_term (inst, tinst) = if Symtab.is_empty inst |
|
1665 then tinst_term tinst |
|
1666 else (* instantiate terms and types simultaneously *) |
|
1667 let |
|
1668 fun instf (Const (x, T)) = Const (x, tinst_type tinst T) |
|
1669 | instf (Free (x, T)) = (case Symtab.lookup (inst, x) of |
|
1670 NONE => Free (x, tinst_type tinst T) |
|
1671 | SOME t => t) |
|
1672 | instf (Var (xi, T)) = Var (xi, tinst_type tinst T) |
|
1673 | instf (b as Bound _) = b |
|
1674 | instf (Abs (x, T, t)) = Abs (x, tinst_type tinst T, instf t) |
|
1675 | instf (s $ t) = instf s $ instf t |
|
1676 in instf end; |
|
1677 |
|
1678 fun inst_thm sg (inst, tinst) thm = if Symtab.is_empty inst |
|
1679 then tinst_thm sg tinst thm |
|
1680 else let |
|
1681 val cert = Thm.cterm_of sg; |
|
1682 val certT = Thm.ctyp_of sg; |
|
1683 val {hyps, prop, ...} = Thm.rep_thm thm; |
|
1684 (* type instantiations *) |
|
1685 val tfrees = foldr Term.add_term_tfree_names [] (prop :: hyps); |
|
1686 val tinst' = Symtab.dest tinst |> |
|
1687 List.filter (fn (a, _) => a mem_string tfrees); |
|
1688 (* term instantiations; |
|
1689 note: lhss are type instantiated, because |
|
1690 type insts will be done first*) |
|
1691 val frees = foldr Term.add_term_frees [] (prop :: hyps); |
|
1692 val inst' = Symtab.dest inst |> |
|
1693 List.mapPartial (fn (a, t) => |
|
1694 get_first (fn (Free (x, T)) => |
|
1695 if a = x then SOME (Free (x, tinst_type tinst T), t) |
|
1696 else NONE) frees); |
|
1697 in |
|
1698 if null tinst' andalso null inst' then tinst_thm sg tinst thm |
|
1699 else thm |> Drule.implies_intr_list (map cert hyps) |
|
1700 |> Drule.tvars_intr_list (map #1 tinst') |
|
1701 |> (fn (th, al) => th |> Thm.instantiate |
|
1702 ((map (fn (a, T) => (valOf (assoc (al, a)), certT T)) tinst'), |
|
1703 [])) |
|
1704 |> Drule.forall_intr_list (map (cert o #1) inst') |
|
1705 |> Drule.forall_elim_list (map (cert o #2) inst') |
|
1706 |> (fn th => Drule.implies_elim_list th |
|
1707 (map (Thm.assume o cert o inst_term (inst, tinst)) hyps)) |
|
1708 end; |
|
1709 |
|
1710 fun inst_elem _ (_, tinst) (Fixes fixes) = |
|
1711 Fixes (map (fn (x, T, mx) => (x, Option.map (tinst_type tinst) T, mx)) fixes) |
|
1712 | inst_elem _ inst (Assumes asms) = |
|
1713 Assumes (map (apsnd (map (fn (t, (ps, qs)) => |
|
1714 (inst_term inst t, |
|
1715 (map (inst_term inst) ps, map (inst_term inst) qs))))) asms) |
|
1716 | inst_elem _ inst (Defines defs) = |
|
1717 Defines (map (apsnd (fn (t, ps) => |
|
1718 (inst_term inst t, map (inst_term inst) ps))) defs) |
|
1719 | inst_elem sg inst (Notes facts) = |
|
1720 Notes (map (apsnd (map (apfst (map (inst_thm sg inst))))) facts); |
|
1721 |
|
1722 fun inst_elems sign inst ((n, ps), elems) = |
|
1723 ((n, map (inst_term inst) ps), map (inst_elem sign inst) elems); |
|
1724 |
|
1725 (* extract proof obligations (assms and defs) from elements *) |
|
1726 |
|
1727 (* check if defining equation has become t == t, these are dropped |
|
1728 in extract_asms_elem, as they lead to trivial proof obligations *) |
|
1729 (* currently disabled *) |
|
1730 fun check_def (_, (def, _)) = SOME def; |
|
1731 (* |
|
1732 fun check_def (_, (def, _)) = |
|
1733 if def |> Logic.dest_equals |> op aconv |
|
1734 then NONE else SOME def; |
|
1735 *) |
|
1736 |
|
1737 fun extract_asms_elem (ts, Fixes _) = ts |
|
1738 | extract_asms_elem (ts, Assumes asms) = |
|
1739 ts @ List.concat (map (fn (_, ams) => map (fn (t, _) => t) ams) asms) |
|
1740 | extract_asms_elem (ts, Defines defs) = |
|
1741 ts @ List.mapPartial check_def defs |
|
1742 | extract_asms_elem (ts, Notes _) = ts; |
|
1743 |
|
1744 fun extract_asms_elems (id, elems) = |
|
1745 (id, Library.foldl extract_asms_elem ([], elems)); |
|
1746 |
|
1747 fun extract_asms_elemss elemss = |
|
1748 map extract_asms_elems elemss; |
|
1749 |
|
1750 (* add registration, without theorems, to theory *) |
|
1751 |
|
1752 fun prep_reg_global attn (thy, (id, _)) = |
|
1753 global_put_registration id attn thy; |
|
1754 |
|
1755 (* activate instantiated facts in theory *) |
|
1756 |
|
1757 fun activate_facts_elem _ _ (thy, Fixes _) = thy |
|
1758 | activate_facts_elem _ _ (thy, Assumes _) = thy |
|
1759 | activate_facts_elem _ _ (thy, Defines _) = thy |
|
1760 | activate_facts_elem disch (prfx, atts) (thy, Notes facts) = |
|
1761 let |
|
1762 (* extract theory attributes *) |
|
1763 val (Notes facts) = map_attrib_element_i fst (Notes facts); |
|
1764 val facts' = map (apfst (apsnd (fn a => a @ atts))) facts; |
|
1765 val facts'' = map (apsnd (map (apfst (map disch)))) facts'; |
|
1766 in |
|
1767 fst (note_thmss_qualified' "" prfx facts thy) |
|
1768 end; |
|
1769 |
|
1770 fun activate_facts_elems disch (thy, (id, elems)) = |
|
1771 let |
|
1772 val ((prfx, atts2), _) = valOf (global_get_registration thy id) |
|
1773 handle Option => error ("(internal) unknown registration of " ^ |
|
1774 quote (fst id) ^ " while activating facts."); |
|
1775 in |
|
1776 Library.foldl (activate_facts_elem disch (prfx, atts2)) (thy, elems) |
|
1777 end; |
|
1778 |
|
1779 fun activate_facts_elemss all_elemss new_elemss thy = |
|
1780 let |
|
1781 val prems = List.concat (List.mapPartial (fn (id, _) => |
|
1782 Option.map snd (global_get_registration thy id) |
|
1783 handle Option => error ("(internal) unknown registration of " ^ |
|
1784 quote (fst id) ^ " while activating facts.")) all_elemss); |
|
1785 fun disch thm = let |
|
1786 in Drule.satisfy_hyps prems thm end; |
|
1787 in Library.foldl (activate_facts_elems disch) (thy, new_elemss) end; |
|
1788 |
|
1789 in |
|
1790 |
|
1791 fun prep_registration attn expr insts thy = |
|
1792 let |
|
1793 val ctxt = ProofContext.init thy; |
|
1794 val sign = Theory.sign_of thy; |
|
1795 val tsig = Sign.tsig_of sign; |
|
1796 |
|
1797 val (ids, raw_elemss) = |
|
1798 flatten (ctxt, intern_expr sign) ([], Expr expr); |
|
1799 val do_close = false; (* effect unknown *) |
|
1800 val ((parms, all_elemss, _), (spec, (xs, defs, _))) = |
|
1801 read_elemss do_close ctxt [] raw_elemss []; |
|
1802 |
|
1803 |
|
1804 (** compute instantiation **) |
|
1805 |
|
1806 (* user input *) |
|
1807 val insts = if length parms < length insts |
|
1808 then error "More arguments than parameters in instantiation." |
|
1809 else insts @ replicate (length parms - length insts) NONE; |
|
1810 val (ps, pTs) = split_list parms; |
|
1811 val pvTs = map Type.varifyT pTs; |
|
1812 val given = List.mapPartial (fn (_, (NONE, _)) => NONE |
|
1813 | (x, (SOME inst, T)) => SOME (x, (inst, T))) (ps ~~ (insts ~~ pvTs)); |
|
1814 val (given_ps, given_insts) = split_list given; |
|
1815 val tvars = foldr Term.add_typ_tvars [] pvTs; |
|
1816 val used = foldr Term.add_typ_varnames [] pvTs; |
|
1817 fun sorts (a, i) = assoc (tvars, (a, i)); |
|
1818 val (tvs, tvinst) = Sign.read_def_terms (sign, K NONE, sorts) used true |
|
1819 given_insts; |
|
1820 val tinst = Symtab.make (map (fn ((x, 0), T) => (x, Type.unvarifyT T) |
|
1821 | ((_, n), _) => error "Var in prep_registration") tvinst); |
|
1822 val inst = Symtab.make (given_ps ~~ map Logic.unvarify tvs); |
|
1823 |
|
1824 (* defined params without user input *) |
|
1825 val not_given = List.mapPartial (fn (x, (NONE, T)) => SOME (x, T) |
|
1826 | (_, (SOME _, _)) => NONE) (ps ~~ (insts ~~ pTs)); |
|
1827 fun add_def ((inst, tinst), (p, pT)) = |
|
1828 let |
|
1829 val (t, T) = case find_first (fn (Free (a, _), _) => a = p) defs of |
|
1830 NONE => error ("Instance missing for parameter " ^ quote p) |
|
1831 | SOME (Free (_, T), t) => (t, T); |
|
1832 val d = t |> inst_term (inst, tinst) |> Envir.beta_norm; |
|
1833 in (Symtab.update_new ((p, d), inst), tinst) end; |
|
1834 val (inst, tinst) = Library.foldl add_def ((inst, tinst), not_given); |
|
1835 |
|
1836 |
|
1837 (** compute proof obligations **) |
|
1838 |
|
1839 (* restore small ids *) |
|
1840 val ids' = map (fn ((n, ps), _) => |
|
1841 (n, map (fn p => Free (p, valOf (assoc (parms, p)))) ps)) ids; |
|
1842 |
|
1843 (* instantiate ids and elements *) |
|
1844 val inst_elemss = map |
|
1845 (fn (id, (_, elems)) => inst_elems sign (inst, tinst) (id, |
|
1846 map (fn Int e => e) elems)) |
|
1847 (ids' ~~ all_elemss); |
|
1848 |
|
1849 (* |
|
1850 (* varify ids, props are varified after they are proved *) |
|
1851 val inst_elemss' = map (fn ((n, ps), elems) => |
|
1852 ((n, map Logic.varify ps), elems)) inst_elemss; |
|
1853 *) |
|
1854 |
|
1855 (* remove fragments already registered with theory *) |
|
1856 val new_inst_elemss = List.filter (fn (id, _) => |
|
1857 is_none (global_get_registration thy id)) inst_elemss; |
|
1858 |
|
1859 |
|
1860 val propss = extract_asms_elemss new_inst_elemss; |
|
1861 |
|
1862 |
|
1863 (** add registrations to theory, |
|
1864 without theorems, these are added after the proof **) |
|
1865 |
|
1866 val thy' = Library.foldl (prep_reg_global attn) (thy, new_inst_elemss); |
|
1867 |
|
1868 in (thy', propss, activate_facts_elemss inst_elemss new_inst_elemss) end; |
|
1869 |
|
1870 |
|
1871 (* Add registrations and theorems to theory context *) |
|
1872 |
|
1873 val global_activate_thm = global_put_registration_thm |
|
1874 |
|
1875 end; (* local *) |
|
1876 |
|
1877 |
|
1878 |
1454 (** locale theory setup **) |
1879 (** locale theory setup **) |
1455 |
1880 |
1456 val setup = |
1881 val setup = |
1457 [LocalesData.init, |
1882 [LocalesData.init, |
1458 add_locale_i true "var" empty [Fixes [(Syntax.internal "x", NONE, SOME Syntax.NoSyn)]], |
1883 add_locale_i true "var" empty [Fixes [(Syntax.internal "x", NONE, SOME Syntax.NoSyn)]], |