diff options
| -rw-r--r-- | lib/kernel/date_spec.ml | 20 | ||||
| -rw-r--r-- | lib/kernel/layer.ml | 6 | ||||
| -rw-r--r-- | test/test_names.ml | 30 | ||||
| -rw-r--r-- | test/test_overlay.ml | 19 |
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; |