diff options
Diffstat (limited to 'lib/kernel')
| -rw-r--r-- | lib/kernel/layer.ml | 4 | ||||
| -rw-r--r-- | lib/kernel/overlay.ml | 22 | ||||
| -rw-r--r-- | lib/kernel/overlay_ini.ml | 13 | ||||
| -rw-r--r-- | lib/kernel/sexp_error.ml | 177 | ||||
| -rw-r--r-- | lib/kernel/sexp_error.mli | 4 |
5 files changed, 198 insertions, 22 deletions
diff --git a/lib/kernel/layer.ml b/lib/kernel/layer.ml index ec074a7..f069546 100644 --- a/lib/kernel/layer.ml +++ b/lib/kernel/layer.ml @@ -85,11 +85,11 @@ let load rank_of_sexp path = unterminated list or string) rather than [Sexplib.Sexp.Parse_error], so a catch-all here -- placed last among the exception branches -- is what actually keeps every parse failure inside [Error] instead of escaping. *) - | exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)) + | exception exn -> Error (Printf.sprintf "%s: %s" path (Sexp_error.humanise (Printexc.to_string exn))) | sexp -> ( match t_of_sexp rank_of_sexp sexp with | t -> Ok { t with entries = canonical t.entries } (* [rank_of_sexp] is caller-supplied and may raise anything, not only [Of_sexp_error] -- mirrors [Overlay.load]'s catch-all, so "never as an exception" (layer.mli) actually holds. *) - | exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn))) + | exception exn -> Error (Printf.sprintf "%s: %s" path (Sexp_error.humanise (Printexc.to_string exn)))) diff --git a/lib/kernel/overlay.ml b/lib/kernel/overlay.ml index 58d8847..516379d 100644 --- a/lib/kernel/overlay.ml +++ b/lib/kernel/overlay.ml @@ -132,23 +132,6 @@ let fill_defaults ~id sexp = actually reach a user into the vocabulary of the file they are looking at. Anything unrecognised passes through verbatim rather than being reworded into something possibly wrong. *) -let humanise_error msg = - let replace ~sub ~by s = - let n = String.length sub and len = String.length s in - let rec go i acc = - if i > len - n then acc ^ String.sub s i (len - i) - else if String.equal (String.sub s i n) sub then go (i + n) (acc ^ by) - else go (i + 1) (acc ^ String.make 1 s.[i]) - in - if n = 0 then s else go 0 "" - in - msg - |> replace ~sub:"lib/kernel/celebration.ml.t_of_sexp" ~by:"celebration" - |> replace ~sub:"lib/kernel/colour.ml.t_of_sexp" ~by:"colour" - |> replace ~sub:"lib/kernel/subject.ml.t_of_sexp" ~by:"subject" - |> replace ~sub:"lib/kernel/date_spec.ml.t_of_sexp" ~by:"date" - |> replace ~sub:"lib/kernel/overlay.ml.directive_of_sexp" ~by:"directive" - let load rank_of_sexp path = match Sexplib.Sexp.load_sexp path with | exception Sys_error msg -> Error msg @@ -157,7 +140,8 @@ let load rank_of_sexp path = [Sexplib.Sexp.Parse_error], so a catch-all here -- placed last among the exception branches -- is what actually keeps every parse failure inside [Error] instead of escaping. *) - | exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)) + | exception exn -> + Error (Printf.sprintf "%s: %s" path (Sexp_error.humanise (Printexc.to_string exn))) | sexp -> ( (* The overlay's own [id] is needed to default [layer], so read it off the raw sexp first. If it is missing or malformed the derived parser @@ -174,4 +158,4 @@ let load rank_of_sexp path = match t_of_sexp rank_of_sexp (fill_defaults ~id sexp) with | t -> Ok t | exception exn -> - Error (Printf.sprintf "%s: %s" path (humanise_error (Printexc.to_string exn)))) + Error (Printf.sprintf "%s: %s" path (Sexp_error.humanise (Printexc.to_string exn)))) diff --git a/lib/kernel/overlay_ini.ml b/lib/kernel/overlay_ini.ml index 6b6249f..09f6d52 100644 --- a/lib/kernel/overlay_ini.ml +++ b/lib/kernel/overlay_ini.ml @@ -37,7 +37,18 @@ let parse_sections text = end else match String.index_opt line '=' with - | None -> err "line %d: %S is neither a [section] nor a key = value line" n line + | None -> + (* Echo at most a little of the line. Pointing at line N is + what locates the problem; reproducing the whole line adds + nothing and, when someone has pointed a --lang or --overlay + flag at a file that is not a calendar at all, quietly + copies that file's contents into stderr and any log + collecting it. *) + let shown = + if String.length line > 40 then String.sub line 0 37 ^ "..." + else line + in + err "line %d: %S is neither a [section] nor a key = value line" n shown | Some i -> if !cur = None then err "line %d: %S appears before any [section] header" n line diff --git a/lib/kernel/sexp_error.ml b/lib/kernel/sexp_error.ml new file mode 100644 index 0000000..88cc139 --- /dev/null +++ b/lib/kernel/sexp_error.ml @@ -0,0 +1,177 @@ +(* 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 ^ ")" diff --git a/lib/kernel/sexp_error.mli b/lib/kernel/sexp_error.mli new file mode 100644 index 0000000..d3de75b --- /dev/null +++ b/lib/kernel/sexp_error.mli @@ -0,0 +1,4 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) + +(** Human-readable form of a raw sexplib exception string. *) +val humanise : string -> string |