(** Validation messages with typed error codes. *)

type severity = Error | Warning | Info

type location = {
  line : int;
  column : int;
  end_line : int option;
  end_column : int option;
  system_id : string option;
}

type error_code =
  | Parse_error of Html5rw.Parse_error_code.t
  | Conformance_error of Error_code.t

type t = {
  severity : severity;
  message : string;
  error_code : error_code;
  location : location option;
  element : string option;
  attribute : string option;
  extract : string option;
}

let make_location ~line ~column ?end_line ?end_column ?system_id () =
  { line; column; end_line; end_column; system_id }

(** Create a message from a conformance error code *)
let of_conformance_error ?location ?element ?attribute ?extract error_code =
  let severity = match Error_code.severity error_code with
    | Error_code.Error -> Error
    | Error_code.Warning -> Warning
    | Error_code.Info -> Info
  in
  {
    severity;
    message = Error_code.to_message error_code;
    error_code = Conformance_error error_code;
    location;
    element;
    attribute;
    extract;
  }

(** Create a message from a parse error code *)
let of_parse_error ?location ?element ?attribute ?extract ~message code =
  {
    severity = Error;  (* Parse errors are always errors *)
    message;
    error_code = Parse_error code;
    location;
    element;
    attribute;
    extract;
  }

let error_code_to_string = function
  | Parse_error code -> Html5rw.Parse_error_code.to_string code
  | Conformance_error code -> Error_code.code_string code

let severity_to_string = function
  | Error -> "error"
  | Warning -> "warning"
  | Info -> "info"

let pp_severity fmt severity =
  Format.pp_print_string fmt (severity_to_string severity)

let pp_location fmt loc =
  (match loc.system_id with
  | Some sid -> Format.fprintf fmt "%s:" sid
  | None -> ());
  Format.fprintf fmt "%d:%d" loc.line loc.column;
  match (loc.end_line, loc.end_column) with
  | Some el, Some ec when el = loc.line && ec > loc.column ->
      Format.fprintf fmt "-%d" ec
  | Some el, Some ec when el > loc.line ->
      Format.fprintf fmt "-%d:%d" el ec
  | _ -> ()

let pp fmt msg =
  (match msg.location with
  | Some loc ->
      pp_location fmt loc;
      Format.fprintf fmt ": "
  | None -> ());
  pp_severity fmt msg.severity;
  Format.fprintf fmt " [%s]" (error_code_to_string msg.error_code);
  Format.fprintf fmt ": %s" msg.message;
  (match msg.element with
  | Some elem -> Format.fprintf fmt " (element: %s)" elem
  | None -> ());
  match msg.attribute with
  | Some attr -> Format.fprintf fmt " (attribute: %s)" attr
  | None -> ()

let to_string msg =
  let buf = Buffer.create 256 in
  let fmt = Format.formatter_of_buffer buf in
  pp fmt msg;
  Format.pp_print_flush fmt ();
  Buffer.contents buf