wenzelm@46551
|
1 |
(* Title: HOL/Tools/Quotient/quotient_type.ML
|
kaliszyk@35222
|
2 |
Author: Cezary Kaliszyk and Christian Urban
|
kaliszyk@35222
|
3 |
|
urbanc@35806
|
4 |
Definition of a quotient type.
|
kaliszyk@35222
|
5 |
*)
|
kaliszyk@35222
|
6 |
|
kaliszyk@35222
|
7 |
signature QUOTIENT_TYPE =
|
kaliszyk@35222
|
8 |
sig
|
kuncar@47966
|
9 |
val can_generate_code_cert: thm -> bool
|
kuncar@47966
|
10 |
|
kuncar@46542
|
11 |
val add_quotient_type: ((string list * binding * mixfix) * (typ * term * bool) *
|
kuncar@46542
|
12 |
((binding * binding) option)) * thm -> local_theory -> Quotient_Info.quotients * local_theory
|
kaliszyk@35412
|
13 |
|
kuncar@46542
|
14 |
val quotient_type: ((string list * binding * mixfix) * (typ * term * bool) *
|
kuncar@46542
|
15 |
((binding * binding) option)) list -> Proof.context -> Proof.state
|
kaliszyk@35222
|
16 |
|
kuncar@46542
|
17 |
val quotient_type_cmd: (((((string list * binding) * mixfix) * string) * (bool * string)) *
|
kuncar@46542
|
18 |
(binding * binding) option) list -> Proof.context -> Proof.state
|
kaliszyk@35222
|
19 |
end;
|
kaliszyk@35222
|
20 |
|
kaliszyk@35222
|
21 |
structure Quotient_Type: QUOTIENT_TYPE =
|
kaliszyk@35222
|
22 |
struct
|
kaliszyk@35222
|
23 |
|
kaliszyk@35222
|
24 |
|
kaliszyk@35222
|
25 |
(*** definition of quotient types ***)
|
kaliszyk@35222
|
26 |
|
kaliszyk@45075
|
27 |
val mem_def1 = @{lemma "y : Collect S ==> S y" by simp}
|
kaliszyk@45075
|
28 |
val mem_def2 = @{lemma "S y ==> y : Collect S" by simp}
|
kaliszyk@35222
|
29 |
|
kuncar@47970
|
30 |
(* constructs the term {c. EX (x::rty). rel x x \<and> c = Collect (rel x)} *)
|
kaliszyk@35222
|
31 |
fun typedef_term rel rty lthy =
|
wenzelm@41700
|
32 |
let
|
wenzelm@41700
|
33 |
val [x, c] =
|
wenzelm@41700
|
34 |
[("x", rty), ("c", HOLogic.mk_setT rty)]
|
wenzelm@41700
|
35 |
|> Variable.variant_frees lthy [rel]
|
wenzelm@41700
|
36 |
|> map Free
|
wenzelm@41700
|
37 |
in
|
bulwahn@46183
|
38 |
HOLogic.Collect_const (HOLogic.mk_setT rty) $ (lambda c (HOLogic.exists_const rty $
|
kaliszyk@45075
|
39 |
lambda x (HOLogic.mk_conj (rel $ x $ x,
|
bulwahn@46183
|
40 |
HOLogic.mk_eq (c, HOLogic.Collect_const rty $ (rel $ x))))))
|
wenzelm@41700
|
41 |
end
|
kaliszyk@35222
|
42 |
|
kaliszyk@35222
|
43 |
|
kaliszyk@35222
|
44 |
(* makes the new type definitions and proves non-emptyness *)
|
kaliszyk@37493
|
45 |
fun typedef_make (vs, qty_name, mx, rel, rty) equiv_thm lthy =
|
wenzelm@41700
|
46 |
let
|
wenzelm@41700
|
47 |
val typedef_tac =
|
wenzelm@41700
|
48 |
EVERY1 (map rtac [@{thm part_equivp_typedef}, equiv_thm])
|
wenzelm@41700
|
49 |
in
|
cezarykaliszyk@47598
|
50 |
Typedef.add_typedef false NONE (qty_name, map (rpair dummyS) vs, mx)
|
wenzelm@41700
|
51 |
(typedef_term rel rty lthy) NONE typedef_tac lthy
|
wenzelm@41700
|
52 |
end
|
kaliszyk@35222
|
53 |
|
kaliszyk@35222
|
54 |
|
kaliszyk@35222
|
55 |
(* tactic to prove the quot_type theorem for the new type *)
|
wenzelm@35995
|
56 |
fun typedef_quot_type_tac equiv_thm ((_, typedef_info): Typedef.info) =
|
wenzelm@41700
|
57 |
let
|
wenzelm@41700
|
58 |
val rep_thm = #Rep typedef_info RS mem_def1
|
wenzelm@41700
|
59 |
val rep_inv = #Rep_inverse typedef_info
|
wenzelm@41700
|
60 |
val abs_inv = #Abs_inverse typedef_info
|
wenzelm@41700
|
61 |
val rep_inj = #Rep_inject typedef_info
|
wenzelm@41700
|
62 |
in
|
wenzelm@41700
|
63 |
(rtac @{thm quot_type.intro} THEN' RANGE [
|
wenzelm@41700
|
64 |
rtac equiv_thm,
|
wenzelm@41700
|
65 |
rtac rep_thm,
|
wenzelm@41700
|
66 |
rtac rep_inv,
|
wenzelm@41700
|
67 |
rtac abs_inv THEN' rtac mem_def2 THEN' atac,
|
wenzelm@41700
|
68 |
rtac rep_inj]) 1
|
wenzelm@41700
|
69 |
end
|
kaliszyk@35222
|
70 |
|
kaliszyk@35222
|
71 |
(* proves the quot_type theorem for the new type *)
|
kaliszyk@35222
|
72 |
fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy =
|
wenzelm@41700
|
73 |
let
|
bulwahn@46188
|
74 |
val quot_type_const = Const (@{const_name "quot_type"},
|
bulwahn@46188
|
75 |
fastype_of rel --> fastype_of abs --> fastype_of rep --> @{typ bool})
|
bulwahn@46188
|
76 |
val goal = HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep)
|
wenzelm@41700
|
77 |
in
|
wenzelm@41700
|
78 |
Goal.prove lthy [] [] goal
|
wenzelm@41700
|
79 |
(K (typedef_quot_type_tac equiv_thm typedef_info))
|
wenzelm@41700
|
80 |
end
|
kuncar@47966
|
81 |
|
kuncar@47966
|
82 |
fun can_generate_code_cert quot_thm =
|
kuncar@47966
|
83 |
case Quotient_Term.get_rel_from_quot_thm quot_thm of
|
kuncar@47966
|
84 |
Const (@{const_name HOL.eq}, _) => true
|
kuncar@47966
|
85 |
| Const (@{const_name invariant}, _) $ _ => true
|
kuncar@47966
|
86 |
| _ => false
|
kuncar@47966
|
87 |
|
kuncar@47966
|
88 |
fun define_abs_type quot_thm lthy =
|
kuncar@47966
|
89 |
if can_generate_code_cert quot_thm then
|
kuncar@47966
|
90 |
let
|
kuncar@47966
|
91 |
val abs_type_thm = quot_thm RS @{thm Quotient_abs_rep}
|
kuncar@47966
|
92 |
val add_abstype_attribute =
|
kuncar@47966
|
93 |
Thm.declaration_attribute (fn thm => Context.mapping (Code.add_abstype thm) I)
|
kuncar@47966
|
94 |
val add_abstype_attrib = Attrib.internal (K add_abstype_attribute);
|
kuncar@47966
|
95 |
in
|
kuncar@47966
|
96 |
lthy
|
kuncar@47966
|
97 |
|> (snd oo Local_Theory.note) ((Binding.empty, [add_abstype_attrib]), [abs_type_thm])
|
kuncar@47966
|
98 |
end
|
kuncar@47966
|
99 |
else
|
kuncar@47966
|
100 |
lthy
|
kuncar@47966
|
101 |
|
kuncar@47966
|
102 |
fun init_quotient_infr quot_thm equiv_thm lthy =
|
kuncar@47966
|
103 |
let
|
kuncar@47966
|
104 |
val (_ $ rel $ abs $ rep) = (HOLogic.dest_Trueprop o prop_of) quot_thm
|
kuncar@47966
|
105 |
val (qtyp, rtyp) = (dest_funT o fastype_of) rep
|
kuncar@47966
|
106 |
val qty_full_name = (fst o dest_Type) qtyp
|
kuncar@47966
|
107 |
val quotients = {qtyp = qtyp, rtyp = rtyp, equiv_rel = rel, equiv_thm = equiv_thm,
|
kuncar@47966
|
108 |
quot_thm = quot_thm }
|
kuncar@47966
|
109 |
fun quot_info phi = Quotient_Info.transform_quotients phi quotients
|
kuncar@47966
|
110 |
val abs_rep = {abs = abs, rep = rep}
|
kuncar@47966
|
111 |
fun abs_rep_info phi = Quotient_Info.transform_abs_rep phi abs_rep
|
kuncar@47966
|
112 |
in
|
kuncar@47966
|
113 |
lthy
|
kuncar@47966
|
114 |
|> Local_Theory.declaration {syntax = false, pervasive = true}
|
kuncar@47966
|
115 |
(fn phi => Quotient_Info.update_quotients qty_full_name (quot_info phi)
|
kuncar@47966
|
116 |
#> Quotient_Info.update_abs_rep qty_full_name (abs_rep_info phi))
|
kuncar@47966
|
117 |
|> define_abs_type quot_thm
|
kuncar@47966
|
118 |
end
|
kaliszyk@35222
|
119 |
|
kaliszyk@35222
|
120 |
(* main function for constructing a quotient type *)
|
kuncar@46542
|
121 |
fun add_quotient_type (((vs, qty_name, mx), (rty, rel, partial), opt_morphs), equiv_thm) lthy =
|
wenzelm@41700
|
122 |
let
|
wenzelm@41700
|
123 |
val part_equiv =
|
wenzelm@41700
|
124 |
if partial
|
wenzelm@41700
|
125 |
then equiv_thm
|
wenzelm@41700
|
126 |
else equiv_thm RS @{thm equivp_implies_part_equivp}
|
kaliszyk@37493
|
127 |
|
wenzelm@41700
|
128 |
(* generates the typedef *)
|
kuncar@47966
|
129 |
val ((_, typedef_info), lthy1) =
|
wenzelm@41700
|
130 |
typedef_make (vs, qty_name, mx, rel, rty) part_equiv lthy
|
kaliszyk@35222
|
131 |
|
wenzelm@41700
|
132 |
(* abs and rep functions from the typedef *)
|
wenzelm@41700
|
133 |
val Abs_ty = #abs_type (#1 typedef_info)
|
wenzelm@41700
|
134 |
val Rep_ty = #rep_type (#1 typedef_info)
|
wenzelm@41700
|
135 |
val Abs_name = #Abs_name (#1 typedef_info)
|
wenzelm@41700
|
136 |
val Rep_name = #Rep_name (#1 typedef_info)
|
wenzelm@41700
|
137 |
val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty)
|
wenzelm@41700
|
138 |
val Rep_const = Const (Rep_name, Abs_ty --> Rep_ty)
|
kaliszyk@35222
|
139 |
|
wenzelm@41700
|
140 |
(* more useful abs and rep definitions *)
|
bulwahn@46188
|
141 |
val abs_const = Const (@{const_name quot_type.abs},
|
bulwahn@46188
|
142 |
(rty --> rty --> @{typ bool}) --> (Rep_ty --> Abs_ty) --> rty --> Abs_ty)
|
bulwahn@46188
|
143 |
val rep_const = Const (@{const_name quot_type.rep}, (Abs_ty --> Rep_ty) --> Abs_ty --> rty)
|
bulwahn@46188
|
144 |
val abs_trm = abs_const $ rel $ Abs_const
|
bulwahn@46188
|
145 |
val rep_trm = rep_const $ Rep_const
|
kuncar@46542
|
146 |
val (rep_name, abs_name) =
|
kuncar@46542
|
147 |
(case opt_morphs of
|
kuncar@46542
|
148 |
NONE => (Binding.prefix_name "rep_" qty_name, Binding.prefix_name "abs_" qty_name)
|
kuncar@46542
|
149 |
| SOME morphs => morphs)
|
kaliszyk@35222
|
150 |
|
kuncar@47966
|
151 |
val ((_, (_, abs_def)), lthy2) = lthy1
|
wenzelm@47780
|
152 |
|> Local_Theory.define ((abs_name, NoSyn), ((Thm.def_binding abs_name, []), abs_trm))
|
kuncar@47966
|
153 |
val ((_, (_, rep_def)), lthy3) = lthy2
|
wenzelm@47780
|
154 |
|> Local_Theory.define ((rep_name, NoSyn), ((Thm.def_binding rep_name, []), rep_trm))
|
kaliszyk@35222
|
155 |
|
wenzelm@41700
|
156 |
(* quot_type theorem *)
|
wenzelm@41700
|
157 |
val quot_thm = typedef_quot_type_thm (rel, Abs_const, Rep_const, part_equiv, typedef_info) lthy3
|
kaliszyk@35222
|
158 |
|
wenzelm@41700
|
159 |
(* quotient theorem *)
|
wenzelm@41700
|
160 |
val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name
|
wenzelm@41700
|
161 |
val quotient_thm =
|
wenzelm@41700
|
162 |
(quot_thm RS @{thm quot_type.Quotient})
|
wenzelm@41700
|
163 |
|> fold_rule [abs_def, rep_def]
|
kaliszyk@35222
|
164 |
|
wenzelm@41700
|
165 |
(* name equivalence theorem *)
|
wenzelm@41700
|
166 |
val equiv_thm_name = Binding.suffix_name "_equivp" qty_name
|
kaliszyk@35222
|
167 |
|
wenzelm@46150
|
168 |
(* storing the quotients *)
|
kuncar@47963
|
169 |
val quotients = {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_thm,
|
kuncar@47963
|
170 |
quot_thm = quotient_thm}
|
urbanc@37523
|
171 |
|
wenzelm@41700
|
172 |
val lthy4 = lthy3
|
kuncar@47966
|
173 |
|> init_quotient_infr quotient_thm equiv_thm
|
wenzelm@46153
|
174 |
|> (snd oo Local_Theory.note)
|
wenzelm@46153
|
175 |
((equiv_thm_name,
|
wenzelm@46153
|
176 |
if partial then [] else [Attrib.internal (K Quotient_Info.equiv_rules_add)]),
|
wenzelm@46153
|
177 |
[equiv_thm])
|
wenzelm@46153
|
178 |
|> (snd oo Local_Theory.note)
|
wenzelm@46153
|
179 |
((quotient_thm_name, [Attrib.internal (K Quotient_Info.quotient_rules_add)]),
|
wenzelm@46153
|
180 |
[quotient_thm])
|
wenzelm@41700
|
181 |
in
|
wenzelm@46150
|
182 |
(quotients, lthy4)
|
wenzelm@41700
|
183 |
end
|
kaliszyk@35222
|
184 |
|
kaliszyk@35222
|
185 |
|
kaliszyk@35222
|
186 |
(* sanity checks for the quotient type specifications *)
|
kuncar@46542
|
187 |
fun sanity_check ((vs, qty_name, _), (rty, rel, _), _) =
|
wenzelm@41700
|
188 |
let
|
wenzelm@41700
|
189 |
val rty_tfreesT = map fst (Term.add_tfreesT rty [])
|
wenzelm@41700
|
190 |
val rel_tfrees = map fst (Term.add_tfrees rel [])
|
wenzelm@41700
|
191 |
val rel_frees = map fst (Term.add_frees rel [])
|
wenzelm@41700
|
192 |
val rel_vars = Term.add_vars rel []
|
wenzelm@41700
|
193 |
val rel_tvars = Term.add_tvars rel []
|
wenzelm@44418
|
194 |
val qty_str = Binding.print qty_name ^ ": "
|
kaliszyk@35222
|
195 |
|
wenzelm@41700
|
196 |
val illegal_rel_vars =
|
wenzelm@41700
|
197 |
if null rel_vars andalso null rel_tvars then []
|
wenzelm@41700
|
198 |
else [qty_str ^ "illegal schematic variable(s) in the relation."]
|
kaliszyk@35222
|
199 |
|
wenzelm@41700
|
200 |
val dup_vs =
|
wenzelm@41700
|
201 |
(case duplicates (op =) vs of
|
wenzelm@41700
|
202 |
[] => []
|
wenzelm@41700
|
203 |
| dups => [qty_str ^ "duplicate type variable(s) on the lhs: " ^ commas_quote dups])
|
kaliszyk@35222
|
204 |
|
wenzelm@41700
|
205 |
val extra_rty_tfrees =
|
wenzelm@41700
|
206 |
(case subtract (op =) vs rty_tfreesT of
|
wenzelm@41700
|
207 |
[] => []
|
wenzelm@41700
|
208 |
| extras => [qty_str ^ "extra type variable(s) on the lhs: " ^ commas_quote extras])
|
kaliszyk@35222
|
209 |
|
wenzelm@41700
|
210 |
val extra_rel_tfrees =
|
wenzelm@41700
|
211 |
(case subtract (op =) vs rel_tfrees of
|
wenzelm@41700
|
212 |
[] => []
|
wenzelm@41700
|
213 |
| extras => [qty_str ^ "extra type variable(s) in the relation: " ^ commas_quote extras])
|
kaliszyk@35222
|
214 |
|
wenzelm@41700
|
215 |
val illegal_rel_frees =
|
wenzelm@41700
|
216 |
(case rel_frees of
|
wenzelm@41700
|
217 |
[] => []
|
wenzelm@41700
|
218 |
| xs => [qty_str ^ "illegal variable(s) in the relation: " ^ commas_quote xs])
|
kaliszyk@35222
|
219 |
|
wenzelm@41700
|
220 |
val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees
|
wenzelm@41700
|
221 |
in
|
wenzelm@41700
|
222 |
if null errs then () else error (cat_lines errs)
|
wenzelm@41700
|
223 |
end
|
kaliszyk@35222
|
224 |
|
kaliszyk@35222
|
225 |
(* check for existence of map functions *)
|
kuncar@46666
|
226 |
fun map_check ctxt (_, (rty, _, _), _) =
|
wenzelm@41700
|
227 |
let
|
wenzelm@41700
|
228 |
fun map_check_aux rty warns =
|
wenzelm@46151
|
229 |
(case rty of
|
wenzelm@41700
|
230 |
Type (_, []) => warns
|
wenzelm@46211
|
231 |
| Type (s, _) =>
|
kuncar@46666
|
232 |
if Symtab.defined (Enriched_Type.entries ctxt) s then warns else s :: warns
|
wenzelm@46151
|
233 |
| _ => warns)
|
kaliszyk@35222
|
234 |
|
wenzelm@41700
|
235 |
val warns = map_check_aux rty []
|
wenzelm@41700
|
236 |
in
|
wenzelm@41700
|
237 |
if null warns then ()
|
wenzelm@41700
|
238 |
else warning ("No map function defined for " ^ commas warns ^
|
wenzelm@41700
|
239 |
". This will cause problems later on.")
|
wenzelm@41700
|
240 |
end
|
kaliszyk@35222
|
241 |
|
kaliszyk@35222
|
242 |
|
kaliszyk@35222
|
243 |
(*** interface and syntax setup ***)
|
kaliszyk@35222
|
244 |
|
kuncar@46564
|
245 |
(* the ML-interface takes a list of tuples consisting of:
|
kuncar@46564
|
246 |
|
kuncar@46564
|
247 |
- the name of the quotient type
|
kuncar@46564
|
248 |
- its free type variables (first argument)
|
kuncar@46564
|
249 |
- its mixfix annotation
|
kuncar@46564
|
250 |
- the type to be quotient
|
kuncar@46564
|
251 |
- the partial flag (a boolean)
|
kuncar@46564
|
252 |
- the relation according to which the type is quotient
|
kuncar@46564
|
253 |
- optional names of morphisms (rep/abs)
|
kuncar@46564
|
254 |
|
kuncar@46564
|
255 |
it opens a proof-state in which one has to show that the
|
kuncar@46564
|
256 |
relations are equivalence relations
|
kuncar@46564
|
257 |
*)
|
kuncar@46564
|
258 |
|
kaliszyk@35222
|
259 |
fun quotient_type quot_list lthy =
|
wenzelm@41700
|
260 |
let
|
wenzelm@41700
|
261 |
(* sanity check *)
|
wenzelm@41700
|
262 |
val _ = List.app sanity_check quot_list
|
kuncar@46666
|
263 |
val _ = List.app (map_check lthy) quot_list
|
kaliszyk@35222
|
264 |
|
wenzelm@41700
|
265 |
fun mk_goal (rty, rel, partial) =
|
wenzelm@41700
|
266 |
let
|
wenzelm@41700
|
267 |
val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool}
|
wenzelm@41700
|
268 |
val const =
|
wenzelm@41700
|
269 |
if partial then @{const_name part_equivp} else @{const_name equivp}
|
wenzelm@41700
|
270 |
in
|
wenzelm@41700
|
271 |
HOLogic.mk_Trueprop (Const (const, equivp_ty) $ rel)
|
wenzelm@41700
|
272 |
end
|
wenzelm@41700
|
273 |
|
kuncar@46542
|
274 |
val goals = map (mk_goal o #2) quot_list
|
wenzelm@41700
|
275 |
|
wenzelm@46153
|
276 |
fun after_qed [thms] = fold (snd oo add_quotient_type) (quot_list ~~ thms)
|
kaliszyk@35222
|
277 |
in
|
wenzelm@46153
|
278 |
Proof.theorem NONE after_qed [map (rpair []) goals] lthy
|
kaliszyk@35222
|
279 |
end
|
kaliszyk@35222
|
280 |
|
wenzelm@41700
|
281 |
fun quotient_type_cmd specs lthy =
|
wenzelm@41700
|
282 |
let
|
kuncar@46542
|
283 |
fun parse_spec (((((vs, qty_name), mx), rty_str), (partial, rel_str)), opt_morphs) lthy =
|
wenzelm@41700
|
284 |
let
|
wenzelm@41700
|
285 |
val rty = Syntax.read_typ lthy rty_str
|
cezarykaliszyk@47598
|
286 |
val tmp_lthy1 = Variable.declare_typ rty lthy
|
wenzelm@41700
|
287 |
val rel =
|
cezarykaliszyk@47598
|
288 |
Syntax.parse_term tmp_lthy1 rel_str
|
wenzelm@41700
|
289 |
|> Type.constraint (rty --> rty --> @{typ bool})
|
cezarykaliszyk@47598
|
290 |
|> Syntax.check_term tmp_lthy1
|
cezarykaliszyk@47598
|
291 |
val tmp_lthy2 = Variable.declare_term rel tmp_lthy1
|
wenzelm@41700
|
292 |
in
|
cezarykaliszyk@47598
|
293 |
(((vs, qty_name, mx), (rty, rel, partial), opt_morphs), tmp_lthy2)
|
wenzelm@41700
|
294 |
end
|
kaliszyk@35222
|
295 |
|
cezarykaliszyk@47598
|
296 |
val (spec', _) = fold_map parse_spec specs lthy
|
kaliszyk@35222
|
297 |
in
|
cezarykaliszyk@47598
|
298 |
quotient_type spec' lthy
|
kaliszyk@35222
|
299 |
end
|
kaliszyk@35222
|
300 |
|
wenzelm@47823
|
301 |
val partial = Scan.optional (Parse.reserved "partial" -- @{keyword ":"} >> K true) false
|
kaliszyk@37493
|
302 |
|
kuncar@47961
|
303 |
val quotspec_parser =
|
kuncar@47961
|
304 |
Parse.and_list1
|
kuncar@47961
|
305 |
((Parse.type_args -- Parse.binding) --
|
kuncar@47961
|
306 |
(* FIXME Parse.type_args_constrained and standard treatment of sort constraints *)
|
kuncar@47961
|
307 |
Parse.opt_mixfix -- (@{keyword "="} |-- Parse.typ) --
|
kuncar@47961
|
308 |
(@{keyword "/"} |-- (partial -- Parse.term)) --
|
kuncar@47961
|
309 |
Scan.option (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)))
|
kuncar@47961
|
310 |
|
kaliszyk@35222
|
311 |
val _ =
|
wenzelm@47836
|
312 |
Outer_Syntax.local_theory_to_proof @{command_spec "quotient_type"}
|
wenzelm@41700
|
313 |
"quotient type definitions (require equivalence proofs)"
|
kuncar@47966
|
314 |
(quotspec_parser >> quotient_type_cmd)
|
kuncar@47966
|
315 |
|
kuncar@47966
|
316 |
(* Setup lifting using type_def_thm *)
|
kuncar@47966
|
317 |
|
kuncar@47966
|
318 |
exception SETUP_LIFT_TYPE of string
|
kuncar@47966
|
319 |
|
kuncar@47966
|
320 |
fun setup_lift_type typedef_thm =
|
kuncar@47966
|
321 |
let
|
kuncar@47966
|
322 |
val typedef_set = (snd o dest_comb o HOLogic.dest_Trueprop o prop_of) typedef_thm
|
kuncar@47966
|
323 |
val (quot_thm, equivp_thm) = (case typedef_set of
|
kuncar@47966
|
324 |
Const ("Orderings.top_class.top", _) =>
|
kuncar@47966
|
325 |
(typedef_thm RS @{thm copy_type_to_Quotient},
|
kuncar@47966
|
326 |
typedef_thm RS @{thm copy_type_to_equivp})
|
kuncar@47966
|
327 |
| Const (@{const_name "Collect"}, _) $ Abs (_, _, _ $ Bound 0) =>
|
kuncar@47966
|
328 |
(typedef_thm RS @{thm invariant_type_to_Quotient},
|
kuncar@47966
|
329 |
typedef_thm RS @{thm invariant_type_to_part_equivp})
|
kuncar@47966
|
330 |
| _ => raise SETUP_LIFT_TYPE "unsupported typedef theorem")
|
kuncar@47966
|
331 |
in
|
kuncar@47966
|
332 |
init_quotient_infr quot_thm equivp_thm
|
kuncar@47966
|
333 |
end
|
kuncar@47966
|
334 |
|
kuncar@47966
|
335 |
fun setup_lift_type_aux xthm lthy = setup_lift_type (singleton (Attrib.eval_thms lthy) xthm) lthy
|
kuncar@47966
|
336 |
|
kuncar@47966
|
337 |
val _ =
|
kuncar@47966
|
338 |
Outer_Syntax.local_theory @{command_spec "setup_lifting"}
|
kuncar@47966
|
339 |
"Setup lifting infrastracture"
|
kuncar@47966
|
340 |
(Parse_Spec.xthm >> (fn xthm => setup_lift_type_aux xthm))
|
kaliszyk@35222
|
341 |
|
wenzelm@46151
|
342 |
end;
|