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; |