qsp_parser/lib/syntax/report.ml

(** Report built over the differents analysis in the file *)

type level = Error | Warn | Debug
[@@deriving show { with_path = false }, enum, eq]

type pos = Lexing.position * Lexing.position

let level_of_string : string -> (level, string) result =
 fun level ->
  match String.lowercase_ascii level with
  | "error" -> Ok Error
  | "warn" -> Ok Warn
  | "debug" -> Ok Debug
  | _ ->
      Error
        (Format.sprintf
           "Unknown report level '%s'. Accepted values are error, warn, debug"
           level)

let pp_pos : Format.formatter -> pos -> unit =
 fun f (start_pos, end_pos) ->
  let start_c = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol
  and end_c = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol
  and start_line = start_pos.Lexing.pos_lnum
  and end_line = end_pos.Lexing.pos_lnum in

  if start_line != end_line then
    Format.fprintf f "Lines %d-%d" start_line end_line
  else Format.fprintf f "Line %d %d:%d" start_line start_c end_c

let pp_line : Format.formatter -> pos -> unit =
 fun f (start_pos, end_pos) ->
  (* Only care about the first line *)
  ignore end_pos;
  let start_line = start_pos.Lexing.pos_lnum in
  Format.fprintf f "%d" start_line

type t = { level : level; loc : pos; message : string }
[@@deriving show { with_path = false }]

(** Compare two positions *)
let compare_pos : pos -> pos -> int =
 fun (pos1_start, pos1_end) (pos2_start, pos2_end) ->
  (* first compare the position *)
  match compare pos1_start.pos_cnum pos2_start.pos_cnum with
  | 0 ->
      (* Then the ending position *)
      compare pos1_end.pos_cnum pos2_end.pos_cnum
  | other -> other

let compare : t -> t -> int =
 fun t1 t2 ->
  (* first compare the position *)
  match compare_pos t1.loc t2.loc with
  | 0 -> (
      (* And the level *)
      match compare (level_to_enum t1.level) (level_to_enum t2.level) with
      | 0 -> String.compare t1.message t2.message
      | other -> other)
  | other -> other

let debug : pos -> string -> t =
 fun loc message -> { level = Debug; loc; message }

let warn : pos -> string -> t =
 fun loc message -> { level = Warn; loc; message }

let error : pos -> string -> t =
 fun loc message -> { level = Error; loc; message }

let message level loc message = { level; loc; message }

type result = t list [@@deriving show]