Source file diagnosis.ml

type loc = Cmarkit.Textloc.t

let loc_of_ploc loc (idx, idx') =
  let open Cmarkit.Textloc in
  let file = file loc in
  let first_line = first_line loc in
  let last_line = first_line in
  let first_byte = first_byte loc + idx in
  let last_byte = first_byte + idx' - idx - 1 in
  v ~file ~first_line ~last_line ~first_byte ~last_byte

type t =
  | DuplicateID of { id : string; occurrences : loc list }
  | MissingFile of { file : string; error_msg : string; locs : loc list }
  | WrongType of { loc_reason : loc; loc_block : loc; expected_type : string }
  | ParsingError of { action : string; msg : string; loc : loc }
  | ParsingWarnor of { warnor : Actions_arguments.W.warnor; loc : loc }
  | InconsistentOption of { option_name : string; loc1 : loc; loc2 : loc }
  | MissingID of { id : string; loc : loc }
  | UnknownAttribute of { attr : string; loc : loc }
  | UnknownFrontmatterField of {
      key : string;
      loc : loc;
      allowed_keys : string list;
    }
  | FrontmatterParsing of { key : string; msg : string; loc : loc }
  | InvalidFrontmatterLine of { loc : loc }
  | ChildrenClassWithValue of { loc : loc }

(* This is currently used to render issues on things that don't have location:
   mostly CLI input. CLI input have much less errors they can raise, so it's OK
   if (most) of them are not great messages. But I still keep all of those here
   since this function will have some things to be taken for LSP integration. *)
let pp ppf = function
  | DuplicateID id ->
      Format.fprintf ppf "ID '%s' has already been given at %a." id.id
        (Fmt.list Cmarkit.Textloc.pp_ocaml)
        id.occurrences
  | MissingFile s ->
      Format.fprintf ppf "Missing file: %s, considering it as an URL. (%s)"
        s.file s.error_msg
  | WrongType { loc_reason = _; loc_block = _; expected_type } ->
      Format.fprintf ppf "Wrong type: expected type '%s'" expected_type
  | ParsingError { action; msg; loc = _ } ->
      Format.fprintf ppf
        "Parsing of the arguments of actions '%s' failed with '%s'" action msg
  | ParsingWarnor
      { warnor = UnusedArgument { action_name; argument_name; _ }; loc = _ } ->
      Format.fprintf ppf "Action '%s' does not accept argument '%s'" action_name
        argument_name
  | ParsingWarnor { warnor = Parsing_failure { msg; loc = _ }; loc = _ } ->
      Format.fprintf ppf "Action argument parsing failure: %s" msg
  | MissingID { id; loc = _ } ->
      Format.fprintf ppf "Id '%s' could not be found" id
  | UnknownAttribute { attr; loc = _ } ->
      Format.fprintf ppf
        "Attribute '%s' is neither a standard HTML attribute nor a slipshow \
         specific one"
        attr
  | UnknownFrontmatterField { key; _ } ->
      Format.fprintf ppf "Frontmatter field '%s' is not interpreted by slipshow"
        key
  | InvalidFrontmatterLine _ ->
      Format.fprintf ppf
        "Invalid frontmatter entry: Frontmatter have to be of the form \
         \"key:value\" on a single line."
  | FrontmatterParsing { msg; _ } -> Format.fprintf ppf "%s" msg
  | ChildrenClassWithValue _ ->
      Format.fprintf ppf "%s" "Children classes cannot have a value"
  | InconsistentOption { option_name; _ } ->
      Format.fprintf ppf "option '%s' is provided multiple times" option_name

let to_code = function
  | DuplicateID _ -> "DupID"
  | MissingFile _ -> "FSError"
  | WrongType _ -> "WrongType"
  | ParsingError _ -> "ActionParsing"
  | ParsingWarnor _ -> "ActionParsing"
  | MissingID _ -> "IDNotFound"
  | UnknownAttribute _ -> "UnknownAttribute"
  | UnknownFrontmatterField _ -> "UnknownFrontmatterField"
  | InvalidFrontmatterLine _ -> "InvalidFrontmatterLine"
  | FrontmatterParsing _ -> "FrontmatterParsing"
  | ChildrenClassWithValue _ -> "ChildrenClassWithValue"
  | InconsistentOption _ -> "InconsistentOption"

let report_no_src fmt x =
  let msg = Format.asprintf "%a" pp x in
  let msg = Grace.Diagnostic.createf ~labels:[] ~code:x Warning "%s" msg in
  Format.fprintf fmt "%a@.@."
    (Grace_ansi_renderer.pp_diagnostic ?config:None ~code_to_string:to_code)
    msg

let with_range source_map loc f =
  let open Grace in
  let ( let+ ) x f = Option.map f x in
  let range (loc : loc) =
    let+ source = source_map (Fpath.v (Cmarkit.Textloc.file loc)) in
    let start = Cmarkit.Textloc.first_byte loc in
    let stop = Cmarkit.Textloc.last_byte loc + 1 in
    Range.create ~source (Byte_index.of_int start) (Byte_index.of_int stop)
  in
  try
    let+ range = range loc in
    f ~range
  with Invalid_argument _ -> None

let to_grace source_map error =
  let open Grace in
  let with_range = with_range source_map in
  match error with
  | DuplicateID { id; occurrences } ->
      let labels =
        List.filter_map
          (fun occ -> with_range occ @@ Diagnostic.Label.primaryf "")
          occurrences
      in
      Diagnostic.createf ~labels Warning "ID %s is assigned multiple times" id
  | MissingFile { file; error_msg; locs } ->
      let labels =
        List.filter_map
          (fun loc -> with_range loc @@ Diagnostic.Label.primaryf "")
          locs
      in
      Diagnostic.createf ~labels Warning "file '%s' could not be read: %s" file
        error_msg
  | WrongType { loc_reason; loc_block; expected_type } ->
      let labels =
        List.filter_map Fun.id
          [
            with_range loc_reason
            @@ Diagnostic.Label.primaryf "This expects the id of a %s"
                 expected_type;
            with_range loc_block
            @@ Diagnostic.Label.primaryf "This is not a %s" expected_type;
          ]
      in
      Diagnostic.createf ~labels Warning "Wrong type"
  | ParsingError { action; msg; loc } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "%s" msg ]
      in
      Diagnostic.createf ~labels Warning
        "Action %s arguments could not be parsed" action
  | ParsingWarnor
      {
        warnor =
          UnusedArgument
            { action_name; argument_name; loc = parse_loc; possible_arguments };
        loc;
      } ->
      let loc = loc_of_ploc loc parse_loc in
      let labels =
        List.filter_map Fun.id
          [
            with_range loc
            @@ Diagnostic.Label.primaryf
                 "Action '%s' does not take argument '%s'" action_name
                 argument_name;
          ]
      in
      let notes =
        match possible_arguments with
        | [] ->
            [
              Diagnostic.Message.createf "'%s' accepts no arguments" action_name;
            ]
        | _ ->
            [
              Diagnostic.Message.createf "'%s' accepts arguments '%s'"
                action_name
                (String.concat "', '" possible_arguments);
            ]
      in
      Diagnostic.createf ~labels ~notes Warning "Invalid action argument"
  | ParsingWarnor { warnor = Parsing_failure { msg; loc = parse_loc }; loc } ->
      let loc = loc_of_ploc loc parse_loc in
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "%s" msg ]
      in
      Diagnostic.createf ~labels Warning "Failed to parse"
  | MissingID { id; loc } ->
      let labels =
        List.filter_map Fun.id
          [
            with_range loc
            @@ Diagnostic.Label.primaryf
                 "This should be an ID present in the document";
          ]
      in
      Diagnostic.createf ~labels Warning "No element with id '%s' was found" id
  | UnknownFrontmatterField { key; loc; allowed_keys } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "" ]
      in
      let note =
        Diagnostic.Message.createf "Recognized fields are: '%s'"
          (String.concat "', '" allowed_keys)
      in
      Diagnostic.createf ~labels ~notes:[ note ] Warning
        "Frontmatter field '%s' is not interpreted by slipshow" key
  | InvalidFrontmatterLine { loc } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "" ]
      in
      let note =
        Diagnostic.Message.createf "%s"
          "Frontmatter have to be of the form \"key:value\" on a single line."
      in
      let notes = [ note ] in
      Diagnostic.createf ~notes ~labels Warning "Invalid frontmatter entry"
  | UnknownAttribute { attr; loc } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "" ]
      in
      Diagnostic.createf ~labels Warning "Non standard attribute: '%s'" attr
  | FrontmatterParsing { key; msg; loc } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "%s" msg ]
      in
      Diagnostic.createf ~labels Warning
        "Error while parsing frontmatter field '%s'" key
  | ChildrenClassWithValue { loc } ->
      let labels =
        List.filter_map Fun.id
          [ with_range loc @@ Diagnostic.Label.primaryf "" ]
      in
      Diagnostic.createf ~labels Warning "Children classes cannot have a value"
  | InconsistentOption { option_name; loc1; loc2 } ->
      let labels =
        List.filter_map Fun.id
          [
            with_range loc1 @@ Diagnostic.Label.primaryf "";
            with_range loc2 @@ Diagnostic.Label.primaryf "";
          ]
      in
      Diagnostic.createf ~labels Warning
        "Option '%s' is assigned multiple times in incompatible ways"
        option_name

let errors_acc = ref []
let add x = errors_acc := x :: !errors_acc

let with_ f =
  let old_errors = !errors_acc in
  errors_acc := [];
  let clean_up () =
    let errors = !errors_acc in
    errors_acc := old_errors;
    errors
  in
  try
    let res = f () in
    (res, clean_up ())
  with exn ->
    let _ = clean_up () in
    raise exn