ocaml/0015-Do-not-elide-the-whole-module-type-error-message-114.patch

From 54eef17aeecfdbc6eeecd60b9cc64cd7c0129429 Mon Sep 17 00:00:00 2001
From: Florian Angeletti <florian.angeletti@inria.fr>
Date: Wed, 20 Jul 2022 10:58:18 +0200
Subject: [PATCH 15/24] Do not elide the whole module type error message
 (#11416)

(cherry picked from commit 8218be9e2b24907b8558776a34d12032bcc42496)
---
 Changes                                       |  5 +-
 .../inclusion_errors_elision.ml               | 93 +++++++++++++++++++
 typing/includemod_errorprinter.ml             | 11 ++-
 3 files changed, 107 insertions(+), 2 deletions(-)
 create mode 100644 testsuite/tests/typing-modules/inclusion_errors_elision.ml

diff --git a/Changes b/Changes
index a9a9ee92f4..6b9855f707 100644
--- a/Changes
+++ b/Changes
@@ -14,7 +14,10 @@ OCaml 4.14 maintenance branch
   (David Allsopp and Nicolás Ojeda Bär, review by Nicolás Ojeda Bär and
    Sebastien Hinderer)
 
-- #11358, #11378: Refactor the initialization of bytecode threading.
+- #11314, #11416: fix non-informative error message for module inclusion
+  (Florian Angeletti, report by Thierry Martinez, review by Gabriel Scherer)
+
+- #11358, #11379: Refactor the initialization of bytecode threading,
   This avoids a "dangling pointer" warning of GCC 12.1.
   (Xavier Leroy, report by Armaël Guéneau, review by Gabriel Scherer)
 
diff --git a/testsuite/tests/typing-modules/inclusion_errors_elision.ml b/testsuite/tests/typing-modules/inclusion_errors_elision.ml
new file mode 100644
index 0000000000..3dbd0e67ff
--- /dev/null
+++ b/testsuite/tests/typing-modules/inclusion_errors_elision.ml
@@ -0,0 +1,93 @@
+(* TEST
+   flags ="-keep-original-error-size"
+   * expect
+  *)
+
+
+module A = struct
+  type a and b and c and d
+end
+
+module type S = sig
+  module B = A
+end
+
+module C : S = struct
+  module B = struct
+    type a and b and c and d and e and f and g and h
+  end
+end
+[%%expect {|
+module A : sig type a and b and c and d end
+module type S = sig module B = A end
+Lines 9-13, characters 15-3:
+ 9 | ...............struct
+10 |   module B = struct
+11 |     type a and b and c and d and e and f and g and h
+12 |   end
+13 | end
+Error: Signature mismatch:
+       ...
+       In module B:
+       Modules do not match:
+         sig
+           type a = B.a
+           and b = B.b
+           and c = B.c
+           and d = B.d
+           and e = B.e
+           and f = B.f
+           and g = B.g
+           and h = B.h
+         end
+       is not included in
+         (module A)
+|}]
+
+module A = struct
+  type a and b and c and d
+end
+
+module type S = sig
+  module type B = sig
+    module C = A
+  end
+end
+
+module D : S = struct
+  module type B = sig
+    module C: sig
+      type a and b and c and d and e and f and g and h
+    end
+  end
+end
+[%%expect{|
+module A : sig type a and b and c and d end
+module type S = sig module type B = sig module C = A end end
+Lines 11-17, characters 15-3:
+11 | ...............struct
+12 |   module type B = sig
+13 |     module C: sig
+14 |       type a and b and c and d and e and f and g and h
+15 |     end
+16 |   end
+17 | end
+Error: Signature mismatch:
+       ...
+       ...
+       ...
+       At position module type B = sig module C : <here> end
+       Modules do not match:
+         sig
+           type a = C.a
+           and b = C.b
+           and c = C.c
+           and d = C.d
+           and e = C.e
+           and f = C.f
+           and g = C.g
+           and h = C.h
+         end
+       is not included in
+         (module A)
+|}]
diff --git a/typing/includemod_errorprinter.ml b/typing/includemod_errorprinter.ml
index 24d452fddc..b719e1627d 100644
--- a/typing/includemod_errorprinter.ml
+++ b/typing/includemod_errorprinter.ml
@@ -709,7 +709,16 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff =
       functor_params ~expansion_token ~env ~before ~ctx d
   | _ ->
       let inner = if eqmode then eq_module_types else module_types in
-      let next = dwith_context_and_elision ctx inner diff in
+      let next =
+        match diff.symptom with
+        | Mt_core _ ->
+            (* In those cases, the refined error messages for the current error
+               will at most add some minor comments on the current error.
+               It is thus better to avoid eliding the current error message.
+            *)
+            dwith_context ctx (inner diff)
+        | _ -> dwith_context_and_elision ctx inner diff
+      in
       let before = next :: before in
       module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
         diff.symptom
-- 
2.37.0.rc2