diff options
Diffstat (limited to 'lib/kernel/date_spec.ml')
| -rw-r--r-- | lib/kernel/date_spec.ml | 120 |
1 files changed, 104 insertions, 16 deletions
diff --git a/lib/kernel/date_spec.ml b/lib/kernel/date_spec.ml index 732f6b1..6b328df 100644 --- a/lib/kernel/date_spec.ml +++ b/lib/kernel/date_spec.ml @@ -1,14 +1,33 @@ open Sexplib0.Sexp_conv -(* How a sanctoral entry expresses its date. Plan 2 ships the only form the EF - 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. *) +(* How a sanctoral entry expresses its date. + + Plan 2 shipped [Fixed] alone, and this file's own header then said + "Sunday-relative and Easter-relative forms arrive with the OF sanctoral". + They arrive here instead, ahead of OF, because two things needed them at + once: user-supplied overlays carrying LOCAL MOVABLE FEASTS (a patronal + feast on "the first Sunday of October" was simply inexpressible), and + ROGATION WEDNESDAY's own commemoration (RG 87/88/89), recorded as + architecturally blocked since 2026-08-13 for exactly one reason -- its + trigger is Easter+38, and there is no (month, day) pair a [Fixed] spec + could anchor to. + + Sunday-relative forms ("the Sunday on or after 2 November") are still NOT + built: no entry in this repository needs one, and the same mechanism adds + them when one does. See + docs/superpowers/specs/2026-08-17-colitur-movable-date-specs-design.md. *) module Repr = struct - type t = Fixed of { month : int; day : int } [@@deriving sexp] + type t = + | Fixed of { month : int; day : int } + | Easter_offset of int + | Nth_weekday of { month : int; nth : int; weekday : Date.weekday } + [@@deriving sexp] end -type t = Repr.t = Fixed of { month : int; day : int } +type t = Repr.t = + | Fixed of { month : int; day : int } + | Easter_offset of int + | Nth_weekday of { month : int; nth : int; weekday : Date.weekday } (* Leap-year maximum, so 29 February is constructible; it simply does not resolve in a common year. *) @@ -24,20 +43,89 @@ let fixed ~month ~day = Error (Printf.sprintf "date_spec: day %d out of range for month %d" day month) else Ok (Fixed { month; day }) -let resolve t ~year = +(* Deliberately generous rather than tight. Septuagesima is Easter-63 and Time + after Pentecost runs well past Easter+180, so a bound that merely LOOKED + precise would reject legitimate specs; a full year either way is the point + past which a spec is certainly a data error rather than a calendar. *) +let easter_offset n = + if n < -365 || n > 365 then + Error (Printf.sprintf "date_spec: easter offset %d is further than a year from Easter" n) + else Ok (Easter_offset n) + +(* [nth] is 1-based forward, or negative from the end (-1 = the last). Zero is + meaningless, and no month has a sixth of any weekday. *) +let nth_weekday ~month ~nth ~weekday = + if month < 1 || month > 12 then Error (Printf.sprintf "date_spec: month %d out of range 1..12" month) + else if nth = 0 then Error "date_spec: nth = 0 is meaningless (1 is the first, -1 the last)" + else if nth < -5 || nth > 5 then + Error (Printf.sprintf "date_spec: nth %d out of range (no month has six of a weekday)" nth) + else Ok (Nth_weekday { month; nth; weekday }) + +(* The domain check on [Easter_offset] is load-bearing, not defensive + decoration: date.mli states plainly that [add_days] is "unbounded total + arithmetic (they may denote a date outside the domain)", so Easter+200 in + 9999 yields a perfectly well-formed [Date.t] that is nonetheless outside + 1583..9999. Returning it would leak an out-of-domain date into a [Layer] + index and from there into resolution. [None] is the same answer 29 February + already gives in a common year: "this spec does not occur". *) +let in_domain d = Date.year d >= 1583 && Date.year d <= 9999 + +let weekday_index = function + | Date.Sun -> 0 + | Date.Mon -> 1 + | Date.Tue -> 2 + | Date.Wed -> 3 + | Date.Thu -> 4 + | Date.Fri -> 5 + | Date.Sat -> 6 + +(* Total: every branch returns [option], and nothing here raises on an in-range + year. *) +let resolve t ~year ~easter = match t with | Fixed { month; day } -> Result.to_option (Date.make ~year ~month ~day) + | Easter_offset n -> + (* [easter] is the caller's Easter for THIS civil year -- the rite + supplies it ({!Rite.t}'s own [easter] field), so a Julian-reckoning + rite is never silently handed a Gregorian date. *) + let d = Date.add_days easter n in + if in_domain d then Some d else None + | Nth_weekday { month; nth; weekday } -> ( + match Date.make ~year ~month ~day:1 with + | Error _ -> None + | Ok first -> + (* [Date.make] is the authority on month length, so no leap rule is + duplicated here: probe downward from 31 for the last day that + actually constructs. Every month has at least 28. *) + let rec last_day d = + if d <= 28 then d else if Result.is_ok (Date.make ~year ~month ~day:d) then d else last_day (d - 1) + in + let days_in_month = last_day 31 in + let offset_to_first = (weekday_index weekday - weekday_index (Date.weekday first) + 7) mod 7 in + let first_occurrence = 1 + offset_to_first in + let count = ((days_in_month - first_occurrence) / 7) + 1 in + (* Negative [nth] counts back from the end: -1 is the last. *) + let index = if nth > 0 then nth else count + nth + 1 in + if index < 1 || index > count then None + else Result.to_option (Date.make ~year ~month ~day:(first_occurrence + ((index - 1) * 7)))) 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. *) + [t_of_sexp] (relocated to [Repr] above) accepts any in-range int, so + [(Fixed (month 13) (day 40))] or [(Nth_weekday (month 10) (nth 0) ...)] + would otherwise deserialise into a spec that silently never resolves -- a + celebration quietly vanishing with no diagnostic. Re-running the value + through the smart constructors closes that gap the same way loaders already + close it for slugs and language codes. + + EVERY variant is re-validated here. Adding one without extending this + function reopens exactly the hole it exists to close, and the failure mode + is invisible: nothing errors, a feast simply never appears. *) 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 + let reject msg = Sexplib0.Sexp_conv.of_sexp_error msg sexp in + match Repr.t_of_sexp sexp with + | Fixed { month; day } -> ( match fixed ~month ~day with Ok t -> t | Error msg -> reject msg) + | Easter_offset n -> ( match easter_offset n with Ok t -> t | Error msg -> reject msg) + | Nth_weekday { month; nth; weekday } -> ( + match nth_weekday ~month ~nth ~weekday with Ok t -> t | Error msg -> reject msg) |