catala/compiler/catala_utils/message.ml

(* This file is part of the Catala compiler, a specification language for tax
   and social benefits computation rules. Copyright (C) 2023 Inria,
   contributors: Denis Merigoux <denis.merigoux@inria.fr>, Louis Gesbert
   <louis.gesbert@inria.fr>

   Licensed under the Apache License, Version 2.0 (the "License"); you may not
   use this file except in compliance with the License. You may obtain a copy of
   the License at

   http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
   License for the specific language governing permissions and limitations under
   the License. *)

(** Error formatting and helper functions *)

(**{1 Terminal formatting}*)

(* Adds handling of color tags in the formatter *)
let color_formatter ppf =
  Ocolor_format.prettify_formatter ppf;
  ppf

(* Sets handling of tags in the formatter to ignore them (don't print any color
   codes) *)
let unstyle_formatter ppf =
  Format.pp_set_mark_tags ppf false;
  ppf

(* SIDE EFFECT AT MODULE LOAD: this turns on handling of tags in
   [Format.sprintf] etc. functions (ignoring them) *)
let () = ignore (unstyle_formatter Format.str_formatter)

(* Note: we could do the same for std_formatter, err_formatter... but we'd
   rather promote the use of the formatting functions of this module and the
   below std_ppf / err_ppf *)

let has_color oc =
  match Cli.globals.color with
  | Cli.Never -> false
  | Always -> true
  | Auto -> Unix.(isatty (descr_of_out_channel oc))

(* Here we create new formatters to stderr/stdout that remain separate from the
   ones used by [Format.printf] / [Format.eprintf] (which remain unchanged) *)

let formatter_of_out_channel oc =
  let ppf = Format.formatter_of_out_channel oc in
  if has_color oc then color_formatter ppf else unstyle_formatter ppf

let std_ppf = lazy (formatter_of_out_channel stdout)
let err_ppf = lazy (formatter_of_out_channel stderr)
let ignore_ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()))

