diff options
Diffstat (limited to 'test/test_calendar.ml')
| -rw-r--r-- | test/test_calendar.ml | 172 |
1 files changed, 172 insertions, 0 deletions
diff --git a/test/test_calendar.ml b/test/test_calendar.ml new file mode 100644 index 0000000..a3c4125 --- /dev/null +++ b/test/test_calendar.ml @@ -0,0 +1,172 @@ +module C = Colitur_kernel.Calendar +module D = Colitur_kernel.Date +module LD = Colitur_kernel.Liturgical_day +module Cel = Colitur_kernel.Celebration +module Sl = Colitur_kernel.Slug +module Rite = Colitur_kernel.Rite + +let mk y m d = match D.make ~year:y ~month:m ~day:d with Ok t -> t | Error e -> failwith e + +(* A synthetic rite -- not EF -- so Calendar's behaviour is proven against the + abstraction, not against EF's own real (and much larger) data. Two + seasons, two ranks: enough to exercise the type parameters without + dragging in real liturgical logic Calendar itself does not compute. *) +module Fixture = struct + module Vocab = Colitur_kernel.Vocab + module Colour = Colitur_kernel.Colour + module Temporal = Colitur_kernel.Temporal + module P = Colitur_kernel.Precedence + module Layer = Colitur_kernel.Layer + module Date_spec = Colitur_kernel.Date_spec + + type season = A | B + type rank = Hi | Lo + + let season_to_string = function A -> "a" | B -> "b" + let season_of_string = function "a" -> Some A | "b" -> Some B | _ -> None + let rank_to_string = function Hi -> "hi" | Lo -> "lo" + let rank_of_string = function "hi" -> Some Hi | "lo" -> Some Lo | _ -> None + + let vocab : (season, rank) Vocab.t = + { Vocab.seasons = [ A; B ]; season_to_string; season_of_string; + ranks = [ Hi; Lo ]; rank_to_string; rank_of_string } + + let weekday_index d = + match D.weekday d with + | D.Sun -> 0 | D.Mon -> 1 | D.Tue -> 2 | D.Wed -> 3 + | D.Thu -> 4 | D.Fri -> 5 | D.Sat -> 6 + + let sunday_on_or_before d = D.add_days d (-(weekday_index d)) + + (* Advent-anchored, mirroring the real EF rite's own RG-71 "Sunday nearest + 30 November" rule (rite_ef/temporal_ef.ml's [advent_start]) rather than + a Jan-1 year start: that shape is what makes the year-below-the-date's- + own-civil-year case in [Calendar.day] genuinely reachable, so the domain + -floor test below exercises something real. *) + let year_start y = D.add_days (sunday_on_or_before (mk y 12 24)) (-21) + + (* Not liturgically meaningful -- Calendar does not check season + contiguity (that is Validate's job); this just proves the season type + parameter is actually threaded through. *) + let season date = if D.month date < 6 then A else B + + (* One office per day, uniquely named by date so distinct days never + collide on slug. *) + let office date = + let slug = Printf.sprintf "feria-%04d-%02d-%02d" (D.year date) (D.month date) (D.day date) in + Cel.make ~slug:(Sl.of_string_exn slug) ~rank:Lo ~colour:Colour.Green ~layer:"synthetic-temporal" () + + let temporal date : (season, rank) Temporal.t = + { Temporal.season = season date; week = None; weekday = D.weekday date; office = office date } + + (* Band: Hi beats Lo; Temporal breaks a tie in its own favour -- the same + convention test_precedence.ml uses. *) + let band (_ : season P.context) (c : rank P.candidate) = + (match c.P.cel.Cel.rank with Hi -> 10 | Lo -> 20) + - (match c.P.origin with P.Temporal -> 1 | P.Sanctoral -> 0) + + let disposition ~winner:_ ~(loser : rank P.candidate) = + match loser.P.cel.Cel.rank with Lo -> P.Commemorate P.Ordinary | Hi -> P.Transfer + + let rules : (season, rank) P.rules = { P.band; disposition; admit = (fun ~observed:_ cs -> cs) } + + let rite : (season, rank) Rite.t = + { Rite.id = "synthetic-calendar"; vocab; year_start; temporal; anchors = (fun _ -> []); + rules; season_runs = [ A; B ] } + + let entry ~month ~day ~slug ~rank = + { Layer.date = (match Date_spec.fixed ~month ~day with Ok d -> d | Error e -> failwith e); + cel = Cel.make ~slug:(Sl.of_string_exn slug) ~rank ~colour:Colour.White + ~layer:"synthetic-sanctoral" () } + + let big_feast = entry ~month:12 ~day:8 ~slug:"big-feast" ~rank:Hi + let commem_worthy = entry ~month:12 ~day:15 ~slug:"commem-worthy" ~rank:Lo + + let layer = Layer.of_entries ~id:"synthetic" ~name:"Synthetic sanctoral" [ big_feast; commem_worthy ] + + let liturgical_year_of date = + let cy = D.year date in + if D.compare date (year_start cy) >= 0 then cy else cy - 1 +end + +let test_year_covers_every_day () = + let days = C.year Fixture.rite Fixture.layer 2026 in + let first = days.(0) and last = days.(Array.length days - 1) in + Alcotest.(check string) "starts at year_start" "2026-11-29" (D.to_iso8601 first.LD.date); + Alcotest.(check bool) "ends the day before next year_start" true + (D.compare last.LD.date (D.add_days (Fixture.rite.Rite.year_start 2027) (-1)) = 0); + (* every consecutive pair is exactly one day apart: no gaps, no duplicates *) + Array.iteri + (fun i d -> + if i > 0 then + Alcotest.(check int) "consecutive" 1 + (D.to_rata d.LD.date - D.to_rata days.(i - 1).LD.date)) + days + +let test_day_agrees_with_year () = + List.iter + (fun (y, m, dd) -> + let date = mk y m dd in + let from_day = C.day Fixture.rite Fixture.layer date in + let ys = C.year Fixture.rite Fixture.layer (Fixture.liturgical_year_of date) in + let from_year = Array.to_list ys |> List.find (fun d -> D.compare d.LD.date date = 0) in + Alcotest.(check string) "same observed" + (Sl.to_string from_year.LD.observed.Cel.slug) + (Sl.to_string from_day.LD.observed.Cel.slug)) + [ (2026, 12, 1); (2027, 3, 15); (2027, 7, 4) ] + +(* Two entries in the layer, per the brief: one that outranks the feria and + one that does not. Both sit on their own date so each assertion below + pins one behaviour without the other candidate muddying it. *) +let test_sanctoral_outranks_feria_becomes_observed () = + let days = C.year Fixture.rite Fixture.layer 2026 in + let date = mk 2026 12 8 in + let d = Array.to_list days |> List.find (fun d -> D.compare d.LD.date date = 0) in + Alcotest.(check string) "big-feast observed" "big-feast" (Sl.to_string d.LD.observed.Cel.slug) + +let test_lower_ranked_sanctoral_is_commemorated () = + let days = C.year Fixture.rite Fixture.layer 2026 in + let date = mk 2026 12 15 in + let d = Array.to_list days |> List.find (fun d -> D.compare d.LD.date date = 0) in + let expected_feria = Sl.to_string (Fixture.office date).Cel.slug in + Alcotest.(check string) "feria still observed" expected_feria (Sl.to_string d.LD.observed.Cel.slug); + Alcotest.(check (list string)) "commem-worthy commemorated" [ "commem-worthy" ] + (List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.commemorations) + +(* Register/design lesson (Plan 2's Validate 9999 bug): [year_start (y + 1)] + at the top of the domain must not raise. Calling [C.year ... 9999] here + directly (no [try]) is itself part of the pin -- if the clamp regressed, + this call would raise and the test would error rather than fail cleanly. *) +let test_year_9999_does_not_raise () = + let days = C.year Fixture.rite Fixture.layer 9999 in + Alcotest.(check bool) "non-empty" true (Array.length days > 0); + Alcotest.(check string) "starts at year_start 9999" + (D.to_iso8601 (Fixture.rite.Rite.year_start 9999)) + (D.to_iso8601 days.(0).LD.date); + Alcotest.(check string) "ends at the domain ceiling" "9999-12-31" + (D.to_iso8601 days.(Array.length days - 1).LD.date) + +(* The symmetric case at the bottom: 1 January 1583 is the domain's earliest + representable date, and Fixture's Advent-anchored [year_start] puts it + well before that civil year's own year_start -- so [day] must resolve it + via the [y] = 1582 branch without calling [year_start 1582] (out of + domain). Checks identity (the date's own feria), not merely that + something came back. *) +let test_day_near_domain_floor_does_not_raise () = + let date = mk 1583 1 1 in + let d = C.day Fixture.rite Fixture.layer date in + Alcotest.(check string) "returns the queried date" "1583-01-01" (D.to_iso8601 d.LD.date); + Alcotest.(check string) "observed is the day's own feria" + (Sl.to_string (Fixture.office date).Cel.slug) (Sl.to_string d.LD.observed.Cel.slug) + +let suite = + ( "Calendar", + [ Alcotest.test_case "year covers every day" `Quick test_year_covers_every_day; + Alcotest.test_case "day agrees with year" `Quick test_day_agrees_with_year; + Alcotest.test_case "outranking sanctoral becomes observed" `Quick + test_sanctoral_outranks_feria_becomes_observed; + Alcotest.test_case "lower-ranked sanctoral is commemorated" `Quick + test_lower_ranked_sanctoral_is_commemorated; + Alcotest.test_case "year 9999 does not raise" `Quick test_year_9999_does_not_raise; + Alcotest.test_case "day near the domain floor does not raise" `Quick + test_day_near_domain_floor_does_not_raise ] ) |