fix(ocamlc_loc): extended excerpts

CHANGES.md

@@ -1,6 +1,9 @@
 Unreleased
 ----------
 
+- Fix parsing of OCaml errors that contain code excerpts with `...` in them.
+  (#7008, @rgrinberg)
+
 - Pre-emptively clear screen in watch mode (#6987, fixes #6884, @rgrinberg)
 
 - Fix cross compilation configuration when a context with targets is itself a

otherlibs/ocamlc_loc/src/lexer.mli

@@ -43,6 +43,8 @@ type token =
 
 val severity : Lexing.lexbuf -> (severity * string) option
 
-val skip_excerpt : Lexing.lexbuf -> [ `Stop | `Continue ]
+val skip_excerpt_head : Lexing.lexbuf -> [ `Stop | `Continue ]
+
+val skip_excerpt_tail : Lexing.lexbuf -> [ `Stop | `Continue ]
 
 val token : Lexing.lexbuf -> token

otherlibs/ocamlc_loc/src/lexer.mll

@@ -53,7 +53,14 @@ let any = _ *
 
 let alert_name = ['a' - 'z'] ['A' - 'Z' 'a' - 'z' '0' - '9' '_']*
 
-rule skip_excerpt = parse
+rule skip_excerpt_head = parse
+  | blank digits " | " [^ '\n']* [ '.' ]* "\n"?
+    { `Continue }
+  | eof { `Stop }
+  | "" { `Stop }
+
+and skip_excerpt_tail = parse 
+  | "..." '\r'? '\n'? { `Continue }
   | blank digits " | " [^ '\n']* "\n"?
     { `Continue }
   | blank '^'+ blank "\n"?

otherlibs/ocamlc_loc/src/ocamlc_loc.ml

@@ -108,15 +108,20 @@ let severity tokens =
       severity)
   | _ -> raise Unknown_format
 
-let rec skip_excerpt tokens =
-  match Tokens.peek tokens with
-  | Line { contents; indent = _ } -> (
-    match Lexer.skip_excerpt (Lexing.from_string contents) with
-    | `Continue ->
-      Tokens.junk tokens;
-      skip_excerpt tokens
-    | `Stop -> ())
-  | _ -> ()
+let skip_excerpt =
+  let make_skip_excerpt tokens self lex =
+    match Tokens.peek tokens with
+    | Line { contents; indent = _ } -> (
+      match lex (Lexing.from_string contents) with
+      | `Continue ->
+        Tokens.junk tokens;
+        self tokens
+      | `Stop -> ())
+    | _ -> ()
+  in
+  let rec tail tokens = make_skip_excerpt tokens tail Lexer.skip_excerpt_tail in
+  let head tokens = make_skip_excerpt tokens tail Lexer.skip_excerpt_head in
+  head
 
 let rec acc_message tokens min_indent acc =
   match Tokens.peek tokens with

otherlibs/ocamlc_loc/test/ocamlc_loc_tests.ml

@@ -487,61 +487,114 @@ testing
 let%expect_test "nultiple errors from multiple files at once" =
   test_error
     {|
-  File "src/dune_engine/action.ml", lines 34-96, characters 4-64:
-  34 | ....function
-  35 |     | Run (a, xs) -> List (atom "run" :: program a :: List.map xs ~f:string)
-  36 |     | With_accepted_exit_codes (pred, t) ->
-  37 |       List
-  38 |         [ atom "with-accepted-exit-codes"
-  ...
-  93 |       List
-  94 |         (atom (sprintf "pipe-%s" (Outputs.to_string outputs))
-  95 |         :: List.map l ~f:encode)
-  96 |     | Extension ext -> List [ atom "ext"; Extension.encode ext ]
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  Case
-  File "src/dune_engine/action.ml", lines 291-315, characters 2-22:
-  291 | ..match t with
-  292 |   | Chdir (_, t)
-  293 |   | Setenv (_, _, t)
-  294 |   | Redirect_out (_, _, _, t)
-  295 |   | Redirect_in (_, _, t)
-  ...
-  312 |   | Mkdir _
-  313 |   | Diff _
-  314 |   | Merge_files_into _
-  315 |   | Extension _ -> acc
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  Case
-  File "src/dune_engine/action.ml", lines 339-363, characters 21-24:
-  339 | .....................function
-  340 |   | Dynamic_run _ -> true
-  341 |   | Chdir (_, t)
-  342 |   | Setenv (_, _, t)
-  343 |   | Redirect_out (_, _, _, t)
-  ...
-  360 |   | Diff _
-  361 |   | Mkdir _
-  362 |   | Merge_files_into _
-  363 |   | Extension _ -> false
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  Case
-  File "src/dune_engine/action.ml", lines 391-414, characters 4-70:
-  391 | ....match t with
-  392 |     | Chdir (_, t) -> loop t
-  393 |     | Setenv (_, _, t) -> loop t
-  394 |     | Redirect_out (_, _, _, t) -> memoize || loop t
-  395 |     | Redirect_in (_, _, t) -> loop t
-  ...
-  411 |     | Dynamic_run _ -> true
-  412 |     | System _ -> true
-  413 |     | Bash _ -> true
-  414 |     | Extension (module A) -> A.Spec.is_useful_to ~distribute ~memoize
-  Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
-  Here is an example of a case that is not matched:
-  Case
+File "src/dune_engine/action.ml", lines 34-96, characters 4-64:
+34 | ....function
+35 |     | Run (a, xs) -> List (atom "run" :: program a :: List.map xs ~f:string)
+36 |     | With_accepted_exit_codes (pred, t) ->
+37 |       List
+38 |         [ atom "with-accepted-exit-codes"
+...
+93 |       List
+94 |         (atom (sprintf "pipe-%s" (Outputs.to_string outputs))
+95 |         :: List.map l ~f:encode)
+96 |     | Extension ext -> List [ atom "ext"; Extension.encode ext ]
+Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Case
+File "src/dune_engine/action.ml", lines 291-315, characters 2-22:
+291 | ..match t with
+292 |   | Chdir (_, t)
+293 |   | Setenv (_, _, t)
+294 |   | Redirect_out (_, _, _, t)
+295 |   | Redirect_in (_, _, t)
+...
+312 |   | Mkdir _
+313 |   | Diff _
+314 |   | Merge_files_into _
+315 |   | Extension _ -> acc
+Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Case
+File "src/dune_engine/action.ml", lines 339-363, characters 21-24:
+339 | .....................function
+340 |   | Dynamic_run _ -> true
+341 |   | Chdir (_, t)
+342 |   | Setenv (_, _, t)
+343 |   | Redirect_out (_, _, _, t)
+...
+360 |   | Diff _
+361 |   | Mkdir _
+362 |   | Merge_files_into _
+363 |   | Extension _ -> false
+Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Case
+File "src/dune_engine/action.ml", lines 391-414, characters 4-70:
+391 | ....match t with
+392 |     | Chdir (_, t) -> loop t
+393 |     | Setenv (_, _, t) -> loop t
+394 |     | Redirect_out (_, _, _, t) -> memoize || loop t
+395 |     | Redirect_in (_, _, t) -> loop t
+...
+411 |     | Dynamic_run _ -> true
+412 |     | System _ -> true
+413 |     | Bash _ -> true
+414 |     | Extension (module A) -> A.Spec.is_useful_to ~distribute ~memoize
+Error (warning 8 [partial-match]): this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Case
   |};
-  [%expect {| |}]
+  [%expect
+    {|
+    >> error 0
+    { loc =
+        { path = "src/dune_engine/action.ml"
+        ; line = Range 34,96
+        ; chars = Some (4, 64)
+        }
+    ; message =
+        "this pattern-matching is not exhaustive.\n\
+         Here is an example of a case that is not matched:\n\
+         Case"
+    ; related = []
+    ; severity = Error Some { code = 8; name = "partial-match" }
+    }
+    >> error 1
+    { loc =
+        { path = "src/dune_engine/action.ml"
+        ; line = Range 291,315
+        ; chars = Some (2, 22)
+        }
+    ; message =
+        "this pattern-matching is not exhaustive.\n\
+         Here is an example of a case that is not matched:\n\
+         Case"
+    ; related = []
+    ; severity = Error Some { code = 8; name = "partial-match" }
+    }
+    >> error 2
+    { loc =
+        { path = "src/dune_engine/action.ml"
+        ; line = Range 339,363
+        ; chars = Some (21, 24)
+        }
+    ; message =
+        "this pattern-matching is not exhaustive.\n\
+         Here is an example of a case that is not matched:\n\
+         Case"
+    ; related = []
+    ; severity = Error Some { code = 8; name = "partial-match" }
+    }
+    >> error 3
+    { loc =
+        { path = "src/dune_engine/action.ml"
+        ; line = Range 391,414
+        ; chars = Some (4, 70)
+        }
+    ; message =
+        "this pattern-matching is not exhaustive.\n\
+         Here is an example of a case that is not matched:\n\
+         Case"
+    ; related = []
+    ; severity = Error Some { code = 8; name = "partial-match" }
+    } |}]