used Local_Theory.declaration for storing quotdata
authorChristian Urban <urbanc@in.tum.de>
Thu, 24 Dec 2009 00:58:50 +0100
changeset 786 d6407afb913c
parent 785 bf6861ee3b90
child 787 5cf83fa5b36c
used Local_Theory.declaration for storing quotdata
Quot/Examples/AbsRepTest.thy
Quot/quotient_info.ML
Quot/quotient_term.ML
Quot/quotient_typ.ML
--- a/Quot/Examples/AbsRepTest.thy	Wed Dec 23 23:53:03 2009 +0100
+++ b/Quot/Examples/AbsRepTest.thy	Thu Dec 24 00:58:50 2009 +0100
@@ -2,6 +2,8 @@
 imports "../QuotMain" "../QuotList" "../QuotOption" "../QuotSum" "../QuotProd" List
 begin
 
+print_maps
+
 quotient_type 
   fset = "'a list" / "\<lambda>(xs::'a list) ys. \<forall>e. e \<in> set xs \<longleftrightarrow> e \<in> set ys" 
   apply(rule equivpI)
--- a/Quot/quotient_info.ML	Wed Dec 23 23:53:03 2009 +0100
+++ b/Quot/quotient_info.ML	Thu Dec 24 00:58:50 2009 +0100
@@ -8,12 +8,12 @@
   val maps_update: string -> maps_info -> Proof.context -> Proof.context     
   val print_mapsinfo: Proof.context -> unit
 
-  type quotient_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
-  val quotdata_lookup_thy: theory -> string -> quotient_info     (* raises NotFound *)
-  val quotdata_lookup: Proof.context -> string -> quotient_info     (* raises NotFound *)
-  val quotdata_update_thy: string -> (typ * typ * term * thm) -> theory -> theory
-  val quotdata_update: string -> (typ * typ * term * thm) -> Proof.context -> Proof.context
-  val quotdata_dest: theory -> quotient_info list
+  type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
+  val quotdata_transfer: morphism -> quotdata_info -> quotdata_info
+  val quotdata_lookup: theory -> string -> quotdata_info     (* raises NotFound *)
+  val quotdata_update_thy: string -> quotdata_info -> theory -> theory
+  val quotdata_update_gen: string -> quotdata_info -> Context.generic -> Context.generic
+  val quotdata_dest: theory -> quotdata_info list
   val print_quotinfo: Proof.context -> unit
 
   type qconsts_info = {qconst: term, rconst: term, def: thm}
@@ -60,7 +60,7 @@
 fun maps_update k minfo = ProofContext.theory (maps_update_thy k minfo)
 
 fun maps_attribute_aux s minfo = Thm.declaration_attribute 
-  (fn thm => Context.mapping (maps_update_thy s minfo) (maps_update s minfo))
+  (fn _ => Context.mapping (maps_update_thy s minfo) (maps_update s minfo))
 
 (* attribute to be used in declare statements *)
 fun maps_attribute (ctxt, (tystr, (mapstr, relstr))) = 
@@ -98,36 +98,33 @@
   MapsData.get (ProofContext.theory_of ctxt)
   |> Symtab.dest
   |> map (prt_map)
-  |> Pretty.big_list "maps:" 
+  |> Pretty.big_list "maps for type constructors:" 
   |> Pretty.writeln
 end
 
  
 (* info about quotient types *)
-type quotient_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
+type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
 
 structure QuotData = Theory_Data
