add 'co_rec_transfers' to 'fp_sugar'
authordesharna
Mon, 06 Oct 2014 13:35:15 +0200
changeset 58573 04f5d23cd9e5
parent 58572 2e0cf67fa89f
child 58574 e66ed9634a74
add 'co_rec_transfers' to 'fp_sugar'
src/HOL/Tools/BNF/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML
src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML
--- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Mon Oct 06 13:35:03 2014 +0200
+++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Mon Oct 06 13:35:15 2014 +0200
@@ -38,7 +38,9 @@
      co_rec_thms: thm list,
      co_rec_discs: thm list,
      co_rec_disc_iffs: thm list,
-     co_rec_selss: thm list list}
+     co_rec_selss: thm list list,
+     co_rec_codes: thm list,
+     co_rec_transfers: thm list}
 
   type fp_sugar =
     {T: typ,
@@ -203,7 +205,9 @@
    co_rec_thms: thm list,
    co_rec_discs: thm list,
    co_rec_disc_iffs: thm list,
-   co_rec_selss: thm list list};
+   co_rec_selss: thm list list,
+   co_rec_codes: thm list,
+   co_rec_transfers: thm list};
 
 type fp_sugar =
   {T: typ,
@@ -236,7 +240,8 @@
    set_cases = map (Morphism.thm phi) set_cases};
 
 fun morph_fp_co_induct_sugar phi ({co_rec, common_co_inducts, co_inducts, co_rec_def, co_rec_thms,
-    co_rec_discs, co_rec_disc_iffs, co_rec_selss} : fp_co_induct_sugar) =
+    co_rec_discs, co_rec_disc_iffs, co_rec_selss, co_rec_codes, co_rec_transfers
+    } : fp_co_induct_sugar) =
   {co_rec = Morphism.term phi co_rec,
    common_co_inducts = map (Morphism.thm phi) common_co_inducts,
    co_inducts = map (Morphism.thm phi) co_inducts,
@@ -244,7 +249,9 @@
    co_rec_thms = map (Morphism.thm phi) co_rec_thms,
    co_rec_discs = map (Morphism.thm phi) co_rec_discs,
    co_rec_disc_iffs = map (Morphism.thm phi) co_rec_disc_iffs,
-   co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss};
+   co_rec_selss = map (map (Morphism.thm phi)) co_rec_selss,
+   co_rec_codes = map (Morphism.thm phi) co_rec_codes,
+   co_rec_transfers = map (Morphism.thm phi) co_rec_transfers};
 
 fun morph_fp_ctr_sugar phi ({ctrXs_Tss, ctr_defs, ctr_sugar, ctr_transfers, case_transfers,
     disc_transfers} : fp_ctr_sugar) =
@@ -323,7 +330,8 @@
     live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars co_recs co_rec_defs map_thmss
     common_co_inducts co_inductss co_rec_thmss co_rec_discss co_rec_selsss rel_injectss
     rel_distinctss map_disc_iffss map_selss rel_selss rel_intross rel_casess set_thmss set_selss
-    set_intross set_casess ctr_transferss case_transferss disc_transferss co_rec_disc_iffss noted =
+    set_intross set_casess ctr_transferss case_transferss disc_transferss co_rec_disc_iffss
+    co_rec_codess co_rec_transferss noted =
   let
     val fp_sugars =
       map_index (fn (kk, T) =>
@@ -358,7 +366,9 @@
             co_rec_thms = nth co_rec_thmss kk,
             co_rec_discs = nth co_rec_discss kk,
             co_rec_disc_iffs = nth co_rec_disc_iffss kk,
-            co_rec_selss = nth co_rec_selsss kk}}
+            co_rec_selss = nth co_rec_selsss kk,
+            co_rec_codes = nth co_rec_codess kk,
+            co_rec_transfers = nth co_rec_transferss kk}}
         |> morph_fp_sugar (substitute_noted_thm noted)) Ts;
   in
     register_fp_sugars_raw fp_sugars
@@ -2205,7 +2215,7 @@
           map_thmss [induct_thm] (map single induct_thms) rec_thmss (replicate nn [])
           (replicate nn []) rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
-          case_transferss disc_transferss (replicate nn [])
+          case_transferss disc_transferss (replicate nn []) (replicate nn []) rec_transfer_thmss
       end;
 
     fun derive_corec_transfer_thms lthy corecs corec_defs =
@@ -2323,7 +2333,8 @@
           (transpose [coinduct_thms, coinduct_strong_thms]) corec_thmss corec_disc_thmss
           corec_sel_thmsss rel_injectss rel_distinctss map_disc_iffss map_selss rel_selss
           rel_intross rel_casess set_thmss set_selss set_intross set_casess ctr_transferss
-          case_transferss disc_transferss corec_disc_iff_thmss
+          case_transferss disc_transferss corec_disc_iff_thmss (map single corec_code_thms)
+          corec_transfer_thmss
       end;
 
     val lthy'' = lthy'
--- a/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML	Mon Oct 06 13:35:03 2014 +0200
+++ b/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML	Mon Oct 06 13:35:15 2014 +0200
@@ -296,7 +296,7 @@
             ({fp_ctr_sugar = {ctr_transfers, case_transfers, disc_transfers, ...},
               fp_bnf_sugar = {map_disc_iffs, map_sels, rel_injects, rel_distincts, rel_sels,
                 rel_intros, rel_cases, set_thms, set_sels, set_intros, set_cases, ...},
-              fp_co_induct_sugar = {co_rec_disc_iffs, ...},
+              fp_co_induct_sugar = {co_rec_disc_iffs, co_rec_codes, co_rec_transfers, ...},
               ...} : fp_sugar) =
           {T = T, BT = T (*wrong but harmless*), X = X, fp = fp, fp_res = fp_res, fp_res_index = kk,
            pre_bnf = pre_bnf, absT_info = absT_info, fp_nesting_bnfs = fp_nesting_bnfs,
@@ -329,7 +329,9 @@
               co_rec_thms = co_rec_thms,
               co_rec_discs = co_rec_disc_thms,
               co_rec_disc_iffs = co_rec_disc_iffs,
-              co_rec_selss = co_rec_sel_thmss}}
+              co_rec_selss = co_rec_sel_thmss,
+              co_rec_codes = co_rec_codes,
+              co_rec_transfers = co_rec_transfers}}
           |> morph_fp_sugar phi;
 
         val target_fp_sugars =
--- a/src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML	Mon Oct 06 13:35:03 2014 +0200
+++ b/src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML	Mon Oct 06 13:35:15 2014 +0200
@@ -104,7 +104,9 @@
         co_rec_thms = @{thms sum.case},
         co_rec_discs = [],
         co_rec_disc_iffs = [],
-        co_rec_selss = []}}
+        co_rec_selss = [],
+        co_rec_codes = [],
+        co_rec_transfers = []}}
   end;
 
 fun fp_sugar_of_prod ctxt =
@@ -161,7 +163,9 @@
         co_rec_thms = @{thms prod.case},
         co_rec_discs = [],
         co_rec_disc_iffs = [],
-        co_rec_selss = []}}
+        co_rec_selss = [],
+        co_rec_codes = [],
+        co_rec_transfers = []}}
   end;
 
 val _ = Theory.setup (map_local_theory (fn lthy =>