1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
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 ] )
|
