aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/kernel/calendar.ml93
-rw-r--r--lib/kernel/calendar.mli45
-rw-r--r--test/test_calendar.ml172
-rw-r--r--test/test_colitur.ml3
4 files changed, 312 insertions, 1 deletions
diff --git a/lib/kernel/calendar.ml b/lib/kernel/calendar.ml
new file mode 100644
index 0000000..fd23377
--- /dev/null
+++ b/lib/kernel/calendar.ml
@@ -0,0 +1,93 @@
+(* Resolution across a whole liturgical year. See calendar.mli for the
+ architectural rationale (why [year] is the primitive and [day] derived). *)
+
+(* The kernel's domain floor and ceiling (Date.make's documented 1583..9999
+ bound). Both are always constructible -- in-range by definition -- so
+ neither of these can itself raise. *)
+let domain_min_date =
+ match Date.make ~year:1583 ~month:1 ~day:1 with Ok d -> d | Error e -> failwith e
+
+let domain_max_date =
+ match Date.make ~year:9999 ~month:12 ~day:31 with Ok d -> d | Error e -> failwith e
+
+(* [start, stop] for the liturgical year opening in civil year [y], clamped at
+ both ends of the domain rather than calling [rite.year_start] on a civil
+ year outside 1583..9999.
+
+ Top: at [y] = 9999, [rite.year_start (y + 1)] would ask for civil year
+ 10000 -- out of Date's domain (Plan 2 shipped exactly this bug in
+ Validate). Clamp [stop] to 31 December 9999 instead: the final liturgical
+ year comes back truncated, not un-computable.
+
+ Bottom: symmetric case, reachable only through [day] below. A date in
+ civil year 1583 before that year's own [rite.year_start] genuinely belongs
+ to the liturgical year that opened in civil year 1582 for an
+ Advent-anchored rite -- but [rite.year_start 1582] is equally out of
+ domain. [day] only ever decrements a valid date's own (in-domain) civil
+ year by at most one, so [y] = 1582 is the sole way this branch is reached.
+ Clamp [start] to 1 January 1583: "year 1582" becomes the truncated
+ stretch from the domain floor up to the day before [rite.year_start 1583],
+ which is exactly the sliver a date there needs. *)
+let year_bounds (rite : ('s, 'r) Rite.t) (y : int) : Date.t * Date.t =
+ let start = if y < 1583 then domain_min_date else rite.Rite.year_start y in
+ let stop =
+ if y >= 9999 then domain_max_date else Date.add_days (rite.Rite.year_start (y + 1)) (-1)
+ in
+ (start, stop)
+
+(* RG 91's contest for one date: the temporal office against every sanctoral
+ entry whose Date_spec resolves to it. [Layer.on_date] is keyed on exactly
+ (month, day), which for a [Fixed] spec -- the only form Plan 2 ships -- is
+ the same test as resolving the spec against [date]'s own year and
+ comparing, so no separate filter is needed here. *)
+let resolve_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (date : Date.t) :
+ ('s, 'r) Liturgical_day.t =
+ let temporal = rite.Rite.temporal date in
+ let temporal_candidate =
+ { Precedence.cel = temporal.Temporal.office; origin = Precedence.Temporal }
+ in
+ let sanctoral =
+ Layer.on_date idx ~month:(Date.month date) ~day:(Date.day date)
+ |> List.map (fun (e : 'r Layer.entry) ->
+ { Precedence.cel = e.Layer.cel; origin = Precedence.Sanctoral })
+ in
+ let ctx = { Precedence.date; season = temporal.Temporal.season; weekday = temporal.Temporal.weekday } in
+ let resolution = Precedence.resolve rite.Rite.rules ctx ~temporal:temporal_candidate ~sanctoral in
+ (* [resolution.deferred] (RG 96-98 transfer candidates) and
+ [resolution.omitted] (yielded/admission-limit losers) have no field to
+ land in on Liturgical_day.t yet, so both are simply absent from today's
+ result -- deliberately incomplete for a deferred candidate, which is
+ thereby neither observed nor commemorated here, and not yet placed on
+ any later day either ("deferred: transfer placement not yet implemented
+ (Task 6)"). Task 6's fixed-point pass closes this gap. *)
+ {
+ Liturgical_day.date;
+ rite = rite.Rite.id;
+ temporal;
+ observed = resolution.Precedence.observed.Precedence.cel;
+ commemorations =
+ List.map (fun (c, p) -> (c.Precedence.cel, p)) resolution.Precedence.commemorations;
+ transferred_in = None;
+ transferred_out = None;
+ citations = [];
+ }
+
+let year (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (y : int) :
+ ('s, 'r) Liturgical_day.t array =
+ let idx = Layer.index_by_date layer in
+ let start, stop = year_bounds rite y in
+ (* [max 0]: defends [Array.init] against a negative length, which would
+ otherwise arise for a rite whose [year_start] lands exactly on the
+ domain floor (start clamps to the same date, giving [stop] a day
+ before it). Not reachable through [day] -- see calendar.mli -- but
+ [year] is public, and a direct out-of-contract call must not raise
+ either. *)
+ let n = max 0 (Date.to_rata stop - Date.to_rata start + 1) in
+ Array.init n (fun i -> resolve_day rite idx (Date.add_days start i))
+
+let day (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (date : Date.t) :
+ ('s, 'r) Liturgical_day.t =
+ let cy = Date.year date in
+ let y = if Date.compare date (rite.Rite.year_start cy) >= 0 then cy else cy - 1 in
+ let start, _ = year_bounds rite y in
+ (year rite layer y).(Date.to_rata date - Date.to_rata start)
diff --git a/lib/kernel/calendar.mli b/lib/kernel/calendar.mli
new file mode 100644
index 0000000..50ff8f8
--- /dev/null
+++ b/lib/kernel/calendar.mli
@@ -0,0 +1,45 @@
+(** Resolution across a whole liturgical year (spec ยง2.4).
+
+ Transfers make per-date resolution impossible to do correctly: resolving
+ 25 March can push a feast onto 26 March, and RG 97-98 has coinciding
+ I-class feasts transfer in table order, which needs global knowledge of
+ the whole year. So [year] is the primitive -- it resolves every date in
+ one pass -- and [day] is derived: it finds the liturgical year containing
+ a date and indexes into it. Both are pure; neither caches.
+
+ This module resolves each day's temporal-vs-sanctoral contest but does
+ not yet place deferred transfers (RG 96-98): a losing candidate the
+ rite's rules send to [Precedence.Transfer] is absent from the result
+ entirely on this pass -- not observed, not commemorated, and
+ [transferred_in]/[transferred_out] both stay [None] everywhere. Task 6
+ adds the fixed-point placement pass that closes this gap. *)
+
+(** [year rite layer y] resolves every day of the liturgical year that opens
+ in civil year [y]: from [rite.year_start y] through the day before
+ [rite.year_start (y + 1)], inclusive of both ends.
+
+ Total over 1583..9999, including the boundary years:
+ - At [y] = 9999, [rite.year_start (y + 1)] would ask for civil year
+ 10000, out of {!Date}'s domain (this is the bug Plan 2 shipped in
+ [Validate] and later fixed). The end of the walk clamps to 31 December
+ 9999 instead of computing that call; the returned year comes back
+ truncated to whatever the rite's own temporal cycle covers between
+ [rite.year_start 9999] and the last day of that civil year, not
+ un-computable.
+ - Symmetrically, [y] < 1583 clamps the start of the walk to 1 January
+ 1583 instead of calling [rite.year_start y] on an out-of-domain civil
+ year. [year] is never called this way directly by anything in this
+ module; {!day} is the only caller that can reach [y] = 1582 (one below
+ the floor, never lower), when the date it was asked about sits in civil
+ year 1583 before that year's own [rite.year_start] -- i.e. the sliver
+ whose true liturgical year opened in civil year 1582, which the domain
+ cannot represent. Calling [year] with such a [y] directly is also safe:
+ it returns exactly that truncated sliver. *)
+val year : ('s, 'r) Rite.t -> 'r Layer.t -> int -> ('s, 'r) Liturgical_day.t array
+
+(** [day rite layer date] finds the liturgical year containing [date] -- the
+ year [y] with [rite.year_start y <= date < rite.year_start (y + 1)] --
+ and returns its slot for [date]. Recomputes that whole year on every
+ call: pure, no cache, no mutable state. Acceptable cost for the natural
+ usage (dump a year, sweep years for validation), which pays it once. *)
+val day : ('s, 'r) Rite.t -> 'r Layer.t -> Date.t -> ('s, 'r) Liturgical_day.t
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 ] )
diff --git a/test/test_colitur.ml b/test/test_colitur.ml
index 08282e6..a97e35c 100644
--- a/test/test_colitur.ml
+++ b/test/test_colitur.ml
@@ -2,4 +2,5 @@
let () =
Alcotest.run "colitur"
[ Test_date.suite; Test_computus.suite; Test_colour.suite; Test_slug.suite; Test_names.suite;
- Test_overlay.suite; Test_temporal_ef.suite; Test_validate.suite; Test_precedence.suite ]
+ Test_overlay.suite; Test_temporal_ef.suite; Test_validate.suite; Test_precedence.suite;
+ Test_calendar.suite ]
generated by cgit v1.3 (git 2.53.0) at 2026-09-19 10:13:26 +0000