kernel: loaders never escape as an exception, date-spec validates on load

Layer.load narrowed its catch to Sexplib0.Sexp_conv_error.Of_sexp_error,
but rank_of_sexp is caller-supplied and may raise anything -- e.g. a
hand-written rank parser that calls invalid_arg. Overlay.load already
catches every exception from the equivalent call; mirror that here so
layer.mli's "never as an exception" promise actually holds.

Date_spec.t derived its sexp converters with plain ppx_sexp_conv, unlike
Slug and Lang, which hand-write validating parsers specifically so
malformed data is rejected at load. (Fixed (month 13) (day 40)) used to
deserialise cleanly into a spec that simply never resolves -- a saint
quietly vanishing with no diagnostic. t_of_sexp now re-runs the value
through the existing fixed validator, the same shape Slug and Lang
already use.

Covering tests: a Layer.load case where rank_of_sexp raises
Invalid_argument instead of Of_sexp_error (would have escaped
uncaught before this fix); two Date_spec.t_of_sexp cases (month 13,
31 April) that must raise Of_sexp_error rather than silently
constructing an unresolvable spec.

4 files changed, 69 insertions, 6 deletions

diff --git a/lib/kernel/date_spec.ml b/lib/kernel/date_spec.ml
index 76e21e3..732f6b1 100644
--- a/lib/kernel/date_spec.ml
+++ b/lib/kernel/date_spec.ml
@@ -4,7 +4,11 @@ open Sexplib0.Sexp_conv
    sanctoral needs -- a fixed calendar date -- because EF movable feasts come
    from the rite's temporal code, not from data. Sunday-relative and
    Easter-relative forms arrive with the OF sanctoral. *)
-type t = Fixed of { month : int; day : int } [@@deriving sexp]
+module Repr = struct
+  type t = Fixed of { month : int; day : int } [@@deriving sexp]
+end
+
+type t = Repr.t = Fixed of { month : int; day : int }
 
 (* Leap-year maximum, so 29 February is constructible; it simply does not
    resolve in a common year. *)
@@ -23,3 +27,17 @@ let fixed ~month ~day =
 let resolve t ~year =
   match t with
   | Fixed { month; day } -> Result.to_option (Date.make ~year ~month ~day)
+
+let sexp_of_t = Repr.sexp_of_t
+
+(* Validating parser, matching Slug and Lang: [ppx_sexp_conv]'s derived
+   [t_of_sexp] (relocated to [Repr] above) accepts any in-range int pair, so
+   [(Fixed (month 13) (day 40))] would otherwise deserialise into a spec that
+   silently never resolves -- a saint quietly vanishing with no diagnostic.
+   Re-running the value through [fixed] closes that gap the same way loaders
+   already close it for slugs and language codes. *)
+let t_of_sexp sexp =
+  let (Fixed { month; day }) = Repr.t_of_sexp sexp in
+  match fixed ~month ~day with
+  | Ok t -> t
+  | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp
diff --git a/lib/kernel/layer.ml b/lib/kernel/layer.ml
index bf71206..515b052 100644
--- a/lib/kernel/layer.ml
+++ b/lib/kernel/layer.ml
@@ -52,5 +52,7 @@ let load rank_of_sexp path =
   | sexp -> (
       match t_of_sexp rank_of_sexp sexp with
       | t -> Ok { t with entries = canonical t.entries }
-      | exception Sexplib0.Sexp_conv_error.Of_sexp_error (exn, _) ->
-          Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)))
+      (* [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)))
diff --git a/test/test_names.ml b/test/test_names.ml
index 1649f9e..809d1c0 100644
--- a/test/test_names.ml
+++ b/test/test_names.ml
@@ -74,6 +74,24 @@ let test_date_spec_sexp_roundtrip () =
        Alcotest.(check bool) "sexp roundtrip" true (ds = ds')
    | Error e -> Alcotest.failf "fixed: %s" e)
 
