unikernel/duniverse/dune_/otherlibs/ocamlc-loc/src/dune

@@ -0,0 +1,6 @@
+(library
+ (name ocamlc_loc)
+ (public_name ocamlc-loc)
+ (libraries dyn))
+
+(ocamllex lexer)

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/src/lexer.mli

@@ -0,0 +1,47 @@
+exception Unknown_format
+
+type lines =
+  | Single of int
+  | Range of int * int
+
+type code =
+  { code : int
+  ; name : string
+  }
+
+type source =
+  | Code of code
+  | Alert of string
+
+type severity =
+  | Error of source option
+  | Warning of code
+  | Alert of
+      { name : string
+      ; source : string
+      }
+
+type loc =
+  { chars : (int * int) option
+  ; lines : lines
+  ; path : string
+  }
+
+type line =
+  { indent : int
+  ; contents : string
+  }
+
+type token =
+  | Loc of
+      { indent : int
+      ; loc : loc
+      ; message : string
+      }
+  | Line of line
+  | Eof
+
+val severity : Lexing.lexbuf -> (severity * string) option
+val skip_excerpt_head : Lexing.lexbuf -> [ `Stop | `Continue ]
+val skip_excerpt_tail : Lexing.lexbuf -> [ `Stop | `Continue ]
+val token : Lexing.lexbuf -> token

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/src/lexer.mll

