155 lines
4.5 KiB
Diff
155 lines
4.5 KiB
Diff
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
|
|
|