Fix source highlighting for long toplevel phrases (#7925) (#8611)

Fix #7925: error messages for long toplevel inputs would have dummy locations

Changes

@@ -438,6 +438,10 @@ OCaml 4.09.0
    Thomas Refis, Armaël Guéneau, Gabriel Scherer, David Allsopp)
 - #3249: ocamlmklib should reject .cmxa files
   (Xavier Leroy)
+- #7925, #8611: fix error highlighting for exceptionally
+  long toplevel phrases
+  (Kyle Miller, reported by Armaël Guéneau, review by Armaël Guéneau
+   and Nicolás Ojeda Bär)
 - #7937, #2287: fix uncaught Unify exception when looking for type
   declaration
   (Florian Angeletti, review by Jacques Garrigue)

parsing/location.ml

@@ -82,6 +82,7 @@ let mknoloc txt = mkloc txt none
 
 let input_name = ref "_none_"
 let input_lexbuf = ref (None : lexbuf option)
+let input_phrase_buffer = ref (None : Buffer.t option)
 
 (******************************************************************************)
 (* Terminal info *)
@@ -546,6 +547,23 @@ let lines_around_from_lexbuf
     lines_around ~start_pos ~end_pos ~seek ~read_char
   end
 
+(* Attempt to get lines from the phrase buffer *)
+let lines_around_from_phrasebuf
+    ~(start_pos: position) ~(end_pos: position)
+    (pb: Buffer.t):
+  input_line list
+  =
+  let pos = ref 0 in
+  let seek n = pos := n in
+  let read_char () =
+    if !pos >= Buffer.length pb then None
+    else begin
+      let c = Buffer.nth pb !pos in
+      incr pos; Some c
+    end
+  in
+  lines_around ~start_pos ~end_pos ~seek ~read_char
+
 (* Get lines from a file *)
 let lines_around_from_file
     ~(start_pos: position) ~(end_pos: position)
@@ -583,15 +601,22 @@ let lines_around_from_current_input ~start_pos ~end_pos =
     else
       []
   in
-  match !input_lexbuf with
-  | Some lb ->
+  match !input_lexbuf, !input_phrase_buffer, !input_name with
+  | _, Some pb, "//toplevel//" ->
+      begin match lines_around_from_phrasebuf pb ~start_pos ~end_pos with
+      | [] -> (* Couldn't get input from phrase buffer, raise an error *)
+          assert false
+      | lines ->
+          lines
+      end
+  | Some lb, _, _ ->
       begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with
       | [] -> (* The input is likely not in the lexbuf anymore *)
           from_file ()
       | lines ->
           lines
       end
-  | None ->
+  | None, _, _ ->
       from_file ()
 
 (******************************************************************************)

parsing/location.mli

@@ -73,6 +73,11 @@ val mkloc : 'a -> t -> 'a loc
 
 val input_name: string ref
 val input_lexbuf: Lexing.lexbuf option ref
+(* Used by the Error Reporting Code if [!input_name] is
+   //toplevel// [!input_phrase_buffer] is Some buf
+   where buf is the last toplevel phrase and otherwise
+   [!input_phrase_buffer] is None *)
+val input_phrase_buffer: Buffer.t option ref
 
 
 (** {1 Toplevel-specific functions} *)

testsuite/tests/tool-toplevel/error_highlighting.compilers.reference

@@ -39,6 +39,11 @@ Lines 2-4, characters 8-2:
 4 | 2)...
 Error: This expression has type int but an expression was expected of type
          float
+Line 2, characters 12-17:
+2 | let x = 1 + "abc" in
+                ^^^^^
+Error: This expression has type string but an expression was expected of type
+         int
 File "error_highlighting_use1.ml", line 1, characters 8-15:
 1 | let x = (1 + 2) +. 3. in ();;
             ^^^^^^^

testsuite/tests/tool-toplevel/error_highlighting.ml

@@ -26,6 +26,85 @@ let x = (1
 2) +.
 3. in ();;
 
+let x = 1 + "abc" in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in
+let x = 1 in ();;
+
 #use "error_highlighting_use1.ml";;
 #use "error_highlighting_use2.ml";;
 #use "error_highlighting_use3.ml";;

testsuite/tests/tool-toplevel/pr6468.compilers.reference

@@ -8,5 +8,5 @@ val g : unit -> int = <fun>
 Exception: Not_found.
 Raised at file "//toplevel//", line 2, characters 17-26
 Called from file "//toplevel//", line 1, characters 11-15
-Called from file "toplevel/toploop.ml", line 208, characters 17-27
+Called from file "toplevel/toploop.ml", line 211, characters 17-27
 

toplevel/toploop.ml

@@ -36,6 +36,9 @@ type directive_info = {
   doc: string;
 }
 
+(* Phase Buffer that Stores the Last Toplevel Phrase *)
+let phrase_buffer = Buffer.create 1024
+
 (* The table of toplevel value bindings and its accessors *)
 
 let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty
@@ -447,6 +450,8 @@ let read_input_default prompt buffer len =
       if !i >= len then raise Exit;
       let c = input_char stdin in
       Bytes.set buffer !i c;
+      (* Populate Phrase Buffer as new characters are added *)
+      Buffer.add_char phrase_buffer c;
       incr i;
       if c = '\n' then raise Exit;
     done;
@@ -544,6 +549,7 @@ let loop ppf =
   Location.init lb "//toplevel//";
   Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
+  Location.input_phrase_buffer := Some phrase_buffer;
   Sys.catch_break true;
   run_hooks After_setup;
   load_ocamlinit ppf;
@@ -551,6 +557,8 @@ let loop ppf =
     let snap = Btype.snapshot () in
     try
       Lexing.flush_input lb;
+      (* Reset the phrase buffer when we flush the lexing buffer *)
+      Buffer.reset phrase_buffer;
       Location.reset();
       Warnings.reset_fatal ();
       first_line := true;