# HG changeset patch
# User blanchet
# Date 1367254338 -7200
# Node ID 27d073b0876cc385c8eb4526f42caf66e4f3fcc4
# Parent  38996458bc5c75ebe755e46c432abf14c4046094
register all (co)datatypes in local data

diff -r 38996458bc5c -r 27d073b0876c src/HOL/BNF/Tools/bnf_fp_def_sugar.ML
--- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Apr 29 17:37:00 2013 +0200
+++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Apr 29 18:52:18 2013 +0200
@@ -8,7 +8,8 @@
 signature BNF_FP_DEF_SUGAR =
 sig
   type fp =
-    {fp_index: int,
+    {lfp: bool,
+     fp_index: int,
      fp_res: BNF_FP.fp_result,
      ctr_wrap_res: BNF_Ctr_Sugar.ctr_wrap_result};
 
@@ -30,8 +31,8 @@
     Proof.context ->
     (thm * thm list * thm * thm list * Args.src list) * (thm list list * thm list list * 'e list)
     * (thm list list * thm list list) * (thm list list * thm list list * Args.src list)
-    * (thm list list * thm list list * Args.src list) *
-    (thm list list * thm list list * Args.src list)
+    * (thm list list * thm list list * Args.src list)
+    * (thm list list * thm list list * Args.src list)
 
   val datatypes: bool ->
     (mixfix list -> (string * sort) list option -> binding list -> binding list -> binding list ->
@@ -60,16 +61,17 @@
 val EqN = "Eq_";
 
 type fp =
-  {fp_index: int,
+  {lfp: bool,
+   fp_index: int,
    fp_res: fp_result,
    ctr_wrap_res: ctr_wrap_result};
 
-fun eq_fp ({fp_index = fp_index1, fp_res = fp_res1, ...} : fp,
-    {fp_index = fp_index2, fp_res = fp_res2, ...} : fp) =
-  fp_index1 = fp_index2 andalso eq_fp_result (fp_res1, fp_res2);
+fun eq_fp ({lfp = lfp1, fp_index = fp_index1, fp_res = fp_res1, ...} : fp,
+    {lfp = lfp2, fp_index = fp_index2, fp_res = fp_res2, ...} : fp) =
+  lfp1 = lfp2 andalso fp_index1 = fp_index2 andalso eq_fp_result (fp_res1, fp_res2);
 
-fun morph_fp phi {fp_index, fp_res, ctr_wrap_res} =
-  {fp_index = fp_index, fp_res = morph_fp_result phi fp_res,
+fun morph_fp phi {lfp, fp_index, fp_res, ctr_wrap_res} =
+  {lfp = lfp, fp_index = fp_index, fp_res = morph_fp_result phi fp_res,
    ctr_wrap_res = morph_ctr_wrap_result phi ctr_wrap_res};
 
 structure Data = Generic_Data
@@ -86,6 +88,15 @@
   Local_Theory.declaration {syntax = false, pervasive = true}
     (fn phi => Data.map (Symtab.update_new (key, morph_fp phi fp)));
 
+val fp_name_of_ctor = fst o dest_Type o range_type o fastype_of;
+
+fun register_fps lfp (fp_res as {ctors, ...}) ctr_wrap_ress lthy =
+  ((1, ctors), lthy)
+  |> fold (fn ctr_wrap_res => fn ((kk, ctor :: ctors), lthy) =>
+    ((kk + 1, ctors), register_fp (fp_name_of_ctor ctor) {lfp = lfp, fp_index = kk,
+       fp_res = fp_res, ctr_wrap_res = ctr_wrap_res} lthy)) ctr_wrap_ress
+  |> snd;
+
 (* This function could produce clashes in contrived examples (e.g., "x.A", "x.x_A", "y.A"). *)
 fun quasi_unambiguous_case_names names =
   let
@@ -757,7 +768,7 @@
     val fp_eqs =
       map dest_TFree Xs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctr_sum_prod_TsXs;
 
-    val (pre_bnfs, ({bnfs = fp_bnfs as any_fp_bnf :: _, dtors = dtors0, ctors = ctors0,
+    val (pre_bnfs, (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, dtors = dtors0, ctors = ctors0,
            folds = fp_folds0, recs = fp_recs0, induct = fp_induct, strong_induct = fp_strong_induct,
            dtor_ctors, ctor_dtors, ctor_injects, map_thms = fp_map_thms, set_thmss = fp_set_thmss,
            rel_thms = fp_rel_thms, fold_thms = fp_fold_thms, rec_thms = fp_rec_thms}, lthy)) =
@@ -1265,7 +1276,9 @@
            (simpsN, simp_thmss, K [])]
           |> massage_multi_notes;
       in
-        lthy |> Local_Theory.notes (common_notes @ notes) |> snd
+        lthy
+        |> Local_Theory.notes (common_notes @ notes) |> snd
+        |> register_fps true fp_res ctr_wrap_ress
       end;
 
     fun derive_and_note_coinduct_unfold_corec_thms_for_types
@@ -1320,7 +1333,9 @@
            (unfoldN, unfold_thmss, K corec_like_attrs)]
           |> massage_multi_notes;
       in
-        lthy |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd
+        lthy
+        |> Local_Theory.notes (anonymous_notes @ common_notes @ notes) |> snd
+        |> register_fps false fp_res ctr_wrap_ress
       end;
 
     val lthy' = lthy