diff --git a/src/irj_checker/irj_checker.ml b/src/irj_checker/irj_checker.ml index 82b7c17bb..be0a27dae 100644 --- a/src/irj_checker/irj_checker.ml +++ b/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 diff --git a/src/mlang/test_framework/irj_file.ml b/src/mlang/test_framework/irj_file.ml index e4cc59e35..26924076c 100644 --- a/src/mlang/test_framework/irj_file.ml +++ b/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 diff --git a/src/mlang/utils/errors.ml b/src/mlang/utils/errors.ml index 4fbf8fd93..d38a3935c 100644 --- a/src/mlang/utils/errors.ml +++ b/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)) diff --git a/src/mlang/utils/errors.mli b/src/mlang/utils/errors.mli index 11bb4f35d..82ba93a39 100644 --- a/src/mlang/utils/errors.mli +++ b/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 diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index 1f7a2e416..fdc659939 100644 --- a/src/mlang/utils/pos.ml +++ b/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 diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index 1e2c3f62a..73a98e756 100644 --- a/src/mlang/utils/pos.mli +++ b/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