1 (* Title: HOL/Tools/Quotient/quotient_info.ML
2 Author: Cezary Kaliszyk and Christian Urban
4 Context data for the quotient package.
7 signature QUOTIENT_INFO =
9 type quotmaps = {relmap: string, quot_thm: thm}
10 val lookup_quotmaps: Proof.context -> string -> quotmaps option
11 val lookup_quotmaps_global: theory -> string -> quotmaps option
12 val print_quotmaps: Proof.context -> unit
14 type abs_rep = {abs : term, rep : term}
15 val transform_abs_rep: morphism -> abs_rep -> abs_rep
16 val lookup_abs_rep: Proof.context -> string -> abs_rep option
17 val lookup_abs_rep_global: theory -> string -> abs_rep option
18 val update_abs_rep: string -> abs_rep -> Context.generic -> Context.generic
19 val print_abs_rep: Proof.context -> unit
21 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm}
22 val transform_quotients: morphism -> quotients -> quotients
23 val lookup_quotients: Proof.context -> string -> quotients option
24 val lookup_quotients_global: theory -> string -> quotients option
25 val update_quotients: string -> quotients -> Context.generic -> Context.generic
26 val dest_quotients: Proof.context -> quotients list
27 val print_quotients: Proof.context -> unit
29 type quotconsts = {qconst: term, rconst: term, def: thm}
30 val transform_quotconsts: morphism -> quotconsts -> quotconsts
31 val lookup_quotconsts_global: theory -> term -> quotconsts option
32 val update_quotconsts: string -> quotconsts -> Context.generic -> Context.generic
33 val dest_quotconsts_global: theory -> quotconsts list
34 val dest_quotconsts: Proof.context -> quotconsts list
35 val print_quotconsts: Proof.context -> unit
37 val equiv_rules: Proof.context -> thm list
38 val equiv_rules_add: attribute
39 val rsp_rules: Proof.context -> thm list
40 val rsp_rules_add: attribute
41 val prs_rules: Proof.context -> thm list
42 val prs_rules_add: attribute
43 val id_simps: Proof.context -> thm list
44 val quotient_rules: Proof.context -> thm list
45 val quotient_rules_add: attribute
46 val setup: theory -> theory
49 structure Quotient_Info: QUOTIENT_INFO =
52 (** data containers **)
54 (* FIXME just one data slot (record) per program unit *)
56 (* info about map- and rel-functions for a type *)
57 type quotmaps = {relmap: string, quot_thm: thm}
59 structure Quotmaps = Generic_Data
61 type T = quotmaps Symtab.table
62 val empty = Symtab.empty
64 fun merge data = Symtab.merge (K true) data
67 val lookup_quotmaps = Symtab.lookup o Quotmaps.get o Context.Proof
68 val lookup_quotmaps_global = Symtab.lookup o Quotmaps.get o Context.Theory
70 (* FIXME export proper internal update operation!? *)
72 val quotmaps_attribute_setup =
73 Attrib.setup @{binding map}
74 ((Args.type_name true --| Scan.lift (@{keyword "="})) --
75 (Scan.lift (@{keyword "("}) |-- Args.const_proper true --| Scan.lift (@{keyword ","}) --
76 Attrib.thm --| Scan.lift (@{keyword ")"})) >>
77 (fn (tyname, (relname, qthm)) =>
78 let val minfo = {relmap = relname, quot_thm = qthm}
79 in Thm.declaration_attribute (fn _ => Quotmaps.map (Symtab.update (tyname, minfo))) end))
80 "declaration of map information"
82 fun print_quotmaps ctxt =
84 fun prt_map (ty_name, {relmap, quot_thm}) =
85 Pretty.block (separate (Pretty.brk 2)
88 Pretty.str "relation map:",
90 Pretty.str "quot. theorem:",
91 Syntax.pretty_term ctxt (prop_of quot_thm)])
93 map prt_map (Symtab.dest (Quotmaps.get (Context.Proof ctxt)))
94 |> Pretty.big_list "maps for type constructors:"
98 (* info about abs/rep terms *)
99 type abs_rep = {abs : term, rep : term}
101 structure Abs_Rep = Generic_Data
103 type T = abs_rep Symtab.table
104 val empty = Symtab.empty
106 fun merge data = Symtab.merge (K true) data
109 fun transform_abs_rep phi {abs, rep} = {abs = Morphism.term phi abs, rep = Morphism.term phi rep}
111 val lookup_abs_rep = Symtab.lookup o Abs_Rep.get o Context.Proof
112 val lookup_abs_rep_global = Symtab.lookup o Abs_Rep.get o Context.Theory
114 fun update_abs_rep str data = Abs_Rep.map (Symtab.update (str, data))
116 fun print_abs_rep ctxt =
118 fun prt_abs_rep (s, {abs, rep}) =
119 Pretty.block (separate (Pretty.brk 2)
120 [Pretty.str "type constructor:",
122 Pretty.str "abs term:",
123 Syntax.pretty_term ctxt abs,
124 Pretty.str "rep term:",
125 Syntax.pretty_term ctxt rep])
127 map prt_abs_rep (Symtab.dest (Abs_Rep.get (Context.Proof ctxt)))
128 |> Pretty.big_list "abs/rep terms:"
132 (* info about quotient types *)
133 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm}
135 structure Quotients = Generic_Data
137 type T = quotients Symtab.table
138 val empty = Symtab.empty
140 fun merge data = Symtab.merge (K true) data
143 fun transform_quotients phi {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} =
144 {qtyp = Morphism.typ phi qtyp,
145 rtyp = Morphism.typ phi rtyp,
146 equiv_rel = Morphism.term phi equiv_rel,
147 equiv_thm = Morphism.thm phi equiv_thm,
148 quot_thm = Morphism.thm phi quot_thm}
150 val lookup_quotients = Symtab.lookup o Quotients.get o Context.Proof
151 val lookup_quotients_global = Symtab.lookup o Quotients.get o Context.Theory
153 fun update_quotients str qinfo = Quotients.map (Symtab.update (str, qinfo))
155 fun dest_quotients ctxt = (* FIXME slightly expensive way to retrieve data *)
156 map snd (Symtab.dest (Quotients.get (Context.Proof ctxt)))
158 fun print_quotients ctxt =
160 fun prt_quot {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} =
161 Pretty.block (separate (Pretty.brk 2)
162 [Pretty.str "quotient type:",
163 Syntax.pretty_typ ctxt qtyp,
164 Pretty.str "raw type:",
165 Syntax.pretty_typ ctxt rtyp,
166 Pretty.str "relation:",
167 Syntax.pretty_term ctxt equiv_rel,
168 Pretty.str "equiv. thm:",
169 Syntax.pretty_term ctxt (prop_of equiv_thm),
170 Pretty.str "quot. thm:",
171 Syntax.pretty_term ctxt (prop_of quot_thm)])
173 map (prt_quot o snd) (Symtab.dest (Quotients.get (Context.Proof ctxt)))
174 |> Pretty.big_list "quotients:"
179 (* info about quotient constants *)
180 type quotconsts = {qconst: term, rconst: term, def: thm}
182 fun eq_quotconsts (x : quotconsts, y : quotconsts) = #qconst x = #qconst y
184 (* We need to be able to lookup instances of lifted constants,
185 for example given "nat fset" we need to find "'a fset";
186 but overloaded constants share the same name *)
187 structure Quotconsts = Generic_Data
189 type T = quotconsts list Symtab.table
190 val empty = Symtab.empty
192 val merge = Symtab.merge_list eq_quotconsts
195 fun transform_quotconsts phi {qconst, rconst, def} =
196 {qconst = Morphism.term phi qconst,
197 rconst = Morphism.term phi rconst,
198 def = Morphism.thm phi def}
200 fun update_quotconsts name qcinfo = Quotconsts.map (Symtab.cons_list (name, qcinfo))
202 fun dest_quotconsts ctxt =
203 flat (map snd (Symtab.dest (Quotconsts.get (Context.Proof ctxt))))
205 fun dest_quotconsts_global thy =
206 flat (map snd (Symtab.dest (Quotconsts.get (Context.Theory thy))))
210 fun lookup_quotconsts_global thy t =
212 val (name, qty) = dest_Const t
213 fun matches (x: quotconsts) =
214 let val (name', qty') = dest_Const (#qconst x);
215 in name = name' andalso Sign.typ_instance thy (qty, qty') end
217 (case Symtab.lookup (Quotconsts.get (Context.Theory thy)) name of
219 | SOME l => find_first matches l)
222 fun print_quotconsts ctxt =
224 fun prt_qconst {qconst, rconst, def} =
225 Pretty.block (separate (Pretty.brk 1)
226 [Syntax.pretty_term ctxt qconst,
228 Syntax.pretty_term ctxt rconst,
230 Syntax.pretty_term ctxt (prop_of def)])
232 map prt_qconst (maps snd (Symtab.dest (Quotconsts.get (Context.Proof ctxt))))
233 |> Pretty.big_list "quotient constants:"
237 (* equivalence relation theorems *)
238 structure Equiv_Rules = Named_Thms
240 val name = @{binding quot_equiv}
241 val description = "equivalence relation theorems"
244 val equiv_rules = Equiv_Rules.get
245 val equiv_rules_add = Equiv_Rules.add
247 (* respectfulness theorems *)
248 structure Rsp_Rules = Named_Thms
250 val name = @{binding quot_respect}
251 val description = "respectfulness theorems"
254 val rsp_rules = Rsp_Rules.get
255 val rsp_rules_add = Rsp_Rules.add
257 (* preservation theorems *)
258 structure Prs_Rules = Named_Thms
260 val name = @{binding quot_preserve}
261 val description = "preservation theorems"
264 val prs_rules = Prs_Rules.get
265 val prs_rules_add = Prs_Rules.add
267 (* id simplification theorems *)
268 structure Id_Simps = Named_Thms
270 val name = @{binding id_simps}
271 val description = "identity simp rules for maps"
274 val id_simps = Id_Simps.get
276 (* quotient theorems *)
277 structure Quotient_Rules = Named_Thms
279 val name = @{binding quot_thm}
280 val description = "quotient theorems"
283 val quotient_rules = Quotient_Rules.get
284 val quotient_rules_add = Quotient_Rules.add
290 quotmaps_attribute_setup #>
298 (* outer syntax commands *)
301 Outer_Syntax.improper_command @{command_spec "print_quotmaps"} "print quotient map functions"
302 (Scan.succeed (Toplevel.keep (print_quotmaps o Toplevel.context_of)))
305 Outer_Syntax.improper_command @{command_spec "print_quotients"} "print quotients"
306 (Scan.succeed (Toplevel.keep (print_quotients o Toplevel.context_of)))
309 Outer_Syntax.improper_command @{command_spec "print_quotconsts"} "print quotient constants"
310 (Scan.succeed (Toplevel.keep (print_quotconsts o Toplevel.context_of)))