From 454667a47b8993ff9698d67dab952298ce42b9b4 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 9 Apr 2024 13:30:01 +0200 Subject: [PATCH] Messages: add a more concise interface with optional args --- compiler/catala_utils/message.ml | 60 ++++++++++++++++++++++++++----- compiler/catala_utils/message.mli | 25 +++++++++++-- 2 files changed, 74 insertions(+), 11 deletions(-) diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index c5a64fdf..9e6f245c 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -74,7 +74,7 @@ let unformat (f : Format.formatter -> unit) : string = (**{2 Message types and output helpers *) -type content_type = Error | Warning | Debug | Log | Result +type level = Error | Warning | Debug | Log | Result let get_ppf = function | Result -> Lazy.force std_ppf @@ -121,12 +121,12 @@ module Content = struct | MainMessage of message | Position of position | Suggestion of string list - | Result of message + | Outcome of message type t = message_element list let of_message (message : message) : t = [MainMessage message] - let of_result (message : message) : t = [Result message] + let of_result (message : message) : t = [Outcome message] let prepend_message (content : t) prefix : t = MainMessage prefix :: content let to_internal_error (content : t) : t = @@ -142,14 +142,14 @@ module Content = struct let add_position (content : t) - ?(message : message option = None) + ?(message : message option) (position : Pos.t) = content @ [Position { pos = position; pos_message = message }] let of_string (s : string) : t = - [MainMessage (fun ppf -> Format.pp_print_string ppf s)] + [MainMessage (fun ppf -> Format.pp_print_text ppf s)] - let emit (content : t) (target : content_type) : unit = + let emit (content : t) (target : level) : unit = match Global.options.message_format with | Global.Human -> let ppf = get_ppf target in @@ -169,7 +169,7 @@ module Content = struct pos.pos_message; Pos.format_loc_text ppf pos.pos | MainMessage msg -> msg ppf - | Result msg -> msg ppf + | Outcome msg -> msg ppf | Suggestion suggestions_list -> Suggestions.format ppf suggestions_list) ppf message_elements) @@ -207,7 +207,7 @@ module Content = struct match pos_message with Some m -> m | None -> fun _ -> () in Some pos, message - | Result m -> None, m + | Outcome m -> None, m | Suggestion sl -> None, fun ppf -> Suggestions.format ppf sl in Option.iter @@ -318,3 +318,47 @@ let emit_result format = Format.kdprintf (fun message -> Content.emit [MainMessage message] Result) format + + +(** New concise interface *) + +type ('a, 'b) emitter = + ?header:Content.message -> + ?internal:bool -> + ?pos:Pos.t -> + ?pos_msg:Content.message -> + ?extra_pos:(string option * Pos.t) list -> + ?fmt_pos:(Content.message option * Pos.t) list -> + ?suggestion:string list -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a + +let make ?header ?(internal=false) ?pos ?pos_msg ?extra_pos ?fmt_pos ?suggestion ~cont ~level = + Format.kdprintf @@ fun message -> + let t = match level with Result -> of_result message | _ -> of_message message in + let t = match header with Some h -> prepend_message t h | None -> t in + let t = if internal then to_internal_error t else t in + let t = match pos with Some p -> add_position t ?message:pos_msg p | None -> t in + let t = match extra_pos with + | Some pl -> + List.fold_left (fun t (message, p) -> + let message = Option.map (fun m ppf -> Format.pp_print_text ppf m) message in + add_position t ?message p) + t + pl + | None -> t + in + let t = match fmt_pos with + | Some pl -> + List.fold_left (fun t (message, p) -> add_position t ?message p) t pl + | None -> t + in + let t = match suggestion with Some s -> add_suggestion t s | None -> t in + cont t level + +let debug = make ~level:Debug ~cont:emit +let log = make ~level:Log ~cont:emit +let result = make ~level:Result ~cont:emit +let warning = make ~level:Warning ~cont:emit +let error = make ~level:Error ~cont:(fun m _ -> raise (CompilerError m)) + diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index 3b599181..ad428fb5 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -27,7 +27,7 @@ (** {1 Message content} *) -type content_type = Error | Warning | Debug | Log | Result +type level = Error | Warning | Debug | Log | Result module Content : sig (** {2 Types}*) @@ -50,11 +50,11 @@ module Content : sig val to_internal_error : t -> t val add_suggestion : t -> string list -> t - val add_position : t -> ?message:message option -> Pos.t -> t + val add_position : t -> ?message:message -> Pos.t -> t (** {2 Content emission}*) - val emit : t -> content_type -> unit + val emit : t -> level -> unit end (** This functions emits the message according to the emission type defined by @@ -132,3 +132,22 @@ val formatter_of_out_channel : out_channel -> Format.formatter (** Creates a new formatter from the given out channel, with correct handling of the ocolor tags. Actual use of escape codes in the output depends on [Cli.style_flag] -- and wether the channel is a tty if that is set to auto. *) + +(** {1 New concise interface using optional args} *) + +type ('a, 'b) emitter = + ?header:Content.message -> + ?internal:bool -> + ?pos:Pos.t -> + ?pos_msg:Content.message -> + ?extra_pos:(string option * Pos.t) list -> + ?fmt_pos:(Content.message option * Pos.t) list -> + ?suggestion:string list -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a + +val log: ('a, unit) emitter +val debug: ('a, unit) emitter +val result: ('a, unit) emitter +val warning: ('a, unit) emitter +val error: ('a, 'b) emitter