--- a/quotient_def.ML Wed Nov 04 11:59:48 2009 +0100
+++ b/quotient_def.ML Wed Nov 04 12:07:22 2009 +0100
@@ -15,6 +15,7 @@
structure Quotient_Def: QUOTIENT_DEF =
struct
+(* wrapper for define *)
fun define name mx attr rhs lthy =
let
val ((rhs, (_ , thm)), lthy') =
@@ -120,6 +121,8 @@
| diffs _ _ = error "Unequal length of type arguments"
+(* sanity check that the calculated quotient environment
+ matches with the stored quotient environment. *)
fun error_msg lthy (qty, rty) =
let
val qtystr = quote (Syntax.string_of_typ lthy qty)
@@ -130,21 +133,21 @@
fun sanity_chk lthy qenv =
let
- val qenv' = Quotient_Info.mk_qenv lthy
- val thy = ProofContext.theory_of lthy
+ val qenv' = Quotient_Info.mk_qenv lthy
+ val thy = ProofContext.theory_of lthy
- fun is_inst thy (qty, rty) (qty', rty') =
- if Sign.typ_instance thy (qty, qty')
- then let
- val inst = Sign.typ_match thy (qty', qty) Vartab.empty
- in
- rty = Envir.subst_type inst rty'
- end
- else false
+ fun is_inst thy (qty, rty) (qty', rty') =
+ if Sign.typ_instance thy (qty, qty')
+ then let
+ val inst = Sign.typ_match thy (qty', qty) Vartab.empty
+ in
+ rty = Envir.subst_type inst rty'
+ end
+ else false
- fun chk_inst (qty, rty) =
- if exists (is_inst thy (qty, rty)) qenv' then true
- else error_msg lthy (qty, rty)
+ fun chk_inst (qty, rty) =
+ if exists (is_inst thy (qty, rty)) qenv' then true
+ else error_msg lthy (qty, rty)
in
forall chk_inst qenv
end
@@ -162,13 +165,6 @@
make_def bind rhs qty mx attr qenv lthy
end
-
-val quotdef_parser =
- (OuterParse.binding --
- (OuterParse.$$$ "::" |-- OuterParse.!!! (OuterParse.typ --
- OuterParse.opt_mixfix' --| OuterParse.where_)) >> OuterParse.triple2) --
- (SpecParse.opt_thm_name ":" -- OuterParse.prop)
-
fun quotdef_cmd ((bind, qtystr, mx), (attr, propstr)) lthy =
let
val qty = (Syntax.check_typ lthy o Syntax.parse_typ lthy) qtystr
@@ -177,6 +173,13 @@
quotdef ((bind, qty, mx), (attr, prop)) lthy |> snd
end
+
+val quotdef_parser =
+ (OuterParse.binding --
+ (OuterParse.$$$ "::" |-- OuterParse.!!! (OuterParse.typ --
+ OuterParse.opt_mixfix' --| OuterParse.where_)) >> OuterParse.triple2) --
+ (SpecParse.opt_thm_name ":" -- OuterParse.prop)
+
val _ = OuterSyntax.local_theory "quotient_def" "lifted definition of constants"
OuterKeyword.thy_decl (quotdef_parser >> quotdef_cmd)