13 |
13 |
14 type abs_rep = {abs : term, rep : term} |
14 type abs_rep = {abs : term, rep : term} |
15 val transform_abs_rep: morphism -> abs_rep -> abs_rep |
15 val transform_abs_rep: morphism -> abs_rep -> abs_rep |
16 val lookup_abs_rep: Proof.context -> string -> abs_rep option |
16 val lookup_abs_rep: Proof.context -> string -> abs_rep option |
17 val lookup_abs_rep_global: theory -> 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 |
18 val update_abs_rep: string * abs_rep -> Context.generic -> Context.generic |
19 val print_abs_rep: Proof.context -> unit |
19 val print_abs_rep: Proof.context -> unit |
20 |
20 |
21 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm} |
21 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm} |
22 val transform_quotients: morphism -> quotients -> quotients |
22 val transform_quotients: morphism -> quotients -> quotients |
23 val lookup_quotients: Proof.context -> string -> quotients option |
23 val lookup_quotients: Proof.context -> string -> quotients option |
24 val lookup_quotients_global: theory -> string -> quotients option |
24 val lookup_quotients_global: theory -> string -> quotients option |
25 val update_quotients: string -> quotients -> Context.generic -> Context.generic |
25 val update_quotients: string * quotients -> Context.generic -> Context.generic |
26 val dest_quotients: Proof.context -> quotients list |
26 val dest_quotients: Proof.context -> quotients list |
27 val print_quotients: Proof.context -> unit |
27 val print_quotients: Proof.context -> unit |
28 |
28 |
29 type quotconsts = {qconst: term, rconst: term, def: thm} |
29 type quotconsts = {qconst: term, rconst: term, def: thm} |
30 val transform_quotconsts: morphism -> quotconsts -> quotconsts |
30 val transform_quotconsts: morphism -> quotconsts -> quotconsts |
31 val lookup_quotconsts_global: theory -> term -> quotconsts option |
31 val lookup_quotconsts_global: theory -> term -> quotconsts option |
32 val update_quotconsts: string -> quotconsts -> Context.generic -> Context.generic |
32 val update_quotconsts: string * quotconsts -> Context.generic -> Context.generic |
33 val dest_quotconsts_global: theory -> quotconsts list |
33 val dest_quotconsts_global: theory -> quotconsts list |
34 val dest_quotconsts: Proof.context -> quotconsts list |
34 val dest_quotconsts: Proof.context -> quotconsts list |
35 val print_quotconsts: Proof.context -> unit |
35 val print_quotconsts: Proof.context -> unit |
36 end; |
36 end; |
37 |
37 |
38 structure Quotient_Info: QUOTIENT_INFO = |
38 structure Quotient_Info: QUOTIENT_INFO = |
39 struct |
39 struct |
40 |
40 |
41 (** data containers **) |
41 (** data containers **) |
42 |
42 |
43 (* FIXME just one data slot (record) per program unit *) |
43 (*info about map- and rel-functions for a type*) |
44 |
|
45 (* info about map- and rel-functions for a type *) |
|
46 type quotmaps = {relmap: string, quot_thm: thm} |
44 type quotmaps = {relmap: string, quot_thm: thm} |
47 |
45 |
48 structure Quotmaps = Generic_Data |
46 (*info about abs/rep terms*) |
|
47 type abs_rep = {abs : term, rep : term} |
|
48 fun transform_abs_rep phi {abs, rep} : abs_rep = |
|
49 {abs = Morphism.term phi abs, rep = Morphism.term phi rep} |
|
50 |
|
51 (*info about quotient types*) |
|
52 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm} |
|
53 fun transform_quotients phi {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} : quotients = |
|
54 {qtyp = Morphism.typ phi qtyp, |
|
55 rtyp = Morphism.typ phi rtyp, |
|
56 equiv_rel = Morphism.term phi equiv_rel, |
|
57 equiv_thm = Morphism.thm phi equiv_thm, |
|
58 quot_thm = Morphism.thm phi quot_thm} |
|
59 |
|
60 (*info about quotient constants*) |
|
61 (*We need to be able to lookup instances of lifted constants, |
|
62 for example given "nat fset" we need to find "'a fset"; |
|
63 but overloaded constants share the same name.*) |
|
64 type quotconsts = {qconst: term, rconst: term, def: thm} |
|
65 fun eq_quotconsts (x: quotconsts, y: quotconsts) = #qconst x = #qconst y |
|
66 fun transform_quotconsts phi {qconst, rconst, def} : quotconsts = |
|
67 {qconst = Morphism.term phi qconst, |
|
68 rconst = Morphism.term phi rconst, |
|
69 def = Morphism.thm phi def} |
|
70 |
|
71 structure Data = Generic_Data |
49 ( |
72 ( |
50 type T = quotmaps Symtab.table |
73 type T = |
51 val empty = Symtab.empty |
74 quotmaps Symtab.table * |
|
75 abs_rep Symtab.table * |
|
76 quotients Symtab.table * |
|
77 quotconsts list Symtab.table |
|
78 val empty: T = (Symtab.empty, Symtab.empty, Symtab.empty, Symtab.empty) |
52 val extend = I |
79 val extend = I |
53 fun merge data = Symtab.merge (K true) data |
80 fun merge |
|
81 ((quotmaps1, abs_rep1, quotients1, quotconsts1), |
|
82 (quotmaps2, abs_rep2, quotients2, quotconsts2)) : T = |
|
83 (Symtab.merge (K true) (quotmaps1, quotmaps2), |
|
84 Symtab.merge (K true) (abs_rep1, abs_rep2), |
|
85 Symtab.merge (K true) (quotients1, quotients2), |
|
86 Symtab.merge_list eq_quotconsts (quotconsts1, quotconsts2)) |
54 ) |
87 ) |
55 |
88 |
56 val lookup_quotmaps = Symtab.lookup o Quotmaps.get o Context.Proof |
89 val get_quotmaps = #1 o Data.get |
57 val lookup_quotmaps_global = Symtab.lookup o Quotmaps.get o Context.Theory |
90 val get_abs_rep = #2 o Data.get |
|
91 val get_quotients = #3 o Data.get |
|
92 val get_quotconsts = #4 o Data.get |
|
93 |
|
94 val map_quotmaps = Data.map o @{apply 4(1)} |
|
95 val map_abs_rep = Data.map o @{apply 4(2)} |
|
96 val map_quotients = Data.map o @{apply 4(3)} |
|
97 val map_quotconsts = Data.map o @{apply 4(4)} |
|
98 |
|
99 |
|
100 (* quotmaps *) |
|
101 |
|
102 val lookup_quotmaps = Symtab.lookup o get_quotmaps o Context.Proof |
|
103 val lookup_quotmaps_global = Symtab.lookup o get_quotmaps o Context.Theory |
58 |
104 |
59 (* FIXME export proper internal update operation!? *) |
105 (* FIXME export proper internal update operation!? *) |
60 |
106 |
61 val _ = |
107 val _ = |
62 Theory.setup |
108 Theory.setup |
65 (Scan.lift @{keyword "("} |-- |
111 (Scan.lift @{keyword "("} |-- |
66 Args.const {proper = true, strict = true} --| Scan.lift @{keyword ","} -- |
112 Args.const {proper = true, strict = true} --| Scan.lift @{keyword ","} -- |
67 Attrib.thm --| Scan.lift @{keyword ")"}) >> |
113 Attrib.thm --| Scan.lift @{keyword ")"}) >> |
68 (fn (tyname, (relname, qthm)) => |
114 (fn (tyname, (relname, qthm)) => |
69 let val minfo = {relmap = relname, quot_thm = qthm} |
115 let val minfo = {relmap = relname, quot_thm = qthm} |
70 in Thm.declaration_attribute (fn _ => Quotmaps.map (Symtab.update (tyname, minfo))) end)) |
116 in Thm.declaration_attribute (fn _ => map_quotmaps (Symtab.update (tyname, minfo))) end)) |
71 "declaration of map information") |
117 "declaration of map information") |
72 |
118 |
73 fun print_quotmaps ctxt = |
119 fun print_quotmaps ctxt = |
74 let |
120 let |
75 fun prt_map (ty_name, {relmap, quot_thm}) = |
121 fun prt_map (ty_name, {relmap, quot_thm}) = |
76 Pretty.block (separate (Pretty.brk 2) |
122 Pretty.block (separate (Pretty.brk 2) |
77 [Pretty.str "type:", |
123 [Pretty.str "type:", |
78 Pretty.str ty_name, |
124 Pretty.str ty_name, |
79 Pretty.str "relation map:", |
125 Pretty.str "relation map:", |
80 Pretty.str relmap, |
126 Pretty.str relmap, |
81 Pretty.str "quot. theorem:", |
127 Pretty.str "quot. theorem:", |
82 Syntax.pretty_term ctxt (prop_of quot_thm)]) |
128 Syntax.pretty_term ctxt (prop_of quot_thm)]) |
83 in |
129 in |
84 map prt_map (Symtab.dest (Quotmaps.get (Context.Proof ctxt))) |
130 map prt_map (Symtab.dest (get_quotmaps (Context.Proof ctxt))) |
85 |> Pretty.big_list "maps for type constructors:" |
131 |> Pretty.big_list "maps for type constructors:" |
86 |> Pretty.writeln |
132 |> Pretty.writeln |
87 end |
133 end |
88 |
134 |
89 (* info about abs/rep terms *) |
135 |
90 type abs_rep = {abs : term, rep : term} |
136 (* abs_rep *) |
91 |
137 |
92 structure Abs_Rep = Generic_Data |
138 val lookup_abs_rep = Symtab.lookup o get_abs_rep o Context.Proof |
93 ( |
139 val lookup_abs_rep_global = Symtab.lookup o get_abs_rep o Context.Theory |
94 type T = abs_rep Symtab.table |
140 |
95 val empty = Symtab.empty |
141 val update_abs_rep = map_abs_rep o Symtab.update |
96 val extend = I |
|
97 fun merge data = Symtab.merge (K true) data |
|
98 ) |
|
99 |
|
100 fun transform_abs_rep phi {abs, rep} = {abs = Morphism.term phi abs, rep = Morphism.term phi rep} |
|
101 |
|
102 val lookup_abs_rep = Symtab.lookup o Abs_Rep.get o Context.Proof |
|
103 val lookup_abs_rep_global = Symtab.lookup o Abs_Rep.get o Context.Theory |
|
104 |
|
105 fun update_abs_rep str data = Abs_Rep.map (Symtab.update (str, data)) |
|
106 |
142 |
107 fun print_abs_rep ctxt = |
143 fun print_abs_rep ctxt = |
108 let |
144 let |
109 fun prt_abs_rep (s, {abs, rep}) = |
145 fun prt_abs_rep (s, {abs, rep}) = |
110 Pretty.block (separate (Pretty.brk 2) |
146 Pretty.block (separate (Pretty.brk 2) |
113 Pretty.str "abs term:", |
149 Pretty.str "abs term:", |
114 Syntax.pretty_term ctxt abs, |
150 Syntax.pretty_term ctxt abs, |
115 Pretty.str "rep term:", |
151 Pretty.str "rep term:", |
116 Syntax.pretty_term ctxt rep]) |
152 Syntax.pretty_term ctxt rep]) |
117 in |
153 in |
118 map prt_abs_rep (Symtab.dest (Abs_Rep.get (Context.Proof ctxt))) |
154 map prt_abs_rep (Symtab.dest (get_abs_rep (Context.Proof ctxt))) |
119 |> Pretty.big_list "abs/rep terms:" |
155 |> Pretty.big_list "abs/rep terms:" |
120 |> Pretty.writeln |
156 |> Pretty.writeln |
121 end |
157 end |
122 |
158 |
123 (* info about quotient types *) |
159 |
124 type quotients = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm, quot_thm: thm} |
160 (* quotients *) |
125 |
161 |
126 structure Quotients = Generic_Data |
162 val lookup_quotients = Symtab.lookup o get_quotients o Context.Proof |
127 ( |
163 val lookup_quotients_global = Symtab.lookup o get_quotients o Context.Theory |
128 type T = quotients Symtab.table |
164 |
129 val empty = Symtab.empty |
165 val update_quotients = map_quotients o Symtab.update |
130 val extend = I |
166 |
131 fun merge data = Symtab.merge (K true) data |
167 fun dest_quotients ctxt = |
132 ) |
168 map snd (Symtab.dest (get_quotients (Context.Proof ctxt))) |
133 |
|
134 fun transform_quotients phi {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} = |
|
135 {qtyp = Morphism.typ phi qtyp, |
|
136 rtyp = Morphism.typ phi rtyp, |
|
137 equiv_rel = Morphism.term phi equiv_rel, |
|
138 equiv_thm = Morphism.thm phi equiv_thm, |
|
139 quot_thm = Morphism.thm phi quot_thm} |
|
140 |
|
141 val lookup_quotients = Symtab.lookup o Quotients.get o Context.Proof |
|
142 val lookup_quotients_global = Symtab.lookup o Quotients.get o Context.Theory |
|
143 |
|
144 fun update_quotients str qinfo = Quotients.map (Symtab.update (str, qinfo)) |
|
145 |
|
146 fun dest_quotients ctxt = (* FIXME slightly expensive way to retrieve data *) |
|
147 map snd (Symtab.dest (Quotients.get (Context.Proof ctxt))) |
|
148 |
169 |
149 fun print_quotients ctxt = |
170 fun print_quotients ctxt = |
150 let |
171 let |
151 fun prt_quot {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} = |
172 fun prt_quot {qtyp, rtyp, equiv_rel, equiv_thm, quot_thm} = |
152 Pretty.block (separate (Pretty.brk 2) |
173 Pretty.block (separate (Pretty.brk 2) |
159 Pretty.str "equiv. thm:", |
180 Pretty.str "equiv. thm:", |
160 Syntax.pretty_term ctxt (prop_of equiv_thm), |
181 Syntax.pretty_term ctxt (prop_of equiv_thm), |
161 Pretty.str "quot. thm:", |
182 Pretty.str "quot. thm:", |
162 Syntax.pretty_term ctxt (prop_of quot_thm)]) |
183 Syntax.pretty_term ctxt (prop_of quot_thm)]) |
163 in |
184 in |
164 map (prt_quot o snd) (Symtab.dest (Quotients.get (Context.Proof ctxt))) |
185 map (prt_quot o snd) (Symtab.dest (get_quotients (Context.Proof ctxt))) |
165 |> Pretty.big_list "quotients:" |
186 |> Pretty.big_list "quotients:" |
166 |> Pretty.writeln |
187 |> Pretty.writeln |
167 end |
188 end |
168 |
189 |
169 |
190 |
170 (* info about quotient constants *) |
191 (* quotconsts *) |
171 type quotconsts = {qconst: term, rconst: term, def: thm} |
192 |
172 |
193 val update_quotconsts = map_quotconsts o Symtab.cons_list |
173 fun eq_quotconsts (x : quotconsts, y : quotconsts) = #qconst x = #qconst y |
|
174 |
|
175 (* We need to be able to lookup instances of lifted constants, |
|
176 for example given "nat fset" we need to find "'a fset"; |
|
177 but overloaded constants share the same name *) |
|
178 structure Quotconsts = Generic_Data |
|
179 ( |
|
180 type T = quotconsts list Symtab.table |
|
181 val empty = Symtab.empty |
|
182 val extend = I |
|
183 val merge = Symtab.merge_list eq_quotconsts |
|
184 ) |
|
185 |
|
186 fun transform_quotconsts phi {qconst, rconst, def} = |
|
187 {qconst = Morphism.term phi qconst, |
|
188 rconst = Morphism.term phi rconst, |
|
189 def = Morphism.thm phi def} |
|
190 |
|
191 fun update_quotconsts name qcinfo = Quotconsts.map (Symtab.cons_list (name, qcinfo)) |
|
192 |
194 |
193 fun dest_quotconsts ctxt = |
195 fun dest_quotconsts ctxt = |
194 flat (map snd (Symtab.dest (Quotconsts.get (Context.Proof ctxt)))) |
196 maps snd (Symtab.dest (get_quotconsts (Context.Proof ctxt))) |
195 |
197 |
196 fun dest_quotconsts_global thy = |
198 fun dest_quotconsts_global thy = |
197 flat (map snd (Symtab.dest (Quotconsts.get (Context.Theory thy)))) |
199 maps snd (Symtab.dest (get_quotconsts (Context.Theory thy))) |
198 |
|
199 |
|
200 |
200 |
201 fun lookup_quotconsts_global thy t = |
201 fun lookup_quotconsts_global thy t = |
202 let |
202 let |
203 val (name, qty) = dest_Const t |
203 val (name, qty) = dest_Const t |
204 fun matches (x: quotconsts) = |
204 fun matches (x: quotconsts) = |
205 let val (name', qty') = dest_Const (#qconst x); |
205 let val (name', qty') = dest_Const (#qconst x); |
206 in name = name' andalso Sign.typ_instance thy (qty, qty') end |
206 in name = name' andalso Sign.typ_instance thy (qty, qty') end |
207 in |
207 in |
208 (case Symtab.lookup (Quotconsts.get (Context.Theory thy)) name of |
208 (case Symtab.lookup (get_quotconsts (Context.Theory thy)) name of |
209 NONE => NONE |
209 NONE => NONE |
210 | SOME l => find_first matches l) |
210 | SOME l => find_first matches l) |
211 end |
211 end |
212 |
212 |
213 fun print_quotconsts ctxt = |
213 fun print_quotconsts ctxt = |