@@ -0,0 +1,131 @@
+{
+  (* raise when the format is unrecognized *)
+  exception Unknown_format
+
+  type lines =
+    | Single of int
+    | Range of int * int
+
+  type code =
+    { code : int
+    ; name : string
+    }
+
+  type source =
+    | Code of code
+    | Alert of string
+
+  type severity =
+    | Error of source option
+    | Warning of code
+    | Alert of { name : string ; source : string }
+
+  type loc =
+    { chars : (int * int) option
+    ; lines : lines
+    ; path : string
+    }
+
+  type line = { indent : int ; contents : string }
+
+  type token =
+    | Loc of { indent : int ; loc : loc ; message : string }
+    | Line of line
+    | Eof
+
+  let parse_range s =
+    match String.split_on_char '-' s with
+    | [x; y] -> (int_of_string x, int_of_string y)
+    | _ -> assert false
+}
+
+let blank = [' ' '\t' '\r']*
+
+let newline = '\n'
+
+let quoted_string = '"' [^ '"']+ '"'
+
+let digits = ['0' - '9']+
+
+let range = digits "-" digits
+
+let any = _ *
+
+let alert_name = ['a' - 'z'] ['A' - 'Z' 'a' - 'z' '0' - '9' '_']*
+
+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"?
+    { `Continue }
+  | eof { `Stop }
+  | "" { `Stop }
+
+and severity = parse
+  | "Error:"
+    (blank any as rest)
+    { Some (Error None, rest) }
+  | "Warning" blank (digits as code) blank "[" ([^ ']']+ as name) "]:"
+    (blank any as rest)
+    { Some (Warning { code = int_of_string code ; name }, rest)
+    }
+  | "Error" blank
+    "(warning" blank (digits as code) blank "[" ([^ ']']+ as name) "]):"
+    (blank any as rest)
+    { Some (Error (Some (Code { code = int_of_string code ; name })), rest)
+    }
+  | "Alert " blank (alert_name as name) ":" blank (any as source)
+    {  Some (Alert { name ; source }, "")
+    }
+  | (("Error" | "Warning") as kind) " (alert " ([^ ')']+ as alert) "):"
+    (blank any as rest)
+    { let res =
+        match kind with
+        | "Error" -> Error (Some (Alert alert))
+        | "Warning" -> Alert { name = alert ; source = "" }
+        | _ -> assert false
+      in
+      Some (res, rest)
+    }
+  | "" { None }
+
+and line = parse
+  | (blank as prefix) ([^ '\n']* as contents) blank newline?
+    { Line { indent = String.length prefix ; contents }
+    }
+  | eof { Eof }
+
+and token = parse
+  | (blank as indent) "File \"" ([^ '"']* as path) "\", " blank
+    (("line " (digits as line) | "lines " (range as lines)))
+    ("," blank "characters" blank (range as chars))?
+    ":" blank ([^ '\n']* as message) newline?
+    { let lines =
+        match line, lines with
+        | Some line, None -> Single (int_of_string line)
+        | None, Some range ->
+          let start, finish = (parse_range range) in
+          Range (start, finish)
+        | None, None
+        | Some _, Some _ -> assert false
+      in
+      let chars =
+        match chars with
+        | None -> None
+        | Some chars ->
+          let start, finish = parse_range chars in
+          Some (start, finish)
+      in
+      let indent = String.length indent in
+      let loc = { lines ; path ; chars } in
+      Loc { loc ; indent ; message }
+    }
+  | eof { Eof }
+  | "" { line lexbuf }

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/src/ocamlc_loc.ml

@@ -0,0 +1,209 @@
+include Lexer
+module List = ListLabels
+
+type report =
+  { loc : loc
+  ; severity : severity
+  ; message : string
+  ; related : (loc * string) list
+  }
+
+let dyn_of_code { code; name } =
+  let open Dyn in
+  record [ "code", int code; "name", string name ]
+;;
+
+let dyn_of_source =
+  let open Dyn in
+  function
+  | Code { code; name } -> record [ "code", int code; "name", string name ]
+  | Alert s -> string s
+;;
+
+let dyn_of_severity =
+  let open Dyn in
+  function
+  | Error w -> variant "Error" [ option dyn_of_source w ]
+  | Warning w -> variant "Warning" [ dyn_of_code w ]
+  | Alert { name; source } ->
+    variant "Alert" [ record [ "name", string name; "source", string source ] ]
+;;
+
+let dyn_of_loc { path; lines; chars } =
+  let open Dyn in
+  record
+    [ "path", string path
+    ; ( "line"
+      , match lines with
+        | Single i -> variant "Single" [ int i ]
+        | Range (i, j) -> variant "Range" [ int i; int j ] )
+    ; "chars", option (pair int int) chars
+    ]
+;;
+
+let dyn_of_report { loc; message; related; severity } =
+  let open Dyn in
+  record
+    [ "loc", dyn_of_loc loc
+    ; "message", string message
+    ; "related", list (pair dyn_of_loc string) related
+    ; "severity", dyn_of_severity severity
+    ]
+;;
+
+module Tokens : sig
+  type t
+
+  val create : Lexing.lexbuf -> t
+  val peek : t -> Lexer.token
+  val junk : t -> unit
+  val push : t -> Lexer.token -> unit
+  val next : t -> Lexer.token
+end = struct
+  type t =
+    { lexbuf : Lexing.lexbuf
+    ; mutable unread : Lexer.token list
+    }
+
+  let create lexbuf = { lexbuf; unread = [] }
+  let push t token = t.unread <- token :: t.unread
+
+  let next t =
+    match t.unread with
+    | [] -> Lexer.token t.lexbuf
+    | x :: xs ->
+      t.unread <- xs;
+      x
+  ;;
+
+  let peek t =
+    match t.unread with
+    | x :: _ -> x
+    | [] ->
+      let token = Lexer.token t.lexbuf in
+      t.unread <- [ token ];
+      token
+  ;;
+
+  let junk t =
+    match t.unread with
+    | _ :: xs -> t.unread <- xs
+    | _ -> ignore (Lexer.token t.lexbuf)
+  ;;
+end
+
+let indent_of_severity = function
+  | Error _ -> String.length "Error: "
+  | Warning _ -> String.length "Warning: "
+  | Alert { name; source } ->
+    String.length "Alert :" + String.length name + String.length source + 1
+;;
+
+let severity tokens =
+  match Tokens.peek tokens with
+  | Line { contents; indent } ->
+    (match Lexer.severity (Lexing.from_string contents) with
+     | None -> raise Unknown_format
+     | Some (severity, new_contents) ->
+       Tokens.junk tokens;
+       let indent = indent_of_severity severity + indent in
+       Tokens.push tokens (Line { indent; contents = new_contents });
+       severity)
+  | _ -> raise Unknown_format
+;;
+
+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
+  | Line line ->
+    Tokens.junk tokens;
+    let min_indent = min min_indent line.indent in
+    acc_message tokens min_indent (line :: acc)
+  | _ ->
+    List.rev_map acc ~f:(fun { indent; contents } ->
+      let prefix = String.make (indent - min_indent) ' ' in
+      prefix ^ contents)
+    |> String.concat "\n"
+    |> String.trim
+;;
+
+let rec related tokens acc =
+  match Tokens.peek tokens with
+  | Loc { indent; message; loc } ->
+    if indent = 0
+    then List.rev acc
+    else (
+      Tokens.junk tokens;
+      let message = acc_message tokens indent [ { indent; contents = message } ] in
+      let acc = (loc, message) :: acc in
+      related tokens acc)
+  | _ -> List.rev acc
+;;
+
+let toplevel tokens =
+  match Tokens.next tokens with
+  | Loc { indent; message; loc } ->
+    if indent > 0 then raise Unknown_format;
+    skip_excerpt tokens;
+    let severity = severity tokens in
+    let indent = indent + indent_of_severity severity in
+    let message = acc_message tokens indent [ { indent; contents = message } ] in
+    let related = related tokens [] in
+    { loc; severity; message; related }
+  | _ -> raise Unknown_format
+;;
+
+let parse s =
+  let lexbuf = Lexing.from_string s in
+  let tokens = Tokens.create lexbuf in
+  let rec loop acc =
+    match toplevel tokens with
+    | exception Unknown_format -> List.rev acc
+    | t -> loop (t :: acc)
+  in
+  loop []
+;;
+
+let dyn_of_raw =
+  Dyn.list (function
+    | `Loc loc -> dyn_of_loc loc
+    | `Message m -> Dyn.string m)
+;;
+
+let parse_raw s =
+  let lexbuf = Lexing.from_string s in
+  let tokens = Tokens.create lexbuf in
+  let rec loop acc =
+    match Tokens.peek tokens with
+    | Loc { loc; message; indent } ->
+      Tokens.junk tokens;
+      let acc = `Loc loc :: acc in
+      let message = acc_message tokens indent [ { contents = message; indent } ] in
+      let acc = `Message message :: acc in
+      loop acc
+    | Line line ->
+      Tokens.junk tokens;
+      let message = acc_message tokens line.indent [ line ] in
+      let acc = `Message message :: acc in
+      loop acc
+    | Eof ->
+      Tokens.junk tokens;
+      List.rev acc
+  in
+  loop []
+;;

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/src/ocamlc_loc.mli

@@ -0,0 +1,40 @@
+[@@@alert unstable "The API of this library is not stable and may change without notice."]
+
+type code =
+  { code : int
+  ; name : string
+  }
+
+type source =
+  | Code of code
+  | Alert of string
+
+type lines =
+  | Single of int
+  | Range of int * int
+
+type loc =
+  { chars : (int * int) option
+  ; lines : lines
+  ; path : string
+  }
+
+type severity =
+  | Error of source option
+  | Warning of code
+  | Alert of
+      { name : string
+      ; source : string
+      }
+
+type report =
+  { loc : loc
+  ; severity : severity
+  ; message : string
+  ; related : (loc * string) list
+  }
+
+val dyn_of_report : report -> Dyn.t
+val dyn_of_raw : [ `Loc of loc | `Message of string ] list -> Dyn.t
+val parse_raw : string -> [ `Loc of loc | `Message of string ] list
+val parse : string -> report list

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/test/dune

@@ -0,0 +1,13 @@
+(library
+ (name ocamlc_loc_tests)
+ (libraries
+  ocamlc_loc
+  stdune
+  ;; deps below required because (implicit_transitive_deps false)
+  ppx_expect.config
+  ppx_expect.config_types
+  base
+  ppx_inline_test.config)
+ (preprocess
+  (pps ppx_expect))
+ (inline_tests))

unikernel/duniverse/dune_/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml

@@ -0,0 +1,653 @@
+open Stdune
+
+let cmd fmt =
+  Printf.ksprintf
+    (fun s ->
+       let (_ : int) = Sys.command s in
+       ())
+    fmt
+;;
+
+module Test = struct
+  type t = { dir : Path.t }
+
+  let restore_cwd =
+    let cwd = Sys.getcwd () in
+    fun () -> Sys.chdir cwd
+  ;;
+
+  let file t ~fname ~contents =
+    let path = Path.relative t.dir fname in
+    Io.write_file path contents;
+    path
+  ;;
+
+  let print_errors =
+    List.iteri ~f:(fun i report ->
+      printfn ">> error %d" i;
+      print_endline (Dyn.to_string (Ocamlc_loc.dyn_of_report report)))
+  ;;
+
+  let create f =
+    let dir = Temp.create Dir ~prefix:"dune." ~suffix:".test" in
+    let t = { dir } in
+    Sys.chdir (Path.to_string dir);
+    let output =
+      let out_file = Exn.protect ~f:(fun () -> f t) ~finally:restore_cwd in
+      let output = Io.read_file out_file in
+      Format.asprintf "%a@." Pp.to_fmt (Ansi_color.parse output)
+    in
+    (* Format.eprintf "print raw output:@.%s@.%!" output; *)
+    Ocamlc_loc.parse output |> print_errors
+  ;;
+end
+
+(* FIXME: unused value warning isn't parsed correctly - the file excerpt isn't
+   extracted *)
+let%expect_test "unused value" =
+  let raw_error =
+    String.trim
+      {|
+File "test.ml", line 1, characters 4-7:
+1 | let foo = ()
+        ^^^
+Error (warning 32 [unused-value-declaration]): unused value foo.
+    |}
+  in
+  String.split_lines raw_error
+  |> String.concat ~sep:"\r\n"
+  |> Ocamlc_loc.parse
+  |> Test.print_errors;
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "test.ml"; line = Single 1; chars = Some (4, 7) }
+    ; message = "unused value foo."
+    ; related = []
+    ; severity = Error (Some { code = 32; name = "unused-value-declaration" })
+    } |}]
+;;
+
+let test_error raw_error = String.trim raw_error |> Ocamlc_loc.parse |> Test.print_errors
+
+let test_error_raw raw_error =
+  String.trim raw_error
+  |> Ocamlc_loc.parse_raw
+  |> Ocamlc_loc.dyn_of_raw
+  |> Dyn.to_string
+  |> print_endline
+;;
+
+let%expect_test "mli mismatch" =
+  test_error
+    {|
+File "test.ml", line 1:
+Error: The implementation test.ml does not match the interface test.cmi:
+       Values do not match: val x : bool is not included in val x : int
+       The type bool is not compatible with the type int
+       File "test.mli", line 1, characters 0-11: Expected declaration
+       File "test.ml", line 1, characters 4-5: Actual declaration
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "test.ml"; line = Single 1; chars = None }
+    ; message =
+        "The implementation test.ml does not match the interface test.cmi:\n\
+         Values do not match: val x : bool is not included in val x : int\n\
+         The type bool is not compatible with the type int"
+    ; related =
+        [ ({ path = "test.mli"; line = Single 1; chars = Some (0, 11) },
+           "Expected declaration")
+        ; ({ path = "test.ml"; line = Single 1; chars = Some (4, 5) },
+           "Actual declaration")
+        ]
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "" =
+  test_error
+    {|
+File "test.ml", line 1, characters 9-12:
+1 | let () = 123
+             ^^^
+Error: This expression has type int but an expression was expected of type
+         unit
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "test.ml"; line = Single 1; chars = Some (9, 12) }
+    ; message =
+        "This expression has type int but an expression was expected of type\n\
+        \  unit"
+    ; related = []
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "warning" =
+  test_error
+    {|
+File "test.ml", line 1, characters 13-14:
+1 | let () = let x = 2 in ()
+                 ^
+Warning 26 [unused-var]: unused variable x.
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "test.ml"; line = Single 1; chars = Some (13, 14) }
+    ; message = "unused variable x."
+    ; related = []
+    ; severity = Warning { code = 26; name = "unused-var" }
+    } |}]
+;;
+
+let%expect_test "" =
+  test_error
+    {|
+File "test.ml", lines 3-5, characters 6-3:
+3 | ......struct
+4 |   let x y = y +. 2.0
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig val x : float -> float end
+       is not included in
+         sig val x : int -> int end
+       Values do not match:
+         val x : float -> float
+       is not included in
+         val x : int -> int
+       The type float -> float is not compatible with the type int -> int
+       Type float is not compatible with type int
+       File "test.ml", line 2, characters 2-20: Expected declaration
+       File "test.ml", line 4, characters 6-7: Actual declaration
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "test.ml"; line = Range (3, 5); chars = Some (6, 3) }
+    ; message =
+        "Signature mismatch:\n\
+         Modules do not match:\n\
+        \  sig val x : float -> float end\n\
+         is not included in\n\
+        \  sig val x : int -> int end\n\
+         Values do not match:\n\
+        \  val x : float -> float\n\
+         is not included in\n\
+        \  val x : int -> int\n\
+         The type float -> float is not compatible with the type int -> int\n\
+         Type float is not compatible with type int"
+    ; related =
+        [ ({ path = "test.ml"; line = Single 2; chars = Some (2, 20) },
+           "Expected declaration")
+        ; ({ path = "test.ml"; line = Single 4; chars = Some (6, 7) },
+           "Actual declaration")
+        ]
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "ml mli mismatch 2" =
+  test_error
+    {|
+File "src/dune_rules/artifacts.ml", line 1:
+Error: The implementation src/dune_rules/artifacts.ml
+       does not match the interface src/dune_rules/.dune_rules.objs/byte/dune_rules__Artifacts.cmi:
+        ... ... In module Bin.Local:
+       Values do not match:
+         val equal :
+           Import.Path.Build.t Import.String.Set.map ->
+           Import.Path.Build.t Import.String.Set.map -> bool
+       is not included in
+         val equal : t -> bool -> bool
+       The type
+         Import.Path.Build.t Import.String.Set.map ->
+         Import.Path.Build.t Import.String.Set.map -> bool
+       is not compatible with the type t -> bool -> bool
+       Type Import.Path.Build.t Import.String.Set.map
+       is not compatible with type bool
+       File "src/dune_rules/artifacts.mli", line 20, characters 4-33:
+         Expected declaration
+       File "src/dune_rules/artifacts.ml", line 50, characters 8-13:
+         Actual declaration
+         |};
+  [%expect
+    {|
+    >> error 0
+    { loc =
+        { path = "src/dune_rules/artifacts.ml"; line = Single 1; chars = None }
+    ; message =
+        "The implementation src/dune_rules/artifacts.ml\n\
+         does not match the interface src/dune_rules/.dune_rules.objs/byte/dune_rules__Artifacts.cmi:\n\
+        \ ... ... In module Bin.Local:\n\
+         Values do not match:\n\
+        \  val equal :\n\
+        \    Import.Path.Build.t Import.String.Set.map ->\n\
+        \    Import.Path.Build.t Import.String.Set.map -> bool\n\
+         is not included in\n\
+        \  val equal : t -> bool -> bool\n\
+         The type\n\
+        \  Import.Path.Build.t Import.String.Set.map ->\n\
+        \  Import.Path.Build.t Import.String.Set.map -> bool\n\
+         is not compatible with the type t -> bool -> bool\n\
+         Type Import.Path.Build.t Import.String.Set.map\n\
+         is not compatible with type bool"
+    ; related =
+        [ ({ path = "src/dune_rules/artifacts.mli"
+           ; line = Single 20
+           ; chars = Some (4, 33)
+           },
+           "Expected declaration")
+        ; ({ path = "src/dune_rules/artifacts.ml"
+           ; line = Single 50
+           ; chars = Some (8, 13)
+           },
+           "Actual declaration")
+        ]
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "" =
+  test_error
+    {|
+File "fooexe.ml", line 3, characters 0-7:
+3 | Bar.run ();;
+    ^^^^^^^
+Error (alert deprecated): module Bar
+Will be removed past 2020-20-20. Use Mylib.Bar instead.
+File "fooexe.ml", line 4, characters 0-7:
+4 | Foo.run ();;
+    ^^^^^^^
+Error (alert deprecated): module Foo
+Will be removed past 2020-20-20. Use Mylib.Foo instead.
+File "fooexe.ml", line 7, characters 11-22:
+7 | module X : Intf_only.S = struct end
+               ^^^^^^^^^^^
+Error (alert deprecated): module Intf_only
+Will be removed past 2020-20-20. Use Mylib.Intf_only instead.
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "fooexe.ml"; line = Single 3; chars = Some (0, 7) }
+    ; message =
+        "module Bar\n\
+         Will be removed past 2020-20-20. Use Mylib.Bar instead."
+    ; related = []
+    ; severity = Error (Some "deprecated")
+    }
+    >> error 1
+    { loc = { path = "fooexe.ml"; line = Single 4; chars = Some (0, 7) }
+    ; message =
+        "module Foo\n\
+         Will be removed past 2020-20-20. Use Mylib.Foo instead."
+    ; related = []
+    ; severity = Error (Some "deprecated")
+    }
+    >> error 2
+    { loc = { path = "fooexe.ml"; line = Single 7; chars = Some (11, 22) }
+    ; message =
+        "module Intf_only\n\
+         Will be removed past 2020-20-20. Use Mylib.Intf_only instead."
+    ; related = []
+    ; severity = Error (Some "deprecated")
+    } |}]
+;;
+
+let%expect_test "undefined fields" =
+  test_error
+    {|
+File "test/expect-tests/timer_tests.ml", lines 6-10, characters 2-3:
+ 6 | ..{ Scheduler.Config.concurrency = 1
+ 7 |   ; display = { verbosity = Short; status_line = false }
+ 8 |   ; stats = None
+10 |   }
+Error: Some record fields are undefined: signal_watcher
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc =
+        { path = "test/expect-tests/timer_tests.ml"
+        ; line = Range (6, 10)
+        ; chars = Some (2, 3)
+        }
+    ; message = "Some record fields are undefined: signal_watcher"
+    ; related = []
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "undefined fields" =
+  test_error_raw
+    {|
+Error: Some record fields are undefined: signal_watcher
+|};
+  [%expect
+    {|
+    [ "Error: Some record fields are undefined: signal_watcher" ] |}]
+;;
+
+let%expect_test "test error from merlin" =
+  test_error_raw
+    {|Signature mismatch:
+Modules do not match:
+  sig val x : int end
+is not included in
+  sig val x : unit end
+Values do not match: val x : int is not included in val x : unit
+The type int is not compatible with the type unit
+File "test.ml", line 2, characters 2-14: Expected declaration
+File "test.ml", line 4, characters 6-7: Actual declaration
+  |};
+  [%expect
+    {|
+    [ "Signature mismatch:\n\
+       Modules do not match:\n\
+      \  sig val x : int end\n\
+       is not included in\n\
+      \  sig val x : unit end\n\
+       Values do not match: val x : int is not included in val x : unit\n\
+       The type int is not compatible with the type unit"
+    ; { path = "test.ml"; line = Single 2; chars = Some (2, 14) }
+    ; "Expected declaration"
+    ; { path = "test.ml"; line = Single 4; chars = Some (6, 7) }
+    ; "Actual declaration"
+    ] |}]
+;;
+
+let%expect_test "ml/mli error" =
+  test_error
+    {|
+File "src/dune_engine/build_system.ml", line 1:
+Error: The implementation src/dune_engine/build_system.ml
+      does not match the interface src/dune_engine/.dune_engine.objs/byte/dune_engine__Build_system.cmi:
+        The value `dune_stats' is required but not provided
+      File "src/dune_engine/build_system.mli", line 8, characters 0-40:
+        Expected declaration
+        |};
+  [%expect
+    {|
+    >> error 0
+    { loc =
+        { path = "src/dune_engine/build_system.ml"
+        ; line = Single 1
+        ; chars = None
+        }
+    ; message =
+        "The implementation src/dune_engine/build_system.ml\n\
+         does not match the interface src/dune_engine/.dune_engine.objs/byte/dune_engine__Build_system.cmi:\n\
+        \  The value `dune_stats' is required but not provided"
+    ; related =
+        [ ({ path = "src/dune_engine/build_system.mli"
+           ; line = Single 8
+           ; chars = Some (0, 40)
+           },
+           "Expected declaration")
+        ]
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "ml/mli error" =
+  test_error
+    {|
+File "bin/common.ml", line 1004, characters 8-43:
+1004 |         Dune_engine.Build_system.dune_stats := Some stats;
+               ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Unbound value Dune_engine.Build_system.dune_stats
+          |};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "bin/common.ml"; line = Single 1004; chars = Some (8, 43) }
+    ; message = "Unbound value Dune_engine.Build_system.dune_stats"
+    ; related = []
+    ; severity = Error None
+    } |}]
+;;
+
+let%expect_test "alert" =
+  test_error
+    {|
+File "foo.ml", line 8, characters 9-12:
+8 | let () = A.f
+             ^^^
+Alert deprecated: A.f
+foo
+  |};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "foo.ml"; line = Single 8; chars = Some (9, 12) }
+    ; message = "foo"
+    ; related = []
+    ; severity = Alert { name = "deprecated"; source = "A.f" }
+    } |}];
+  test_error
+    {|
+File "foo.ml", line 8, characters 9-12:
+8 | let () = A.f
+             ^^^
+Alert foobar: A.f
+blah
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "foo.ml"; line = Single 8; chars = Some (9, 12) }
+    ; message = "blah"
+    ; related = []
+    ; severity = Alert { name = "foobar"; source = "A.f" }
+    } |}]
+;;
+
+let%expect_test "multiple errors in one file" =
+  test_error
+    {|
+File "foo.ml", line 8, characters 8-11:
+8 | let f = A.f
+            ^^^
+Alert deprecated: A.f
+foo
+File "foo.ml", line 9, characters 8-11:
+9 | let g = A.f
+            ^^^
+Alert deprecated: A.f
+foo
+File "foo.ml", line 10, characters 8-11:
+10 | let h = A.f
+             ^^^
+Alert deprecated: A.f
+foo
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "foo.ml"; line = Single 8; chars = Some (8, 11) }
+    ; message = "foo"
+    ; related = []
+    ; severity = Alert { name = "deprecated"; source = "A.f" }
+    }
+    >> error 1
+    { loc = { path = "foo.ml"; line = Single 9; chars = Some (8, 11) }
+    ; message = "foo"
+    ; related = []
+    ; severity = Alert { name = "deprecated"; source = "A.f" }
+    }
+    >> error 2
+    { loc = { path = "foo.ml"; line = Single 10; chars = Some (8, 11) }
+    ; message = "foo"
+    ; related = []
+    ; severity = Alert { name = "deprecated"; source = "A.f" }
+    } |}]
+;;
+
+let%expect_test "fatal alert" =
+  test_error
+    {|
+File "foo.ml", line 8, characters 8-11:
+8 | let f = A.f
+            ^^^
+Error (alert foobar): A.f
+testing
+|};
+  [%expect
+    {|
+    >> error 0
+    { loc = { path = "foo.ml"; line = Single 8; chars = Some (8, 11) }
+    ; message = "A.f\n\
+                 testing"
+    ; related = []
+    ; severity = Error (Some "foobar")
+    } |}]
+;;
+
+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
+  |};
+  [%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" })
+    } |}]
+;;
+
+let%expect_test "two errors, second without 'error:'" =
+  test_error
+    {|
+File "src/dune_threaded_console/dune_threaded_console.ml", line 59, characters 18-23:
+59 |       Queue.clear state.messages;
+                       ^^^^^
+Error: Syntax error: 'end' expected
+File "src/dune_threaded_console/dune_threaded_console.ml", line 9, characters 17-23:
+9 |   let module T = struct
+                     ^^^^^^
+  This 'struct' might be unmatched
+
+    |};
+  [%expect
+    {|
+>> error 0
+{ loc =
+    { path = "src/dune_threaded_console/dune_threaded_console.ml"
+    ; line = Single 59
+    ; chars = Some (18, 23)
+    }
+; message = "Syntax error: 'end' expected"
+; related = []
+; severity = Error None
+} |}]
+;;