Compare every runtime shape claim of an interface in one place

Interface inclusion compared classes and kinds in Includecore and
@notundefined in Includemod, the two levels of one declared shape.
Includecore.compare_runtime_annotations now checks both; the messages are
unchanged.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t
Signed-off-by: Christoph Knittel <ck@cca.io>

Author: cknitt

compiler/ml/UntaggedVariants.md

@@ -501,7 +501,7 @@ for functor arguments and `with type` constraints.
   `ast_untagged_variants.ml:has_not_undefined`;
   `variant_layout.ml:declaration_shape`;
   `typeopt.ml:type_cannot_contain_undefined`;
-  `includemod.ml:not_undefined_mismatch`.
+  `includecore.ml:compare_runtime_annotations`.
 - Tests: `spec_test` rule 13; fixtures `invalid_attribute_not_undefined.res`,
   `not_undefined_functor_argument.res`, `not_undefined_functor_parameter.res`;
   `tests/tests/src/not_undefined_interface_test.res`,

compiler/ml/includecore.ml

@@ -345,13 +345,25 @@ and compare_records env params1_ params2_ n_
   in
   aux ~fast:true params1_ params2_ n_ labels1_ labels2_
 
-(* Values are recognized by the class or [typeof] the second declaration
-   states, so the first must state the same. Stating nothing hides it. *)
-let compare_runtime_annotations env decl1 decl2 =
+(* What the second declaration states about its values at run time must
+   hold for the first. Values are recognized by the class or [typeof] the
+   second states, so the first must state the same; stating nothing hides it.
+   [@notUndefined] lets clients unbox [option] of the type, so the first must
+   be a type that cannot hold [undefined] either, or one whose representation
+   the compiler does not see, which has none that contradicts it. *)
+let compare_runtime_annotations env id decl1 decl2 =
   (* The second declaration's shape was resolved in its own environment, so
      it is what users of the second declaration see *)
   match decl2.type_shape with
-  | Unstated | Never_undefined -> []
+  | Unstated -> []
+  | Never_undefined -> (
+    let env = Env.add_type ~check:false id decl1 env in
+    let ty =
+      Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil))
+    in
+    match Typeopt.undefinedness env ty with
+    | Cannot_be_undefined | Unseen -> []
+    | Stands_for_another | Can_be_undefined -> [Not_undefined])
   | Recognized_as block_type2 ->
     let declared2 = Some block_type2 in
     let declared1 =
@@ -395,7 +407,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
         else [Constraint]
     in
     let err =
-      if err <> [] then err else compare_runtime_annotations env decl1 decl2
+      if err <> [] then err else compare_runtime_annotations env id decl1 decl2
     in
     if err <> [] then err
     else

compiler/ml/includemod.ml

@@ -62,32 +62,12 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 =
 
 (* Inclusion between type declarations *)
 
-(* [@notUndefined] lets clients unbox [option] of the type, so the
-   implementation must be a type that cannot hold [undefined] either, or one
-   whose representation the compiler does not see, which has none that
-   contradicts it. *)
-let not_undefined_mismatch env id (decl1 : Types.type_declaration)
-    (decl2 : Types.type_declaration) =
-  match decl2.type_shape with
-  | Unstated | Recognized_as _ -> []
-  | Never_undefined -> (
-    let env = Env.add_type ~check:false id decl1 env in
-    let ty =
-      Btype.newgenty (Tconstr (Pident id, decl1.type_params, ref Mnil))
-    in
-    match Typeopt.undefinedness env ty with
-    | Cannot_be_undefined | Unseen -> []
-    | Stands_for_another | Can_be_undefined -> [Includecore.Not_undefined])
-
 let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 =
   Env.mark_type_used env (Ident.name id) decl1;
   let decl2 = Subst.type_declaration subst decl2 in
   let err =
     Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2
   in
-  let err =
-    if err <> [] then err else not_undefined_mismatch env id decl1 decl2
-  in
   if err <> [] then
     raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))])