src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
changeset 54282 32b5c4821d9d
parent 54280 23c0049e7c40
child 54283 6f0a49ed1bb1
equal deleted inserted replaced
54281:b01057e72233 54282:32b5c4821d9d
   290     val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
   290     val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
   291 
   291 
   292     val perm_actual_Ts as Type (_, tyargs0) :: _ =
   292     val perm_actual_Ts as Type (_, tyargs0) :: _ =
   293       sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
   293       sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
   294 
   294 
       
   295     fun the_fp_sugar_of (T as Type (T_name, _)) =
       
   296       (case fp_sugar_of lthy T_name of
       
   297         SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
       
   298       | NONE => not_co_datatype T);
       
   299 
   295     fun check_enrich_with_mutuals _ [] = []
   300     fun check_enrich_with_mutuals _ [] = []
   296       | check_enrich_with_mutuals seen ((T as Type (T_name, tyargs)) :: Ts) =
   301       | check_enrich_with_mutuals seen ((T as Type (_, tyargs)) :: Ts) =
   297         (case fp_sugar_of lthy T_name of
   302         let
   298           SOME ({fp = fp', fp_res = {Ts = Ts', ...}, ...}) =>
   303           val {fp_res = {Ts = Ts', ...}, ...} = the_fp_sugar_of T
   299           if fp = fp' then
   304           val mutual_Ts = map (fn Type (s, _) => Type (s, tyargs)) Ts';
   300             let
   305           val (seen', Ts') = List.partition (member (op =) mutual_Ts) Ts;
   301               val mutual_Ts = map (fn Type (s, _) => Type (s, tyargs)) Ts';
   306         in
   302               val (seen', Ts') = List.partition (member (op =) mutual_Ts) Ts;
   307           mutual_Ts @ check_enrich_with_mutuals (seen @ T :: seen') Ts'
   303             in
   308         end
   304               mutual_Ts @ check_enrich_with_mutuals (seen @ T :: seen') Ts'
       
   305             end
       
   306           else
       
   307             not_co_datatype T
       
   308         | NONE => not_co_datatype T)
       
   309       | check_enrich_with_mutuals _ (T :: _) = not_co_datatype T;
   309       | check_enrich_with_mutuals _ (T :: _) = not_co_datatype T;
   310 
   310 
   311     val perm_Ts = check_enrich_with_mutuals [] perm_actual_Ts;
   311     val perm_Ts = check_enrich_with_mutuals [] perm_actual_Ts;
   312     val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
   312     val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
   313     val Ts = actual_Ts @ missing_Ts;
   313     val Ts = actual_Ts @ missing_Ts;