From 8db0b4a6b911ce080dc1e3747bc7feed17380f3a Mon Sep 17 00:00:00 2001
From: Gabriel Scherer <gabriel.scherer@gmail.com>
Date: Sun, 25 Feb 2024 09:05:56 +0100
Subject: [PATCH] error messages: reopen input files when given binary AST

We recently simplified the compiler logic to quote source file
fragments, by keeping the whole input file in memory instead of
reopening the input file when the error lies outside the lexing
buffer. This fixes issue with source files that contain preprocessor
directives (typically, they are the output of a source-to-source
preprocessor).

This simplification is a regression for build systems like Dune that
perform a source-to-AST preprocessing step, then call the compiler
with the binary AST as input: in this case there is no source input file in
memory when printing errors, so source quotations are gone.

The present commit restores the fallback logic that we had in 5.1 and
earlier to apply in this case, when given AST as input.

(cherry picked from commit 2331a2556663e83c4439f1fb63091422fef2d93b)
---
 parsing/location.ml | 32 ++++++++++++++++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

diff --git a/parsing/location.ml b/parsing/location.ml
index d51a7f03b43f..bbad99480f41 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -578,6 +578,24 @@ let lines_around
   loop ();
   List.rev !lines
 
+(* Get lines from a file *)
+let lines_around_from_file
+    ~(start_pos: position) ~(end_pos: position)
+    (filename: string):
+  input_line list
+  =
+  try
+    let cin = open_in_bin filename in
+    let read_char () =
+      try Some (input_char cin) with End_of_file -> None
+    in
+    let lines =
+      lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char
+    in
+    close_in cin;
+    lines
+  with Sys_error _ -> []
+
 (* Attempt to get lines from the lexing buffer. *)
 let lines_around_from_lexbuf
     ~(start_pos: position) ~(end_pos: position)
@@ -627,8 +645,18 @@ let lines_around_from_current_input ~start_pos ~end_pos =
       lines_around_from_phrasebuf pb ~start_pos ~end_pos
   | Some lb, _, _ ->
       lines_around_from_lexbuf lb ~start_pos ~end_pos
-  | None, _, _ ->
-      []
+  | None, _, filename ->
+      (* A situation where we have no input buffer and no phrase buffer
+         is when the compiler is getting the binary AST directly as input. *)
+      (* Be a bit defensive, and do not try to open one of the possible
+         [!input_name] values that we know do not denote valid filenames. *)
+      let file_valid = match filename with
+        | "//toplevel//" | "_none_" | "" -> false
+        | _ -> true
+      in
+      if file_valid
+      then lines_around_from_file filename ~start_pos ~end_pos
+      else []
 
 (******************************************************************************)
 (* Reporting errors and warnings *)