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
|
open Sexplib0.Sexp_conv
(* One calendar layer: a rite's base sanctoral, or any data file with the same
shape. Entries are kept sorted by slug as the canonical form, so equal layers
serialise identically and merge results do not depend on input order. *)
type 'r entry = { date : Date_spec.t; cel : 'r Celebration.t } [@@deriving sexp]
type 'r t = { id : string; name : string; entries : 'r entry list } [@@deriving sexp]
let by_slug a b = Slug.compare a.cel.Celebration.slug b.cel.Celebration.slug
let canonical entries = List.sort by_slug entries
let empty ~id ~name = { id; name; entries = [] }
let of_entries ~id ~name entries = { id; name; entries = canonical entries }
let find t slug = List.find_opt (fun e -> Slug.equal e.cel.Celebration.slug slug) t.entries
let mem t slug = find t slug <> None
let remove t slug =
{ t with entries = List.filter (fun e -> not (Slug.equal e.cel.Celebration.slug slug)) t.entries }
let set t entry =
let t = remove t entry.cel.Celebration.slug in
{ t with entries = canonical (entry :: t.entries) }
(* FIXED entries are year-independent, so their table is built once and keyed
(month, day) -- a full 1583..9999 sweep would otherwise rescan the entry
list for every day.
MOVABLE entries have no such key BY CONSTRUCTION: the same spec lands on a
different (month, day) in different years, so one year-independent table
cannot serve a multi-year span. They are resolved once per civil year in
the span and keyed by rata die instead.
Keeping the two separate, rather than resolving everything per year,
preserves the fixed path exactly as it was -- including the "30 November
counted twice in a 371-day liturgical span" behaviour validate.mli
documents for St Andrew, which falls straight out of querying by (month,
day) and would have to be re-established by hand under a uniform rata-die
index. *)
type 'r index = {
fixed : (int * int, 'r entry list) Hashtbl.t;
movable : (int, 'r entry list) Hashtbl.t; (** keyed by rata die *)
}
let index t ~easter ~years =
(* Filter to the kernel domain BEFORE calling [easter] on anything. A
liturgical year is Advent-anchored, so a caller resolving civil year [y]
legitimately names [y - 1] or [y + 1] -- and at the two edges those are
1582 and 10000, which {!Computus} correctly refuses by raising. Both
edges bit during development (the ceiling via the domain-ceiling test,
the floor via `colitur day 1583`), which is why the guard lives HERE, at
the single point that calls [easter], rather than as a clamp repeated in
every caller. A spec cannot resolve outside 1583..9999 anyway, so
dropping those years loses nothing. *)
let years = List.filter (fun y -> y >= 1583 && y <= 9999) years in
let fixed : (int * int, 'r entry list) Hashtbl.t = Hashtbl.create 512 in
let movable : (int, 'r entry list) Hashtbl.t = Hashtbl.create 32 in
let add tbl k e = Hashtbl.replace tbl k (e :: (try Hashtbl.find tbl k with Not_found -> [])) in
List.iter
(fun e ->
match e.date with
| Date_spec.Fixed { month; day } -> add fixed (month, day) e
| _ ->
(* A spec resolving to nothing in a given year is not an error:
[Date_spec.resolve]'s own [None] means "does not occur this
year", the same contract 29 February has always had. *)
List.iter
(fun year ->
match Date_spec.resolve e.date ~year ~easter:(easter year) with
| Some d -> add movable (Date.to_rata d) e
| None -> ())
years)
t.entries;
Hashtbl.iter (fun k v -> Hashtbl.replace fixed k (canonical v)) fixed;
Hashtbl.iter (fun k v -> Hashtbl.replace movable k (canonical v)) movable;
{ fixed; movable }
let on_date idx date =
let f = try Hashtbl.find idx.fixed (Date.month date, Date.day date) with Not_found -> [] in
let m = try Hashtbl.find idx.movable (Date.to_rata date) with Not_found -> [] in
match m with [] -> f | _ -> canonical (f @ m)
let load rank_of_sexp path =
match Sexplib.Sexp.load_sexp path with
| exception Sys_error msg -> Error msg
(* This sexplib version raises [Failure] for some malformed inputs (e.g. an
unterminated list or string) rather than [Sexplib.Sexp.Parse_error], so a
catch-all here -- placed last among the exception branches -- is what
actually keeps every parse failure inside [Error] instead of escaping. *)
| exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn))
| sexp -> (
match t_of_sexp rank_of_sexp sexp with
| t -> Ok { t with entries = canonical t.entries }
(* [rank_of_sexp] is caller-supplied and may raise anything, not only
[Of_sexp_error] -- mirrors [Overlay.load]'s catch-all, so "never as
an exception" (layer.mli) actually holds. *)
| exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)))
|