let unformat (f : Format.formatter -> unit) : string =
  let buf = Buffer.create 1024 in
  let ppf = unstyle_formatter (Format.formatter_of_buffer buf) in
  Format.pp_set_margin ppf max_int;
  (* We won't print newlines anyways, but better not have them in the first
     place (this wouldn't remove cuts in a vbox for example) *)
  let out_funs = Format.pp_get_formatter_out_functions ppf () in
  Format.pp_set_formatter_out_functions ppf
    {
      out_funs with
      Format.out_newline = (fun () -> out_funs.out_string " " 0 1);
      Format.out_indent = (fun _ -> ());
    };
  f ppf;
  Format.pp_print_flush ppf ();
  Buffer.contents buf

(**{2 Message types and output helpers *)

type content_type = Error | Warning | Debug | Log | Result

let get_ppf = function
  | Result -> Lazy.force std_ppf
  | Debug when not Cli.globals.debug -> Lazy.force ignore_ppf
  | Warning when Cli.globals.disable_warnings -> Lazy.force ignore_ppf
  | Error | Log | Debug | Warning -> Lazy.force err_ppf

(**{3 Markers}*)

let print_time_marker =
  let time : float ref = ref (Unix.gettimeofday ()) in
  fun ppf () ->
    let new_time = Unix.gettimeofday () in
    let old_time = !time in
    time := new_time;
    let delta = (new_time -. old_time) *. 1000. in
    if delta > 50. then
      Format.fprintf ppf "@{<bold;black>[TIME] %.0fms@}@\n" delta

let pp_marker target ppf =
  let open Ocolor_types in
  let tags, str =
    match target with
    | Debug -> [Bold; Fg (C4 magenta)], "[DEBUG]"
    | Error -> [Bold; Fg (C4 red)], "[ERROR]"
    | Warning -> [Bold; Fg (C4 yellow)], "[WARNING]"
    | Result -> [Bold; Fg (C4 green)], "[RESULT]"
    | Log -> [Bold; Fg (C4 black)], "[LOG]"
  in
  if target = Debug then print_time_marker ppf ();
  Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags);
  Format.pp_print_string ppf str;
  Format.pp_close_stag ppf ()

(**{2 Printers}*)

(** {1 Message content} *)

module Content = struct
  type message = Format.formatter -> unit
  type position = { pos_message : message option; pos : Pos.t }
  type suggestions = string list option

  type t = {
    message : message;
    positions : position list;
    suggestions : suggestions;
  }

  let of_message (message : message) : t =
    { message; positions = []; suggestions = None }

  let of_string (s : string) : t =
    {
      message = (fun ppf -> Format.pp_print_string ppf s);
      positions = [];
      suggestions = None;
    }

  let internal_error_prefix =
    "Internal Error, please report to \
     https://github.com/CatalaLang/catala/issues: "

  let prepend_message (content : t) prefix : t =
    {
      content with
      message = (fun ppf -> Format.fprintf ppf "%t@,%t" prefix content.message);
    }

  let mark_as_internal_error (content : t) : t =
    {
      content with
      message =
        (fun ppf ->
          Format.fprintf ppf "%s@,%t" internal_error_prefix content.message);
    }
end

open Content

let emit_content (content : Content.t) (target : content_type) : unit =
  let { message; positions; suggestions } = content in
  match Cli.globals.message_format with
  | Cli.Human ->
    let ppf = get_ppf target in
    Format.fprintf ppf "@[<v>@[<hov 0>%t%t%t@]%a@]@." (pp_marker target)
      (fun ppf ->
        match target with
        | Log | Error | Warning | Debug -> Format.pp_print_char ppf ' '
        | Result -> Format.pp_print_space ppf ())
      message
      (fun ppf l ->
        Format.pp_print_list
          ~pp_sep:(fun _ () -> ())
          (fun ppf pos ->
            Format.pp_print_cut ppf ();
            Format.pp_print_cut ppf ();
            Option.iter
              (fun msg -> Format.fprintf ppf "%t@," msg)
              pos.pos_message;
            Pos.format_loc_text ppf pos.pos)
          ppf l)
      positions
  | Cli.GNU ->
    (* The top message doesn't come with a position, which is not something the
       GNU standard allows. So we look the position list and put the top message
       everywhere there is not a more precise message. If we can't find a
       position without a more precise message, we just take the first position
       in the list to pair with the message. *)
    let ppf = get_ppf target in
    let () =
      if
        positions != []
        && List.for_all
             (fun (pos' : Content.position) -> Option.is_some pos'.pos_message)
             positions
      then
        Format.fprintf ppf "@{<blue>%s@}: %t %s@\n"
          (Pos.to_string_short (List.hd positions).pos)
          (pp_marker target) (unformat message)
    in
    Format.pp_print_list ~pp_sep:Format.pp_print_newline
      (fun ppf pos' ->
        Format.fprintf ppf "@{<blue>%s@}: %t %s"
          (Pos.to_string_short pos'.pos)
          (pp_marker target)
          (match pos'.pos_message with
          | None -> unformat message
          | Some msg' -> unformat msg'))
      ppf positions

(** {1 Error exception} *)

exception CompilerError of Content.t

(** {1 Error printing} *)

let raise_spanned_error
    ?(span_msg : Content.message option)
    (span : Pos.t)
    ?(suggestions : string list option)
    format =
  Format.kdprintf
    (fun message ->
      raise
        (CompilerError
           {
             message;
             positions = [{ pos_message = span_msg; pos = span }];
             suggestions;
           }))
    format

let raise_multispanned_error_full
    (spans : (Content.message option * Pos.t) list)
    format =
  Format.kdprintf
    (fun message ->
      raise
        (CompilerError
           {
             message;
             positions =
               List.map (fun (pos_message, pos) -> { pos_message; pos }) spans;
             suggestions = None;
           }))
    format

let raise_multispanned_error spans format =
  raise_multispanned_error_full
    (List.map
       (fun (msg, pos) ->
         Option.map (fun s ppf -> Format.pp_print_string ppf s) msg, pos)
       spans)
    format

let raise_error format =
  Format.kdprintf
    (fun message ->
      raise (CompilerError { message; positions = []; suggestions = None }))
    format

let raise_internal_error format =
  raise_error ("%s" ^^ format) internal_error_prefix

(** {1 Warning printing}*)

let assert_internal_error condition fmt =
  if condition then raise_internal_error ("assertion failed: " ^^ fmt)
  else Format.ifprintf (Format.formatter_of_out_channel stdout) fmt

let emit_multispanned_warning
    (pos : (Content.message option * Pos.t) list)
    format =
  Format.kdprintf
    (fun message ->
      emit_content
        {
          message;
          positions =
            List.map (fun (pos_message, pos) -> { pos_message; pos }) pos;
          suggestions = None;
        }
        Warning)
    format

let emit_spanned_warning
    ?(span_msg : Content.message option)
    (span : Pos.t)
    format =
  emit_multispanned_warning [span_msg, span] format

let emit_warning format = emit_multispanned_warning [] format

let emit_log format =
  Format.kdprintf
    (fun message ->
      emit_content { message; positions = []; suggestions = None } Log)
    format

let emit_debug format =
  Format.kdprintf
    (fun message ->
      emit_content { message; positions = []; suggestions = None } Debug)
    format

let emit_result format =
  Format.kdprintf
    (fun message ->
      emit_content { message; positions = []; suggestions = None } Result)
    format