lib/kernel/layer.ml


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

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) }

(* Dates are year-independent, so the index is built once per layer rather than
   once per year -- a full 1583..9999 sweep would otherwise rescan the entry
   list for every day. *)
type 'r by_date = (int * int, 'r entry list) Hashtbl.t

let key = function Date_spec.Fixed { month; day } -> (month, day)

let index_by_date t =
  let tbl : 'r by_date = Hashtbl.create 512 in
  List.iter
    (fun e ->
      let k = key e.date in
      Hashtbl.replace tbl k (e :: (try Hashtbl.find tbl k with Not_found -> [])))
    t.entries;
  (* restore canonical order within each date bucket *)
  Hashtbl.iter (fun k v -> Hashtbl.replace tbl k (canonical v)) tbl;
  tbl

let on_date tbl ~month ~day =
  try Hashtbl.find tbl (month, day) with Not_found -> []

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)))