flambda-backend: Make -error_size directly about length of printed error (#2700)

Author: riaqn

testsuite/tests/typing-modules/inclusion_errors_elision.ml

@@ -26,6 +26,46 @@ Lines 9-13, characters 15-3:
 11 |     type a and b and c and d and e and f and g and h
 12 |   end
 13 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           module B :
+             sig type a and b and c and d and e and f and g and h end
+         end
+       is not included in
+         S
+       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 C : S = struct
+  module B = struct
+    type a and b and c and d and e and f and g and h
+    and a_type_with_extremely_long_long_long_long_long_long_long_long_name
+    and a_type_with_extremely_long_long_long_long_long_long_long_long_name0
+  end
+end
+[%%expect {|
+Lines 1-7, characters 15-3:
+1 | ...............struct
+2 |   module B = struct
+3 |     type a and b and c and d and e and f and g and h
+4 |     and a_type_with_extremely_long_long_long_long_long_long_long_long_name
+5 |     and a_type_with_extremely_long_long_long_long_long_long_long_long_name0
+6 |   end
+7 | end
 Error: Signature mismatch:
        ...
        In module B:
@@ -39,6 +79,10 @@ Error: Signature mismatch:
            and f = B.f
            and g = B.g
            and h = B.h
+           and a_type_with_extremely_long_long_long_long_long_long_long_long_name =
+               B.a_type_with_extremely_long_long_long_long_long_long_long_long_name
+           and a_type_with_extremely_long_long_long_long_long_long_long_long_name0 =
+               B.a_type_with_extremely_long_long_long_long_long_long_long_long_name0
          end
        is not included in
          (module A)
@@ -72,6 +116,69 @@ Lines 11-17, characters 15-3:
 15 |     end
 16 |   end
 17 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           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
+       is not included in
+         S
+       Module type declarations do not match:
+         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
+       does not match
+         module type B = sig module C = A end
+       At position module type B = <here>
+       Module types do not match:
+         sig
+           module C :
+             sig type a and b and c and d and e and f and g and h end
+         end
+       is not equal to
+         sig module C = A end
+       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)
+|}]
+
+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
+      and a_type_with_extremely_long_long_long_long_long_long_long_long_name
+      and a_type_with_extremely_long_long_long_long_long_long_long_long_name0
+    end
+  end
+end
+[%%expect{|
+Lines 1-9, characters 15-3:
+1 | ...............struct
+2 |   module type B = sig
+3 |     module C: sig
+4 |       type a and b and c and d and e and f and g and h
+5 |       and a_type_with_extremely_long_long_long_long_long_long_long_long_name
+6 |       and a_type_with_extremely_long_long_long_long_long_long_long_long_name0
+7 |     end
+8 |   end
+9 | end
 Error: Signature mismatch:
        ...
        ...
@@ -87,6 +194,10 @@ Error: Signature mismatch:
            and f = C.f
            and g = C.g
            and h = C.h
+           and a_type_with_extremely_long_long_long_long_long_long_long_long_name =
+               C.a_type_with_extremely_long_long_long_long_long_long_long_long_name
+           and a_type_with_extremely_long_long_long_long_long_long_long_long_name0 =
+               C.a_type_with_extremely_long_long_long_long_long_long_long_long_name0
          end
        is not included in
          (module A)

testsuite/tests/typing-objects-bugs/pr4824a_bad.compilers.reference

@@ -2,7 +2,10 @@ File "pr4824a_bad.ml", line 10, characters 2-45:
 10 |   struct class c x = object val x = x end end
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       ...
+       Modules do not match:
+         sig class c : 'a -> object val x : 'a end end
+       is not included in
+         sig class c : 'a -> object val x : 'b end end
        Class declarations do not match:
          class c : 'a -> object val x : 'a end
        does not match

testsuite/tests/typing-sigsubst/test_locations.compilers.reference

@@ -2,7 +2,14 @@ File "test_loc_type_eq.ml", line 1, characters 49-76:
 1 | module M : Test_functor.S with type elt = unit = Test_functor.Apply (String)
                                                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       ...
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         sig type elt = unit type t val create : elt -> t end
        Type declarations do not match:
          type elt = String.t
        is not included in
@@ -35,7 +42,14 @@ File "test_loc_type_subst.ml", line 1, characters 50-77:
 1 | module M : Test_functor.S with type elt := unit = Test_functor.Apply (String)
                                                       ^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       ...
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         sig type t val create : unit -> t end
        Values do not match:
          val create : elt -> t
        is not included in

typing/includemod_errorprinter.ml

@@ -182,15 +182,9 @@ end
 
 module Err = Includemod.Error
 
-let buffer = ref Bytes.empty
-let is_big obj =
+let is_big p =
   let size = !Clflags.error_size in
-  size > 0 &&
-  begin
-    if Bytes.length !buffer < size then buffer := Bytes.create size;
-    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
-    with _ -> true
-  end
+  size > 0 && Misc.is_print_longer_than size p
 
 let show_loc msg ppf loc =
   let pos = loc.Location.loc_start in
@@ -575,11 +569,11 @@ let with_context ?loc ctx printer diff =
 let dwith_context ?loc ctx printer =
   Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer
 
-let dwith_context_and_elision ?loc ctx printer diff =
-  if is_big (diff.got,diff.expected) then
+let dwith_context_and_elision ?loc ctx print_diff =
+  if is_big print_diff then
     Location.msg ?loc "..."
   else
-    dwith_context ?loc ctx (printer diff)
+    dwith_context ?loc ctx print_diff
 
 (* Merge sub msgs into one printer *)
 let coalesce msgs =
@@ -750,7 +744,7 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff =
                It is thus better to avoid eliding the current error message.
             *)
             dwith_context ctx (inner diff)
-        | _ -> dwith_context_and_elision 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
@@ -819,7 +813,7 @@ and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with
       module_type_decl ~expansion_token ~env ~before ~ctx name diff
 and module_type_decl ~expansion_token ~env ~before ~ctx id diff =
   let next =
-    dwith_context_and_elision ctx (module_type_declarations id) diff in
+    dwith_context_and_elision ctx (module_type_declarations id diff) in
   let before = next :: before in
   match diff.symptom with
   | Not_less_than mts ->

utils/clflags.ml

@@ -110,7 +110,7 @@ and no_auto_link = ref false            (* -noautolink *)
 and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
-and error_size = ref 500                (* -error-size *)
+and error_size = ref 256                (* -error-size *)
 and float_const_prop = ref true         (* -no-float-const-prop *)
 and transparent_modules = ref false     (* -trans-mod *)
 let unique_ids = ref true               (* -d(no-)unique-ds *)

utils/misc.ml

@@ -1099,6 +1099,28 @@ let output_of_print print =
   in
   output
 
+let is_print_longer_than size p =
+  let exception Limit_exceeded in
+  let limit = ref size in
+  let count_down len =
+    limit := !limit - len;
+    if !limit < 0 then raise Limit_exceeded
+  in
+  let out_string _ _ len = count_down len in
+  let out_newline () = count_down 1 in
+  let out_spaces n = count_down n in
+  let out_flush _ = () in
+  let out_indent _ = () in
+  let out_functions : Format.formatter_out_functions = {
+    out_string;
+    out_flush;
+    out_newline;
+    out_spaces;
+    out_indent}
+  in
+  let ppf = Format.formatter_of_out_functions out_functions in
+  try p ppf; false
+  with Limit_exceeded -> true
 
 type filepath = string
 

utils/misc.mli

@@ -630,6 +630,10 @@ val output_of_print :
     Note that naively using [Format.formatter_of_out_channel] typechecks but
     doesn't work because it fails to flush the formatter. *)
 
+val is_print_longer_than: int -> (Format.formatter -> unit) -> bool
+(** Returns [true] if the printed string is longer than the given integer. Stops
+    early if so. Spaces and newlines are counted, but indentation is not. *)
+
 (** {1 Displaying configuration variables} *)
 
 val show_config_and_exit : unit -> unit