(* SPDX-License-Identifier: AGPL-3.0-or-later *)

(* Turn a raw sexplib exception string into something a person editing an
   overlay can act on.

   The derived parsers report failures as [Of_sexp_error] carrying the
   OCaml source path of the converter that failed, e.g.

     (Of_sexp_error "lib/rites/rite_ef/vocab_ef.ml.rank_of_sexp:
      unexpected variant constructor" (invalid_sexp Class9))

   which names a file the reader does not have and buries the one useful
   token (Class9) at the end. A user writing a diocesan calendar is the
   most likely person to hit this and the least likely to read OCaml.

   An earlier version of this lived in overlay.ml and rewrote five
   hardcoded module paths; anything else -- a rank, a layer entry, the
   top-level record -- came through raw. This one is generic, so a
   converter added later is covered without being listed. *)

let ends_with ~suffix s =
  let ls = String.length s and lf = String.length suffix in
  ls >= lf && String.sub s (ls - lf) lf = suffix

(* "lib/kernel/layer.ml.entry_of_sexp" -> "entry"
   "lib/kernel/overlay.ml.t_of_sexp"   -> "overlay"  (t is the module itself) *)
let noun_of_converter tok =
  match String.index_opt tok '/' with
  | None when not (String.length tok > 4 && String.sub tok 0 4 = "lib/") -> None
  | _ ->
      let dot_ml = ".ml." in
      let n = String.length tok and d = String.length dot_ml in
      let rec find i =
        if i > n - d then None
        else if String.sub tok i d = dot_ml then Some i
        else find (i + 1)
      in
      Option.bind (find 0) (fun i ->
          let fn = String.sub tok (i + d) (n - i - d) in
          if not (ends_with ~suffix:"_of_sexp" fn) then None
          else
            let base = String.sub fn 0 (String.length fn - 8) in
            if base <> "t" then Some base
            else
              (* fall back to the module's own name *)
              let path = String.sub tok 0 i in
              let start =
                match String.rindex_opt path '/' with
                | Some j -> j + 1
                | None -> 0
              in
              Some (String.sub path start (String.length path - start)))

let replace ~sub ~by s =
  let n = String.length sub and len = String.length s in
  if n = 0 then s
  else
    let b = Buffer.create len in
    let i = ref 0 in
    while !i <= len - n do
      if String.sub s !i n = sub then begin
        Buffer.add_string b by;
        i := !i + n
      end
      else begin
        Buffer.add_char b s.[!i];
        incr i
      end
    done;
    Buffer.add_string b (String.sub s !i (len - !i));
    Buffer.contents b

(* Every whitespace/paren-delimited token that looks like a converter path. *)
let rec humanise msg =
  let is_sep c = c = ' ' || c = '"' || c = '(' || c = ')' || c = '\n' in
  let out = ref msg in
  let n = String.length msg in
  let i = ref 0 in
  while !i < n do
    if is_sep msg.[!i] then incr i
    else begin
      let start = !i in
      while !i < n && not (is_sep msg.[!i]) do incr i done;
      let tok = String.sub msg start (!i - start) in
      let tok = if ends_with ~suffix:":" tok then String.sub tok 0 (String.length tok - 1) else tok in
      match noun_of_converter tok with
      | Some noun -> out := replace ~sub:tok ~by:noun !out
      | None -> ()
    end
  done;
  !out
  (* sexplib's own phrasing, in the reader's terms. Order matters: the
     longer "... for record expected" forms are rewritten before the
     shorter ones so no stray "expected" is left behind. *)
  |> replace ~sub:"unexpected variant constructor" ~by:"is not one of the allowed values"
  |> replace ~sub:"list instead of atom for record expected"
       ~by:"expected a record, found a plain value"
  |> replace ~sub:"atom instead of list for record expected"
       ~by:"expected a record, found a plain value"
  |> replace ~sub:"extra fields" ~by:"unknown field(s)"
  |> replace ~sub:"element of list" ~by:"item"
  |> strip_wrapper

(* [(Of_sexp_error "MSG" (invalid_sexp VALUE))] -> [MSG (at VALUE)].
   The wrapper is the parser's own structure, not anything the reader
   wrote, and leaving it in makes an error look like more sexp to debug. A
   long VALUE is truncated: the offending FIELD is what identifies the
   problem, and echoing an entire record -- or, when the file is not a
   calendar at all, a line of its contents -- is noise at best and leaks
   file content into logs at worst. *)
and strip_wrapper msg =
  (* sexplib PRETTY-PRINTS the exception, so the wrapper is followed by a
     newline and indentation rather than a single space. Collapse all
     whitespace first, or the prefix match silently never fires and every
     message comes through raw -- which is exactly what happened on the
     first attempt at this. *)
  let msg =
    String.concat " "
      (List.filter (fun w -> w <> "")
         (String.split_on_char ' '
            (String.map (function '\n' | '\t' | '\r' -> ' ' | c -> c) msg)))
  in
  let msg = String.trim msg in
  let strip_prefix p s =
    let lp = String.length p in
    if String.length s >= lp && String.sub s 0 lp = p then
      Some (String.sub s lp (String.length s - lp))
    else None
  in
  match strip_prefix "(Of_sexp_error " msg with
  | None -> msg
  | Some rest ->
      let rest = String.trim rest in
      let body, value =
        match String.index_opt rest '"' with
        | Some 0 -> (
            match String.index_from_opt rest 1 '"' with
            | Some close ->
                let m = String.sub rest 1 (close - 1) in
                let tail = String.trim (String.sub rest (close + 1)
                                          (String.length rest - close - 1)) in
                (m, tail)
            | None -> (rest, ""))
        | _ -> (rest, "")
      in
      let value =
        match strip_prefix "(invalid_sexp " value with
        | Some v ->
            let v = String.trim v in
            (* Drop the closing parens of BOTH wrappers -- invalid_sexp's and
               Of_sexp_error's -- keeping any that belong to the value
               itself, by removing only the excess over what the value
               opens. *)
            let v =
              let opens = ref 0 and closes = ref 0 in
              String.iter
                (function '(' -> incr opens | ')' -> incr closes | _ -> ())
                v;
              let excess = ref (!closes - !opens) in
              let b = Buffer.create (String.length v) in
              let n = String.length v in
              let i = ref (n - 1) in
              let tail = ref [] in
              while !i >= 0 do
                (if v.[!i] = ')' && !excess > 0 then decr excess
                 else tail := v.[!i] :: !tail);
                decr i
              done;
              List.iter (Buffer.add_char b) !tail;
              Buffer.contents b
            in
            let v = String.concat " " (String.split_on_char '\n' v) in
            let v = String.trim v in
            if String.length v > 60 then String.sub v 0 57 ^ "..." else v
        | None -> ""
      in
      if value = "" then body else body ^ " (at " ^ value ^ ")"