Source file warnings.ml

(** This module implements a warning management module *)

type warning =
  | Config of config_warning
  | Term_parsing of term_parsing_warning

and term_parsing_warning =
  | Var_and_const of (string * string * (Lexing.position * Lexing.position))

and config_warning =
  | Missing_key of (string * string list * string)
    (* Aimed at providing info
       about incorrect json
       config file. The string
       list is a path to the
       group of the expected key
    *)
  | Missing_name of (string * string list * string * string)
  | Missing_engine of (string * string list * string * string)
  | Default_engines
  | Default_colors
  | Bad_group of
      (string * string list * string * Yojson.Basic.t * string * string)
  | Json_error of string

let grp_preamble file path =
  match path with
  | [] -> Printf.sprintf "In file \"%s\"" file
  | path ->
      Printf.sprintf "In file \"%s\", under the path \"%s\"" file
        (Utils.string_of_list " -> " (fun x -> x) path)

let issue_warning = function
  | Config (Missing_key (file, path, key)) ->
      Logs.warn (fun m ->
          m "%s, key \"%s\" is missing" (grp_preamble file path) key)
  | Config (Missing_name (file, path, key, msg)) ->
      Logs.warn (fun m ->
          m
            "%s, key \"%s\" is missing in association with signature engine \
             \"%s\""
            (grp_preamble file path) key msg)
  | Config (Missing_engine (file, path, key, msg)) ->
      Logs.warn (fun m ->
          m
            "%s, key \"%s\" is missing in association with signature name \
             \"%s\""
            (grp_preamble file path) key msg)
  | Config Default_engines ->
      Logs.warn (fun m -> m "Using default signature to engine mapping")
  | Config Default_colors ->
      Logs.warn (fun m -> m "Using default bacground and node colors")
  | Config (Bad_group (file, path, yojson_msg, json, msg, msg')) ->
      let () =
        Logs.warn (fun m -> m "%s, %s" (grp_preamble file path) yojson_msg)
      in
      let () =
        Logs.warn (fun m ->
            m "%s, but got: \"%s\"" msg
              (Yojson.Basic.pretty_to_string ~std:true json))
      in
      Logs.warn (fun m -> m "%s" msg')
  | Config (Json_error msg) ->
      let () = Logs.warn (fun m -> m "Json error: %s" msg) in
      Logs.warn (fun m -> m "Using default configuration")
  | Term_parsing (Var_and_const (id, sg_name, (pos1, pos2))) ->
    if pos1 = Lexing.dummy_pos || pos2 = Lexing.dummy_pos then
      Logs.warn (fun m -> m "@[\"%a\"@ is@ both@ a@ variable@ and@ a@ constant@ of@ the@ signature@ \"%a\".@ Used@ here@ as@ a@ variable.@]" Utils.terms_pp id Utils.sig_pp sg_name)
    else
      let () = if pos1.Lexing.pos_fname = "" && pos2.Lexing.pos_fname = "" then Error.underline_error id (pos1, pos2) else () in
      let loc_string = Error.compute_comment_for_location (pos1, pos2) in
      Logs.warn (fun m -> m "@[@[%a:@]@;@[\"%a\"@ is@ both@ a@ variable@ and@ a@ constant@ of@ the@ signature@ \"%a\".@ Used@ here@ as@ a@ variable.@]@]" Error.pp_text loc_string Utils.terms_pp id Utils.sig_pp sg_name)