Source file messageMg.ml

(* I'm not convinced by this module *)

type location = Lexing.position * Lexing.position
type context = { file : string option; loc : location option }

module type MSG = sig
  type t

  val err : 'a Logs.log
  val warn : 'a Logs.log
  val to_string : t -> string
end

module Make (M : MSG) = struct
  type msg =
    | Msg_Only of M.t
    | Msg_and_Full_Location of (M.t * string option * location option)
    | Msg_and_Location of (M.t * location option)
    | Msg_in_Full_Context of M.t

  type t = { msgs : msg list; context : context } [@@warning "-69"]

  exception Stop

  let empty context = { msgs = []; context }
  let set_context context r = { r with context }

  let compute_comment_for_location (pos1, pos2) =
    let line2 = pos2.Lexing.pos_lnum in
    let col2 = pos2.Lexing.pos_cnum - pos2.Lexing.pos_bol in
    let pos1 = pos1 in
    let line1 = pos1.Lexing.pos_lnum in
    let col1 = pos1.Lexing.pos_cnum - pos1.Lexing.pos_bol in
    if line1 = line2 then
      Printf.sprintf "line %d, characters %d-%d" line2 col1 col2
    else
      Printf.sprintf "line %d, character %d to line %d, character %d" line1 col1
        line2 col2

  let wrap_msg_with_location_info ~filename ~loc error =
    match (filename, loc) with
    | None, None -> M.to_string error
    | Some file, None ->
        Printf.sprintf "File \"%s\": %s" file (M.to_string error)
    | Some file, Some loc ->
        Printf.sprintf "File \"%s\", %s\n%s" file
          (compute_comment_for_location loc)
          (M.to_string error)
    | None, Some loc ->
        Printf.sprintf "%s\n%s"
          (compute_comment_for_location loc)
          (M.to_string error)

  let msg_to_string ~contextual_filename ~contextual_location = function
    | Msg_Only msg -> M.to_string msg
    | Msg_and_Full_Location (msg, filename, loc) ->
        wrap_msg_with_location_info ~filename ~loc msg
    | Msg_and_Location (msg, loc) ->
        wrap_msg_with_location_info ~filename:contextual_filename ~loc msg
    | Msg_in_Full_Context msg ->
        wrap_msg_with_location_info ~filename:contextual_filename
          ~loc:contextual_location msg

  let issue_msg ?filename ?location r =
    let () =
      List.iter
        (fun msg ->
          M.warn (fun m ->
              m "%s"
                (msg_to_string ~contextual_filename:filename
                   ~contextual_location:location msg)))
        (List.rev r.msgs)
    in
    { r with msgs = [] }

  let register ?(blocking = false) msg r =
    if not blocking then { r with msgs = msg :: r.msgs }
    else
      let () =
        M.err (fun m ->
            m "%s"
              (msg_to_string ~contextual_filename:None ~contextual_location:None
                 msg))
      in
      raise Stop
end