-  (type T = quotient_info Symtab.table
+  (type T = quotdata_info Symtab.table
    val empty = Symtab.empty
    val extend = I
    val merge = Symtab.merge (K true)) 
 
-fun quotdata_lookup_thy thy s = 
-  case Symtab.lookup (QuotData.get thy) (Sign.intern_type thy s) of
+fun quotdata_transfer phi {qtyp, rtyp, equiv_rel, equiv_thm} =
+    {qtyp = Morphism.typ phi qtyp,
+     rtyp = Morphism.typ phi rtyp,
+     equiv_rel = Morphism.term phi equiv_rel,
+     equiv_thm = Morphism.thm phi equiv_thm}
+
+fun quotdata_lookup thy str = 
+  case Symtab.lookup (QuotData.get thy) str of
     SOME qinfo => qinfo
   | NONE => raise NotFound
 
-val quotdata_lookup = quotdata_lookup_thy o ProofContext.theory_of
-
-fun quotdata_update_thy qty_name (qty, rty, equiv_rel, equiv_thm) =
-let
-  val qinfo = {qtyp = qty, rtyp = rty, equiv_rel = equiv_rel, equiv_thm = equiv_thm}
-in
-  QuotData.map (Symtab.update (qty_name, qinfo))
-end
-
-fun quotdata_update qty_name (qty, rty, rel, equiv_thm) = 
-      ProofContext.theory (quotdata_update_thy qty_name (qty, rty, rel, equiv_thm))
+fun quotdata_update_thy str qinfo = QuotData.map (Symtab.update (str, qinfo))
+fun quotdata_update_gen str qinfo = Context.mapping (quotdata_update_thy str qinfo) I
 
 fun quotdata_dest thy =
     map snd (Symtab.dest (QuotData.get thy))
@@ -167,8 +164,8 @@
      rconst = Morphism.term phi rconst,
      def = Morphism.thm phi def}
 
-fun qconsts_update_thy id qcinfo = QConstsData.map (Symtab.update (id, qcinfo))
-fun qconsts_update_gen id qcinfo = Context.mapping (qconsts_update_thy id qcinfo) I
+fun qconsts_update_thy str qcinfo = QConstsData.map (Symtab.update (str, qcinfo))
+fun qconsts_update_gen str qcinfo = Context.mapping (qconsts_update_thy str qcinfo) I
 
 fun qconsts_dest thy =
   map snd (Symtab.dest (QConstsData.get thy))
--- a/Quot/quotient_term.ML	Wed Dec 23 23:53:03 2009 +0100
+++ b/Quot/quotient_term.ML	Thu Dec 24 00:58:50 2009 +0100
@@ -154,7 +154,7 @@
        else 
          let
            val exc = LIFT_MATCH ("mk_resp_arg (no quotient found for type " ^ s ^ ")") 
-           val equiv_rel = #equiv_rel (quotdata_lookup_thy thy s') handle NotFound => raise exc
+           val equiv_rel = #equiv_rel (quotdata_lookup thy s') handle NotFound => raise exc
            (* FIXME: check in this case that the rty and qty *)
            (* FIXME: correspond to each other *)
 
--- a/Quot/quotient_typ.ML	Wed Dec 23 23:53:03 2009 +0100
+++ b/Quot/quotient_typ.ML	Thu Dec 24 00:58:50 2009 +0100
@@ -155,11 +155,12 @@
   val equiv_thm_name = Binding.suffix_name "_equivp" qty_name
 
   (* storing the quot-info *)
-  val lthy4 = quotdata_update qty_full_name 
-               (Logic.varifyT Abs_ty, Logic.varifyT rty, map_types Logic.varifyT rel, equiv_thm) lthy3  
   (* FIXME: VarifyT should not be used - at the moment it allows matching against the types. *)
-  (* FIXME: The relation can be any term, that later maybe needs to be given *)
-  (* FIXME: a different type (in regularize_trm); how should this be done?   *)
+  fun qinfo phi = quotdata_transfer phi
+                    {qtyp = Logic.varifyT Abs_ty, rtyp = Logic.varifyT rty, 
+                     equiv_rel = map_types Logic.varifyT rel, equiv_thm = equiv_thm}
+  val lthy4 = Local_Theory.declaration true
+                (fn phi => quotdata_update_gen qty_full_name (qinfo phi)) lthy3  
 in
   lthy4
   |> note (quotient_thm_name, quotient_thm, [intern_attr quotient_rules_add])