kernel(lectionary): slug-keyed reading citations

Data only, the same shape and discipline as Layer: slug-canonical,
duplicates rejected at construction naming the offending slug, sexp
round-trips. Which slug a day falls back to is a rubric and belongs to the
rite module, so nothing here knows about ferias or Sundays.

4 files changed, 116 insertions, 1 deletions

diff --git a/lib/kernel/lectionary.ml b/lib/kernel/lectionary.ml
new file mode 100644
index 0000000..1da3d1e
--- /dev/null
+++ b/lib/kernel/lectionary.ml
@@ -0,0 +1,33 @@
+open Sexplib0.Sexp_conv
+
+type entry = Slug.t * Citation.t list [@@deriving sexp]
+type t = entry list [@@deriving sexp]
+
+let empty = []
+
+let of_entries es =
+  let sorted = List.stable_sort (fun (a, _) (b, _) -> Slug.compare a b) es in
+  let rec dup = function
+    | (a, _) :: ((b, _) :: _ as rest) ->
+        if Slug.equal a b then Some a else dup rest
+    | _ -> None
+  in
+  match dup sorted with
+  | Some s ->
+      Error (Printf.sprintf "lectionary: duplicate slug %S" (Slug.to_string s))
+  | None -> Ok sorted
+
+let find t s = List.assoc_opt s t
+let mem t s = List.mem_assoc s t
+let entries t = t
+
+let load path =
+  match Sexplib.Sexp.load_sexp path with
+  | exception Sexplib.Sexp.Parse_error e ->
+      Error (Printf.sprintf "lectionary: %s: %s" path e.err_msg)
+  | exception Sys_error e -> Error (Printf.sprintf "lectionary: %s" e)
+  | sexp -> (
+      match t_of_sexp sexp with
+      | exception Sexplib0.Sexp_conv_error.Of_sexp_error (exn, _) ->
+          Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn))
+      | parsed -> of_entries parsed)
diff --git a/lib/kernel/lectionary.mli b/lib/kernel/lectionary.mli
new file mode 100644
index 0000000..1595377
--- /dev/null
+++ b/lib/kernel/lectionary.mli
@@ -0,0 +1,21 @@
+(** Reading citations keyed by liturgical slug (parent spec §2: "keyed by
+    liturgical slug + cycle -> citation set"). Data only: which slug a given
+    day falls back to is a rubric, and lives in the rite module.
+
+    Same discipline as {!Layer}: slug-canonical, validated at construction,
+    sexp round-trips. *)
+type t [@@deriving sexp]
+
+val empty : t
+
+(** Canonically sorts by slug. [Error] on a duplicate slug, naming it --
+    a lectionary with two answers for one day is not a lectionary. *)
+val of_entries : (Slug.t * Citation.t list) list -> (t, string) result
+
+val find : t -> Slug.t -> Citation.t list option
+val mem : t -> Slug.t -> bool
+val entries : t -> (Slug.t * Citation.t list) list
+
+(** Loads from a sexp file. Parse and validation failures come back as
+    [Error], never as an exception. *)
+val load : string -> (t, string) result
diff --git a/test/test_colitur.ml b/test/test_colitur.ml
index 58557aa..66aec59 100644
--- a/test/test_colitur.ml
+++ b/test/test_colitur.ml
@@ -4,4 +4,5 @@ let () =
     [ 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_calendar.suite; Test_precedence_ef.suite; Test_sanctoral_ef.suite; Test_rite_ef.suite;
-      Test_differential.suite; Test_oracle.suite; Test_golden.suite ]
+      Test_differential.suite; Test_oracle.suite; Test_golden.suite;
+      ("lectionary", Test_lectionary.suite) ]
diff --git a/test/test_lectionary.ml b/test/test_lectionary.ml
new file mode 100644
index 0000000..45a01ab
--- /dev/null
+++ b/test/test_lectionary.ml
@@ -0,0 +1,60 @@
+open Colitur_kernel
+
+let slug = Slug.of_string_exn
+let cit part reference = { Citation.part; reference }
+
+let entry s cs = (slug s, cs)
+
+let ok_exn = function Ok x -> x | Error e -> Alcotest.fail e
+
+(* Stdlib-only substring search -- Astring is not among the frozen deps. *)
+let contains_substring ~needle haystack =
+  let hn = String.length needle and hh = String.length haystack in
+  let rec go i = i + hn <= hh && (String.sub haystack i hn = needle || go (i + 1)) in
+  hn = 0 || go 0
+
+let test_find_present () =
+  let l =
+    ok_exn
+      (Lectionary.of_entries
+         [ entry "ef-advent-sunday-1"
+             [ cit Citation.First "Rom 13:11-14"; cit Citation.Gospel "Luke 21:25-33" ] ])
+  in
+  match Lectionary.find l (slug "ef-advent-sunday-1") with
+  | Some [ a; b ] ->
+      Alcotest.(check string) "epistle" "Rom 13:11-14" a.Citation.reference;
+      Alcotest.(check string) "gospel" "Luke 21:25-33" b.Citation.reference
+  | Some _ -> Alcotest.fail "expected exactly two citations"
+  | None -> Alcotest.fail "slug not found"
+
+let test_find_absent () =
+  let l = ok_exn (Lectionary.of_entries []) in
+  Alcotest.(check bool) "absent" true
+    (Lectionary.find l (slug "ef-advent-sunday-1") = None)
+
+let test_duplicate_slug_rejected () =
+  let e = entry "ef-advent-sunday-1" [ cit Citation.First "Rom 13:11-14" ] in
+  match Lectionary.of_entries [ e; e ] with
+  | Ok _ -> Alcotest.fail "duplicate slug must be rejected"
+  | Error msg ->
+      (* Strengthened beyond the brief's "non-empty and contains 'e'" check:
+         the interface doc promises the error names the slug, so assert the
+         offending slug string actually appears in the message. *)
+      Alcotest.(check bool) "names the slug" true
+        (contains_substring ~needle:"ef-advent-sunday-1" msg)
+
+let test_sexp_round_trip () =
+  let l =
+    ok_exn
+      (Lectionary.of_entries
+         [ entry "ef-lent-1-monday"
+             [ cit Citation.First "Ezech 34:11-16"; cit Citation.Gospel "Matt 25:31-46" ] ])
+  in
+  let l' = Lectionary.t_of_sexp (Lectionary.sexp_of_t l) in
+  Alcotest.(check bool) "round trips" true (l = l')
+
+let suite =
+  [ ("find present", `Quick, test_find_present);
+    ("find absent", `Quick, test_find_absent);
+    ("duplicate slug rejected", `Quick, test_duplicate_slug_rejected);
+    ("sexp round-trip", `Quick, test_sexp_round_trip) ]