+let test_date_spec_sexp_validates () =
+  (* Register finding 6: [ppx_sexp_conv]'s plain derived [t_of_sexp] would
+     accept any in-range int pair for [Fixed], so [(Fixed(month 13)(day 1))]
+     would silently deserialise into a spec that simply never resolves -- a
+     saint quietly vanishing with no diagnostic. [t_of_sexp] now re-runs the
+     value through [fixed], matching how [Slug] and [Lang] already validate
+     on load. *)
+  let bad = Sexplib.Sexp.of_string "(Fixed(month 13)(day 1))" in
+  Alcotest.check_raises "month 13 rejected at load"
+    (Sexplib0.Sexp_conv_error.Of_sexp_error
+       (Failure "date_spec: month 13 out of range 1..12", bad))
+    (fun () -> ignore (DS.t_of_sexp bad));
+  let bad_day = Sexplib.Sexp.of_string "(Fixed(month 4)(day 31))" in
+  Alcotest.check_raises "31 April rejected at load"
+    (Sexplib0.Sexp_conv_error.Of_sexp_error
+       (Failure "date_spec: day 31 out of range for month 4", bad_day))
+    (fun () -> ignore (DS.t_of_sexp bad_day))
+
 module Cel = Colitur_kernel.Celebration
 module S = Colitur_kernel.Slug
 module Col = Colitur_kernel.Colour
@@ -135,9 +153,14 @@ let test_record () =
   Alcotest.(check (list string)) "headers schema"
     [ "date"; "rite"; "season"; "week"; "weekday"; "slug"; "rank"; "colour"; "subject" ]
     Rec.headers;
-  (* Row must be the same length and order as headers. *)
-  Alcotest.(check int) "row matches headers length" (List.length Rec.headers)
-    (List.length (Rec.to_row r))
+  (* Register finding 14: with headers and to_row both derived from the same
+     [columns] list, equal length holds by construction -- a length-only
+     check here is vacuous, since it cannot fail without headers and to_row
+     already being defined from different sources. Assert the row's actual
+     values, in header order, instead. *)
+  Alcotest.(check (list string)) "row values in header order"
+    [ "2026-04-05"; "ef"; "ordinary"; "1"; "sunday"; "ef-easter-sunday"; "high"; "white"; "lord" ]
+    (Rec.to_row r)
 
 let suite =
   ( "Names/Citation/DateSpec",
@@ -149,5 +172,6 @@ let suite =
       Alcotest.test_case "citation" `Quick test_citation;
       Alcotest.test_case "date_spec" `Quick test_date_spec;
       Alcotest.test_case "date_spec sexp roundtrip" `Quick test_date_spec_sexp_roundtrip;
+      Alcotest.test_case "date_spec sexp validates" `Quick test_date_spec_sexp_validates;
       Alcotest.test_case "celebration" `Quick test_celebration;
       Alcotest.test_case "record" `Quick test_record ] )
diff --git a/test/test_overlay.ml b/test/test_overlay.ml
index 6131f65..b5edd5a 100644
--- a/test/test_overlay.ml
+++ b/test/test_overlay.ml
@@ -111,6 +111,23 @@ let test_layer_load_invalid_slug () =
       | Ok _ -> Alcotest.fail "expected Error for an invalid slug"
       | Error _ -> ())
 
+let test_layer_load_rank_of_sexp_raises_other_exception () =
+  (* Register finding 7: [rank_of_sexp] is caller-supplied and may raise
+     anything, not only [Of_sexp_error] -- [layer.mli] promises "never as an
+     exception". Before the fix this call did not reach the [Ok]/[Error]
+     match at all: [Invalid_argument] escaped [L.load] uncaught, and this
+     test would have errored rather than exercised the [Error _ -> ()]
+     branch. *)
+  let l = base () in
+  with_temp_file (fun path ->
+      let oc = open_out path in
+      output_string oc (Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank l));
+      close_out oc;
+      let exploding_rank_of_sexp _sexp = invalid_arg "boom" in
+      match L.load exploding_rank_of_sexp path with
+      | Ok _ -> Alcotest.fail "expected Error, not a successful load"
+      | Error _ -> ())
+
 module O = Colitur_kernel.Overlay
 module N = Colitur_kernel.Names
 module Lang = Colitur_kernel.Lang
@@ -298,6 +315,8 @@ let suite =
       Alcotest.test_case "layer load missing file" `Quick test_layer_load_missing_file;
       Alcotest.test_case "layer load malformed sexp" `Quick test_layer_load_malformed;
       Alcotest.test_case "layer load invalid slug" `Quick test_layer_load_invalid_slug;
+      Alcotest.test_case "layer load: rank_of_sexp raises a non-Of_sexp_error exception" `Quick
+        test_layer_load_rank_of_sexp_raises_other_exception;
       Alcotest.test_case "empty is identity" `Quick test_empty_is_identity;
       Alcotest.test_case "add and suppress" `Quick test_add_and_suppress;
       Alcotest.test_case "order matters" `Quick test_order_matters;