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, three ranks: enough to exercise the type parameters without dragging in real liturgical logic Calendar itself does not compute. Three ranks, not two: Task 6 review finding 2. With only one Transfer-disposed rank, every deferred candidate ties on [band] and [compare_deferred]'s [b1 <> b2] branch (the one RG 97-98 actually depends on -- coinciding I-class feasts transfer in TABLE order, not slug order) was unreachable; reversing it broke no test. [Hi1] outranks [Hi2], both outrank [Lo], both are [Transfer]-disposed -- so two colliding transferables can now differ by band, not only by slug. *) 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 = Hi1 | Hi2 | 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 Hi1 -> "hi1" | Hi2 -> "hi2" | Lo -> "lo" let rank_of_string = function "hi1" -> Some Hi1 | "hi2" -> Some Hi2 | "lo" -> Some Lo | _ -> None let vocab : (season, rank) Vocab.t = { Vocab.seasons = [ A; B ]; season_to_string; season_of_string; ranks = [ Hi1; Hi2; 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: Hi1 beats Hi2 beats Lo; Temporal breaks a tie against a Lo-rank Sanctoral entry 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 Hi1 -> 5 | Hi2 -> 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 | Hi1 | Hi2 -> P.Transfer (* Admits at most one commemoration -- mirrors test_precedence.ml's own example and, unlike "admit everything", actually gives the accounting test below a genuine Precedence-native omission (distinct from a deferred one) to exercise. *) let rules : (season, rank) P.rules = { P.vigil_feast = (fun _ -> None); band; disposition; admit = (fun ~observed:_ ~temporal:_ cs -> List.filteri (fun i _ -> i < 1) cs |> List.map (fun (c, p, (_ : int)) -> (c, p))) } (* RG 96, generic form: search forward from the day after [origin] for the first day whose occupant is not "blocking" -- in this synthetic vocabulary Hi1/Hi2 stand in for I/II class, Lo for everything else (the same convention [band] already uses). No Annunciation-style starting-point override: that exception is EF-specific (RG 96) and belongs to the real rite (Task 11, pinned by Task 17's golden years), not to this abstraction-level fixture, which only has to prove Calendar's placement mechanism, not EF's own rubrics. *) let transfer_target (_ : rank P.candidate) (origin : D.t) (occupant : D.t -> rank Cel.t) : D.t = let rec search d = if (occupant d).Cel.rank = Lo then d else search (D.add_days d 1) in search (D.add_days origin 1) (* No fixture here exercises citations -- readings is a harmless constant [], the same role [empty_layer] plays for the sanctoral side. *) let readings ~observed:_ ~temporal:_ ~date:_ ~temporal_at:_ = [] let rite : (season, rank) Rite.t = { Rite.id = "synthetic-calendar"; vocab; year_start; temporal; anchors = (fun _ -> []); (* Not a Roman rite, but a Rite.t must supply SOME Easter now that movable Date_spec variants exist. The Gregorian one is as good as any for a fixture; nothing here is Easter-relative, so the value is never actually read. *) easter = Colitur_kernel.Computus.gregorian_easter; rules; season_runs = [ A; B ]; transfer_target; readings } 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:Hi1 let commem_worthy = entry ~month:12 ~day:15 ~slug:"commem-worthy" ~rank:Lo (* 20 Dec: four sanctoral entries on one date, for the full-accounting test. "day-winner" and "eclipsed" tie on band (both Hi1, both Sanctoral); ties break on slug, so "day-winner" wins and "eclipsed" -- a Hi1-rank loser -- is [Transfer]-disposed, landing in [deferred]. "loser-a" and "loser-b" are both Lo, both [Commemorate]-disposed, but [admit] only keeps one: the other lands in Precedence's own [omitted] ("admission limit reached"), distinct from "eclipsed"'s deferred reason. Four candidates, three different fates -- observed, one specific omission reason, two more. *) let day_winner = entry ~month:12 ~day:20 ~slug:"day-winner" ~rank:Hi1 let eclipsed = entry ~month:12 ~day:20 ~slug:"eclipsed" ~rank:Hi1 let loser_a = entry ~month:12 ~day:20 ~slug:"loser-a" ~rank:Lo let loser_b = entry ~month:12 ~day:20 ~slug:"loser-b" ~rank:Lo let layer = Layer.of_entries ~id:"synthetic" ~name:"Synthetic sanctoral" [ big_feast; commem_worthy; day_winner; eclipsed; loser_a; loser_b ] (* RG 96 (Task 6): "transferable" is impeded on 10 Jan by "blocker-a" (both Hi1; ties break on slug, "blocker-a" < "transferable", so "blocker-a" wins and "transferable" is the loser). 11 and 12 Jan are ALSO occupied by their own uncontested Hi1-rank entries, so the placement search must walk past more than one ineligible day, not just try origin+1 and stop. 13 Jan carries nothing, so the feria (Lo) is the first admissible day. *) let blocker_a = entry ~month:1 ~day:10 ~slug:"blocker-a" ~rank:Hi1 let transferable = entry ~month:1 ~day:10 ~slug:"transferable" ~rank:Hi1 let blocker_b = entry ~month:1 ~day:11 ~slug:"blocker-b" ~rank:Hi1 let blocker_c = entry ~month:1 ~day:12 ~slug:"blocker-c" ~rank:Hi1 (* RG 97-98: three entries coincide on 1 Feb, spanning both Transfer- disposed ranks so band order and slug order genuinely disagree (Task 6 review finding 2). "collision-winner" and "transfer-hi1" both tie at the BETTER band (Hi1, 5); "transfer-hi2" is at the WORSE band (Hi2, 10). Within the Hi1 tie, slug decides: "collision-winner" < "transfer- hi1", so "collision-winner" keeps 1 Feb. Of the two losers, "transfer-hi1" (band 5) outranks "transfer-hi2" (band 10) -- by BAND, not by slug: "transfer-b" (transfer-hi2's slug) sorts alphabetically *before* "transfer-z" (transfer-hi1's slug). A sort that used slug instead of band, or compared band backwards, would place "transfer-b" on 2 Feb instead of "transfer-z" -- exactly the wrong-order failure mode finding 2 flagged as unreachable in the old two-Hi-rank fixture. 2 and 3 Feb carry nothing of their own, so they are the two admissible days the pair must land on, consecutively, in band order: "transfer-hi1" claims 2 Feb, pushing "transfer-hi2" to 3 Feb. *) let collision_winner = entry ~month:2 ~day:1 ~slug:"collision-winner" ~rank:Hi1 let transfer_hi1 = entry ~month:2 ~day:1 ~slug:"transfer-z" ~rank:Hi1 let transfer_hi2 = entry ~month:2 ~day:1 ~slug:"transfer-b" ~rank:Hi2 let layer_with_collision = Layer.of_entries ~id:"synthetic-with-collision" ~name:"Synthetic sanctoral (with collisions)" [ big_feast; commem_worthy; day_winner; eclipsed; loser_a; loser_b; blocker_a; transferable; blocker_b; blocker_c; collision_winner; transfer_hi1; transfer_hi2 ] 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) (* Full-day accounting through the whole Calendar pipeline (Layer -> Calendar -> Liturgical_day), not just Precedence in isolation: every candidate fed in for 20 Dec 2026 -- the feria plus Fixture's four colliding sanctoral entries -- is accounted for exactly once across observed/commemorations/omitted/transferred_out. Checked as a slug SET (Alcotest.slist), matching test_precedence.ml's own "nothing silently lost" test: a length-only check would pass even if one slug were duplicated into two buckets and another dropped, which this project has shipped before (register finding). "eclipsed" -- the Hi1-rank loser on 20 Dec -- no longer sits in [omitted] here (that was Task 5's honest placeholder, before Task 6 existed to place it): RG 95 gives an I-class loser the right of translation, so it is genuinely gone from this day's own accounting, and its departure is what [transferred_out] records instead. [test_transfer_moves_and_does_not_duplicate] below is what actually pins where it lands. *) let test_full_day_accounting () = let date = mk 2026 12 20 in let d = C.day Fixture.rite Fixture.layer date in let feria_slug = Sl.to_string (Fixture.office date).Cel.slug in let bucketed = (Sl.to_string d.LD.observed.Cel.slug :: List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.commemorations) @ List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.omitted in Alcotest.(check (slist string compare)) "every non-transferred candidate appears exactly once" [ feria_slug; "day-winner"; "loser-a"; "loser-b" ] bucketed; (* Identity within [omitted]: "loser-a"/"loser-b" -- the ones Precedence's own [admit] dropped for exceeding the commemoration limit, not RG 96-98 translation -- must carry that specific reason. Without this, a bug that dropped [resolution.omitted]'s own reasons would still pass the slug-set check above. *) let reason_of slug = d.LD.omitted |> List.find (fun (c, _) -> Sl.to_string c.Cel.slug = slug) |> snd in Alcotest.(check string) "loser-a carries Precedence's own admission-limit reason" "omitted: admission limit reached" (reason_of "loser-a"); (* Not "eclipsed is absent from bucketed" -- the [slist] check just above already guarantees that (a 5-element set would fail it), so re-asserting absence from the same list would be checking something already proven, not something new. What IS new here: this day positively records that a transfer happened, via a different field entirely. *) Alcotest.(check bool) "20 Dec records that something transferred out" true (d.LD.transferred_out <> []) (* Task 6's placement pass (RG 96-98), properties 1 and 2: a transferred celebration appears exactly once in the whole year -- transfer moves, not duplicates -- and [transferred_in]/[transferred_out] are set on the two ends of the move and point at each other. "transferable" is impeded on 10 Jan by "blocker-a" (same band, tie-broken by slug), and 11-12 Jan are also occupied by their own uncontested Hi1 entries, so this also proves the search walks past more than one ineligible day rather than only trying origin+1. *) let test_transfer_moves_and_does_not_duplicate () = let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in let occurrences = Array.to_list days |> List.filter (fun d -> Sl.to_string d.LD.observed.Cel.slug = "transferable") in Alcotest.(check int) "appears exactly once" 1 (List.length occurrences); let landed = List.hd occurrences in Alcotest.(check string) "lands on the first day past the blocked run (13 Jan 2027)" "2027-01-13" (D.to_iso8601 landed.LD.date); Alcotest.(check bool) "marked as transferred in" true (landed.LD.transferred_in <> None); Alcotest.(check string) "the arriving celebration is itself \"transferable\"" "transferable" (match landed.LD.transferred_in with | Some c -> Sl.to_string c.Cel.slug | None -> ""); (* Located by its own known origin date, not by "the first day with transferred_out <> []" -- layer_with_collision has more than one day that transfers something out (20 Dec's "eclipsed", 1 Feb's two losers), so that would silently pick up whichever happens to sort first in the array rather than proving THIS origin points at THIS landing. Its own origin has exactly one departure -- unlike 1 Feb below -- so a single pair pins it. *) let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2027 1 10) = 0) in Alcotest.(check int) "exactly one departure recorded at the origin" 1 (List.length origin.LD.transferred_out); let departed_cel, departed_to = List.hd origin.LD.transferred_out in Alcotest.(check string) "the departed celebration is \"transferable\"" "transferable" (Sl.to_string departed_cel.Cel.slug); Alcotest.(check string) "it points at the landing date" (D.to_iso8601 landed.LD.date) (D.to_iso8601 departed_to) (* Property 3: RG 97-98's ordering, genuinely by band (Task 6 review finding 2) -- see the [layer_with_collision] comment for how the fixture is built so band order and slug order actively disagree here: "transfer-hi1" (slug "transfer-z", band 5) must claim 2 Feb before "transfer-hi2" (slug "transfer-b", band 10), even though "transfer-b" sorts alphabetically first. Checked by DATE, not by "b landed one day after a" -- Task 5's review flagged exactly that style of check as satisfiable by construction (an Array.init built from add_days would pass it trivially); asserting the literal landing dates independently is what actually exercises the placement order. *) let test_two_colliding_transferables_land_in_band_order () = let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in let observed_on date = Array.to_list days |> List.find (fun d -> D.compare d.LD.date date = 0) |> fun d -> Sl.to_string d.LD.observed.Cel.slug in Alcotest.(check string) "collision-winner keeps 1 Feb" "collision-winner" (observed_on (mk 2027 2 1)); Alcotest.(check string) "higher-band loser (transfer-z, Hi1) claims 2 Feb first" "transfer-z" (observed_on (mk 2027 2 2)); Alcotest.(check string) "lower-band loser (transfer-b, Hi2) is pushed to 3 Feb" "transfer-b" (observed_on (mk 2027 2 3)); let count slug = Array.to_list days |> List.filter (fun d -> Sl.to_string d.LD.observed.Cel.slug = slug) |> List.length in Alcotest.(check int) "transfer-z appears exactly once in the year" 1 (count "transfer-z"); Alcotest.(check int) "transfer-b appears exactly once in the year" 1 (count "transfer-b") (* Task 6 review finding 1: RG 97-98 says coinciding I-class feasts transfer "in order" -- plural -- so 1 Feb's origin must record BOTH departures ("transfer-z" -> 2 Feb, "transfer-b" -> 3 Feb), not just one. The original [Date.t option] could only ever hold one; with three entries colliding on the same date it silently dropped whichever [Hashtbl.iter] visited last, which depends on OCaml's hash seed (OCAMLRUNPARAM=R) -- an environment read in a kernel whose invariants forbid one. Sorting both sides before comparing makes this assertion itself independent of [transferred_out]'s own (now canonicalised, but not part of the contract) internal order. *) let test_origin_records_every_departure () = let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2027 2 1) = 0) in let departures = origin.LD.transferred_out |> List.map (fun (c, target) -> (Sl.to_string c.Cel.slug, D.to_iso8601 target)) |> List.sort compare in Alcotest.(check (list (pair string string))) "both losers' departures are recorded, order-independently" (List.sort compare [ ("transfer-z", "2027-02-02"); ("transfer-b", "2027-02-03") ]) departures (* Task 6 review finding 3: a rite whose [transfer_target] names a date outside the liturgical year's own [start, stop] must not make the candidate vanish. "eclipsed" is impeded on 20 Dec as usual, but this rite's search jumps 5000 days forward -- far past [stop] -- instead of walking to the next admissible day. It must never become [observed] anywhere in the array (there is nowhere in the array for it to land), and its origin must record the specific out-of-range reason, not the generic non-convergence one (this placement decides on round 1; the round guard is never even approached). *) let test_transfer_target_outside_year_is_recorded_not_lost () = let stray_rite = { Fixture.rite with Rite.transfer_target = (fun _ origin _ -> D.add_days origin 5000) } in let days = C.year stray_rite Fixture.layer 2026 in let observed_anywhere = Array.to_list days |> List.exists (fun d -> Sl.to_string d.LD.observed.Cel.slug = "eclipsed") in Alcotest.(check bool) "never becomes observed anywhere in the year" false observed_anywhere; let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2026 12 20) = 0) in let reason_of slug = origin.LD.omitted |> List.find (fun (c, _) -> Sl.to_string c.Cel.slug = slug) |> snd in Alcotest.(check string) "recorded with the out-of-range reason, not silently dropped" "omitted: transfer target falls outside the liturgical year (RG 96)" (reason_of "eclipsed") (* Termination is a correctness requirement (brief): a rite whose [transfer_target] always answers with the impeded day itself (never strictly forward, so the pass can never reach a fixed point) must not hang the computation. It has to hit [max_transfer_rounds] and come back with the stuck candidate recorded as omitted -- not dropped, not looping forever. Using plain [Fixture.layer] (20 Dec's "eclipsed" is the stuck candidate) is enough; this is about the guard firing, not about any particular collision shape. *) let test_transfer_guard_records_failure_instead_of_looping () = let broken_rite = { Fixture.rite with Rite.transfer_target = (fun _ origin _ -> origin) } in let days = C.year broken_rite Fixture.layer 2026 in let stuck = Array.to_list days |> List.exists (fun d -> List.exists (fun (_, reason) -> reason = "omitted: transfer placement did not converge within max_transfer_rounds (RG 96-98)") d.LD.omitted) in Alcotest.(check bool) "non-convergence is recorded rather than silently dropped or hung" true stuck (* ef-major-litanies task, fix round 1 (F1) -- a regression test for a THIRD settlement channel `build_day`'s own `settled_at` had to learn to recognise: a transferred candidate that reaches its target and is then CAPPED OUT there by the target day's own RG 111 admission-count limit (not `observed`, not surviving as a `commemoration` -- the two channels the first version of this fix checked), rather than settling cleanly. Missing it reproduces the exact original bug ONE LEVEL FURTHER OUT: the origin wrongly reports the transferred candidate as `unconverged_reason`, even though placement genuinely converged. Unreachable on real EF data ALONE (the Major Litanies, RG 80, are the only privileged `Commemoration_only` candidate real data carries, and no second one can ever coincide with Easter+2) -- reproduced here the same way the fix-round review did: one synthetic privileged `Commemoration_only` candidate, added directly to the REAL EF layer (not a hand-built synthetic rite -- this bug is about the real Litanies candidate's own real transfer, so the real rite is the honest fixture), on the real Litanies' own real 2011 transfer target (26 April -- Easter 2011 = 24 April, so 25 April is Easter Monday, RG 80's second trigger, landing on Easter+2 = 26 April), with a slug ("aaa-probe") sorting ahead of "major-litanies" so it wins {!Rite_ef.Precedence_ef.admit}'s Class1 "one privileged commemoration only" selection there, capping the Litanies out. *) let real_ef_layer_for_transfer_probes = match Colitur_kernel.Layer.load Rite_ef.Vocab_ef.rank_of_sexp "../data/ef/sanctoral.sexp" with | Error e -> failwith ("../data/ef/sanctoral.sexp: " ^ e) | Ok layer -> ( match Colitur_kernel.Overlay.load Rite_ef.Vocab_ef.rank_of_sexp "../data/ef/adjustments.sexp" with | Error e -> failwith ("../data/ef/adjustments.sexp: " ^ e) | Ok overlay -> let layer, diagnostics = Colitur_kernel.Overlay.apply layer overlay in if diagnostics <> [] then failwith "unexpected overlay diagnostics loading the real EF layer"; layer) (* [Rite_ef.context] takes [~lectionary] (fix round 1, coordinator review) -- caller-supplied, same as the sanctoral layer above. *) let real_ef_lectionary_for_transfer_probes = match Colitur_kernel.Lectionary.load "../data/ef/lectionary.sexp" with | Error e -> failwith ("../data/ef/lectionary.sexp: " ^ e) | Ok l -> l (* The Commons (data/ef/commons.sexp) travel the same caller-supplied seam as the lectionary above, and [~commons] is required rather than defaulted so that no caller can silently run with none -- nothing in layers 3-5 compares reading citations, so a rite quietly missing its Commons would be invisible. Loaded here even where this file asserts nothing about readings, so that the rite under test is the same one bin/main.ml assembles. *) let real_ef_commons_for_transfer_probes = match Rite_ef.Lectionary_ef.Commons.load "../data/ef/commons.sexp" with | Error e -> failwith ("../data/ef/commons.sexp: " ^ e) | Ok c -> c let test_transferred_commemoration_only_capped_out_at_target_settles_cleanly () = let probe_date = match Colitur_kernel.Date_spec.fixed ~month:4 ~day:26 with Ok d -> d | Error e -> failwith e in let probe = { Colitur_kernel.Layer.date = probe_date; cel = Cel.make ~slug:(Sl.of_string_exn "aaa-probe") ~rank:Rite_ef.Vocab_ef.Class1 ~status:Cel.Commemoration_only ~colour:Colitur_kernel.Colour.White ~subject:Colitur_kernel.Subject.Saint ~layer:"synthetic-probe" () } in let augmented_layer = Colitur_kernel.Layer.set real_ef_layer_for_transfer_probes probe in (* Liturgical year "2010" (Advent 2010 -- eve of Advent 2011) covers both 25 and 26 April 2011. *) let year = C.year (Rite_ef.context ~lectionary:real_ef_lectionary_for_transfer_probes ~commons:real_ef_commons_for_transfer_probes) augmented_layer 2010 in let find_date target = match Array.to_list year |> List.find_opt (fun d -> D.compare d.LD.date target = 0) with | Some d -> d | None -> failwith "date not found in resolved year" in let origin = find_date (mk 2011 4 25) and target = find_date (mk 2011 4 26) in let slug_s (c : Rite_ef.Vocab_ef.rank Cel.t) = Sl.to_string c.Cel.slug in Alcotest.(check string) "2011-04-25 is Easter Monday, RG80's second trigger" "ef-easter-1-monday" (slug_s origin.LD.observed); let omitted_s d = List.map (fun (c, r) -> (slug_s c, r)) d.LD.omitted in Alcotest.(check (list (pair string string))) "origin: major-litanies is NOT in [omitted] at all -- it \ genuinely, cleanly transferred away, no false 'did not converge'" [] (List.filter (fun (s, _) -> s = "major-litanies") (omitted_s origin)); let contains_substring s ~needle = let ls = String.length s and ln = String.length needle in let rec at i = i + ln <= ls && (String.sub s i ln = needle || at (i + 1)) in ln = 0 || at 0 in Alcotest.(check (list (pair string string))) "origin: no [omitted] entry anywhere claims non-convergence \ (the exact regression this test guards against, stated directly rather than only via the slug check \ above)" [] (List.filter (fun (_, r) -> contains_substring r ~needle:"did not converge") (omitted_s origin)); Alcotest.(check (list string)) "origin: [transferred_out] still correctly names major-litanies -> target" [ "major-litanies->2011-04-26" ] (List.map (fun (c, d) -> Printf.sprintf "%s->%s" (slug_s c) (D.to_iso8601 d)) origin.LD.transferred_out); Alcotest.(check (list string)) "target: aaa-probe wins the Class1 privileged slot (sorts ahead of \ major-litanies at the tied [unclassified] band)" [ "aaa-probe" ] (List.map (fun (c, _) -> slug_s c) target.LD.commemorations); Alcotest.(check bool) "target: major-litanies is capped out into [omitted] there, with the REAL \ admission-limit reason, not lost and not mislabelled" true (List.mem ("major-litanies", "omitted: admission limit reached") (List.map (fun (c,r) -> (slug_s c, r)) target.LD.omitted)) 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; Alcotest.test_case "full day accounting" `Quick test_full_day_accounting; Alcotest.test_case "transfer moves and does not duplicate" `Quick test_transfer_moves_and_does_not_duplicate; Alcotest.test_case "two colliding transferables land in band order" `Quick test_two_colliding_transferables_land_in_band_order; Alcotest.test_case "origin records every departure" `Quick test_origin_records_every_departure; Alcotest.test_case "transfer target outside year is recorded not lost" `Quick test_transfer_target_outside_year_is_recorded_not_lost; Alcotest.test_case "transfer guard records failure instead of looping" `Quick test_transfer_guard_records_failure_instead_of_looping; Alcotest.test_case "ef-major-litanies fix round 1 (F1): a transferred candidate capped out at its own target settles \ cleanly, no false 'did not converge'" `Quick test_transferred_commemoration_only_capped_out_at_target_settles_cleanly ] )