diff -r 5f3b364d4765 -r c18308f60f0e QuotMain.thy --- a/QuotMain.thy Tue Nov 03 14:04:21 2009 +0100 +++ b/QuotMain.thy Tue Nov 03 14:04:45 2009 +0100 @@ -1,8 +1,11 @@ theory QuotMain imports QuotScript QuotList Prove -uses ("quotient.ML") +uses ("quotient_info.ML") + ("quotient.ML") begin +ML {* Attrib.empty_binding *} + locale QUOT_TYPE = fixes R :: "'a \ 'a \ bool" and Abs :: "('a \ bool) \ 'b" @@ -137,6 +140,7 @@ section {* type definition for the quotient type *} +use "quotient_info.ML" use "quotient.ML" declare [[map list = (map, LIST_REL)]] @@ -300,11 +304,11 @@ fun build_qenv lthy qtys = let val qenv = map (fn {qtyp, rtyp, ...} => (qtyp, rtyp)) (quotdata_lookup lthy) - val tsig = Sign.tsig_of (ProofContext.theory_of lthy) + val thy = ProofContext.theory_of lthy fun find_assoc ((qty', rty')::rest) qty = let - val inst = Type.typ_match tsig (qty', qty) Vartab.empty + val inst = Sign.typ_match thy (qty', qty) Vartab.empty in (Envir.norm_type inst qty, Envir.norm_type inst rty') end @@ -319,32 +323,40 @@ end *} + ML {* -val qd_parser = - (Args.parens (OuterParse.$$$ "for" |-- (Scan.repeat OuterParse.typ))) -- - (SpecParse.constdecl -- (SpecParse.opt_thm_name ":" -- OuterParse.prop)) +fun quotdef_cmd qenv ((bind, qty_, mx), (attr, prop)) lthy = +let + val (lhs_, rhs) = Logic.dest_equals prop +in + make_const_def bind rhs mx qenv lthy +end *} ML {* -fun parse_qd_spec (qtystrs, ((bind, tystr, mx), (attr__, propstr))) lthy = +val quotdef_parser = + Scan.option (Args.parens (OuterParse.$$$ "for" |-- (Scan.repeat OuterParse.typ))) -- + (SpecParse.constdecl -- (SpecParse.opt_thm_name ":" -- + OuterParse.prop)) >> OuterParse.triple2 +*} + +ML {* +fun quotdef (qtystrs, (bind, tystr, mx), (attr, propstr)) lthy = let - val qtys = map (Syntax.check_typ lthy o Syntax.parse_typ lthy) qtystrs + val qtys = map (Syntax.check_typ lthy o Syntax.parse_typ lthy) (the qtystrs) val qenv = build_qenv lthy qtys - val qty = Syntax.parse_typ lthy (the tystr) |> Syntax.check_typ lthy + val qty = Option.map (Syntax.check_typ lthy o Syntax.parse_typ lthy) tystr val prop = Syntax.parse_prop lthy propstr |> Syntax.check_prop lthy - val (lhs, rhs) = Logic.dest_equals prop in - make_const_def bind rhs mx qenv lthy |> snd + quotdef_cmd qenv ((bind, qty, mx), (attr, prop)) lthy |> snd end *} ML {* val _ = OuterSyntax.local_theory "quotient_def" "lifted definition of constants" - OuterKeyword.thy_decl (qd_parser >> parse_qd_spec) + OuterKeyword.thy_decl (quotdef_parser >> quotdef) *} -(* ML {* show_all_types := true *} *) - section {* ATOMIZE *} text {*