Two error formats

src/irj_checker/irj_checker.ml

@@ -21,18 +21,36 @@
 open Cmdliner
 open Mlang
 
-let irj_checker (f : string) : unit =
+type message_format_enum = Human | GNU
+
+let irj_checker (f : string) (message_format : message_format_enum) : unit =
   try ignore (Mlang.Irj_file.parse_file f)
   with Errors.StructuredError (msg, pos, kont) ->
-    Cli.error_print "%a" Errors.format_structured_error (msg, pos);
+    (match message_format with
+    | Human -> Cli.error_print "%a" Errors.format_structured_error
+    | GNU -> Format.eprintf "%a" Errors.format_structured_error_gnu_format)
+      (msg, pos);
     (match kont with None -> () | Some kont -> kont ());
     exit 123
 
+let message_format_opt = [ ("human", Human); ("gnu", GNU) ]
+
+let message_format =
+  Arg.(
+    value
+    & opt (enum message_format_opt) Human
+    & info [ "message-format" ]
+        ~doc:
+          "Selects the format of error and warning messages emitted by the \
+           compiler. If set to $(i,human), the messages will be nicely \
+           displayed and meant to be read by a human. If set to $(i, gnu), the \
+           messages will be rendered according to the GNU coding standards.")
+
 let file =
   let doc = "Test file (usually with the .irj extension)" in
   Arg.(value & pos 0 string "" & info [] ~docv:"FILE" ~doc)
 
-let irj_checker_t = Term.(const irj_checker $ file)
+let irj_checker_t = Term.(const irj_checker $ file $ message_format)
 
 let cmd =
   let doc = "parses, validates and transforms IRJ test files" in

src/mlang/test_framework/irj_file.ml

@@ -77,9 +77,9 @@ let fail text buffer (checkpoint : _ Irj_parser.MenhirInterpreter.checkpoint) =
   let message = MenhirLib.ErrorReports.expand (get text checkpoint) message in
   (* Show the tokens just before and just after the error. *)
   let indication =
-    Printf.sprintf "Syntax error at tokens %s. %s\n"
+    Printf.sprintf "Syntax error %s: %s"
       (MenhirLib.ErrorReports.show (show text) buffer)
-      message
+      (String.trim message)
   in
   (* Show these three components. *)
   Errors.raise_spanned_error indication

src/mlang/utils/errors.ml

@@ -31,6 +31,19 @@ let format_structured_error fmt
           pos))
     (if List.length pos = 0 then "" else "\n")
 
+let format_structured_error_gnu_format fmt
+    ((msg, pos) : string * (string option * Pos.t) list) =
+  Format.pp_print_list
+    ~pp_sep:(fun fmt () -> Format.pp_print_newline fmt ())
+    (fun fmt (pos_msg, pos) ->
+      Format.fprintf fmt "%a: %s %a\n" Pos.format_position_gnu pos msg
+        (fun fmt pos_msg ->
+          match pos_msg with
+          | None -> ()
+          | Some pos_msg -> Format.fprintf fmt "[%s]" pos_msg)
+        pos_msg)
+    fmt pos
+
 let raise_spanned_error (msg : string) ?(span_msg : string option)
     (span : Pos.t) : 'a =
   raise (StructuredError (msg, [ (span_msg, span) ], None))

src/mlang/utils/errors.mli

@@ -22,6 +22,9 @@ exception
 val format_structured_error :
   Format.formatter -> string * (string option * Pos.t) list -> unit
 
+val format_structured_error_gnu_format :
+  Format.formatter -> string * (string option * Pos.t) list -> unit
+
 (** {2 Raising errors with useful error messages}*)
 
 val raise_spanned_error : string -> ?span_msg:string -> Pos.t -> 'a

src/mlang/utils/pos.ml

@@ -36,6 +36,22 @@ let make_position_between (p1 : t) (p2 : t) : t =
     let pos_loc = (b, e) in
     { p1 with pos_loc }
 
+let format_position_gnu fmt pos =
+  let s, e = pos.pos_loc in
+  if s.Lexing.pos_lnum = e.Lexing.pos_lnum then
+    Format.fprintf fmt "%s:%d.%d-%d"
+      (Filename.basename pos.pos_filename)
+      s.Lexing.pos_lnum
+      (s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
+      (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
+  else
+    Format.fprintf fmt "%s:%d.%d-%d.%d"
+      (Filename.basename pos.pos_filename)
+      s.Lexing.pos_lnum
+      (s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)
+      e.Lexing.pos_lnum
+      (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1)
+
 let format_position_short fmt pos =
   let s, e = pos.pos_loc in
   if s.Lexing.pos_lnum = e.Lexing.pos_lnum then

src/mlang/utils/pos.mli

@@ -26,6 +26,9 @@ val make_position_between : t -> t -> t
 
 val format_position_short : Format.formatter -> t -> unit
 
+val format_position_gnu : Format.formatter -> t -> unit
+(** Respects https://www.gnu.org/prep/standards/standards.html#Formatting-Error-Messages *)
+
 val format_position : Format.formatter -> t -> unit
 
 type 'a marked = 'a * t