From 57322e766a0ece579dafcddcfe2572676a98fca8 Mon Sep 17 00:00:00 2001 From: Lukasz Kasprzak Date: Tue, 11 Aug 2026 11:37:32 +0200 Subject: kernel: Names, Citation and Date_spec Names is an open language-keyed assoc kept in canonical order so equal name sets serialise identically. Citation carries references only, never text. Date_spec ships the one form the EF sanctoral needs; 29 February is constructible and resolves to None in common years. --- lib/kernel/citation.ml | 33 ++++++++++++++++++++++++++++ lib/kernel/citation.mli | 12 +++++++++++ lib/kernel/date_spec.ml | 53 +++++++++++++++++++++++++++++++++++++++++++++ lib/kernel/date_spec.mli | 12 +++++++++++ lib/kernel/names.ml | 31 +++++++++++++++++++++++++++ lib/kernel/names.mli | 20 +++++++++++++++++ test/test_colitur.ml | 2 +- test/test_names.ml | 56 ++++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 218 insertions(+), 1 deletion(-) create mode 100644 lib/kernel/citation.ml create mode 100644 lib/kernel/citation.mli create mode 100644 lib/kernel/date_spec.ml create mode 100644 lib/kernel/date_spec.mli create mode 100644 lib/kernel/names.ml create mode 100644 lib/kernel/names.mli create mode 100644 test/test_names.ml diff --git a/lib/kernel/citation.ml b/lib/kernel/citation.ml new file mode 100644 index 0000000..a819040 --- /dev/null +++ b/lib/kernel/citation.ml @@ -0,0 +1,33 @@ +(* Scripture references only -- never scripture text (spec §1: that is lectio's + job). *) +type part = First | Psalm | Second | Gospel | Tract | Alleluia | Sequence +[@@deriving sexp] + +let all_parts = [ First; Psalm; Second; Gospel; Tract; Alleluia; Sequence ] + +let part_to_string = function + | First -> "first" | Psalm -> "psalm" | Second -> "second" | Gospel -> "gospel" + | Tract -> "tract" | Alleluia -> "alleluia" | Sequence -> "sequence" + +let part_of_string = function + | "first" -> Some First | "psalm" -> Some Psalm | "second" -> Some Second + | "gospel" -> Some Gospel | "tract" -> Some Tract | "alleluia" -> Some Alleluia + | "sequence" -> Some Sequence | _ -> None + +type t = { part : part; reference : string } + +let sexp_of_t { part; reference } = + Sexplib0.Sexp.List [ + Sexplib0.Sexp_conv.sexp_of_string "part"; + sexp_of_part part; + Sexplib0.Sexp_conv.sexp_of_string "reference"; + Sexplib0.Sexp_conv.sexp_of_string reference + ] + +let t_of_sexp sexp = + match sexp with + | Sexplib0.Sexp.List [ _; part_sexp; _; ref_sexp ] -> + let part = part_of_sexp part_sexp in + let reference = Sexplib0.Sexp_conv.string_of_sexp ref_sexp in + { part; reference } + | _ -> Sexplib0.Sexp_conv.of_sexp_error "Citation.t_of_sexp: expected record format" sexp diff --git a/lib/kernel/citation.mli b/lib/kernel/citation.mli new file mode 100644 index 0000000..74cd639 --- /dev/null +++ b/lib/kernel/citation.mli @@ -0,0 +1,12 @@ +(** A scripture *reference* (e.g. ["Jn 3:16"]), never scripture text. *) +type part = First | Psalm | Second | Gospel | Tract | Alleluia | Sequence +[@@deriving sexp] + +val all_parts : part list +val part_to_string : part -> string +val part_of_string : string -> part option + +type t = { part : part; reference : string } [@@deriving sexp] + +val sexp_of_t : t -> Sexplib0.Sexp.t +val t_of_sexp : Sexplib0.Sexp.t -> t diff --git a/lib/kernel/date_spec.ml b/lib/kernel/date_spec.ml new file mode 100644 index 0000000..1d0da00 --- /dev/null +++ b/lib/kernel/date_spec.ml @@ -0,0 +1,53 @@ +(* 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. *) +type t = Fixed of { month : int; day : int } + +(* Leap-year maximum, so 29 February is constructible; it simply does not + resolve in a common year. *) +let max_day = function + | 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31 + | 4 | 6 | 9 | 11 -> 30 + | 2 -> 29 + | _ -> 0 + +let fixed ~month ~day = + if month < 1 || month > 12 then Error (Printf.sprintf "date_spec: month %d out of range 1..12" month) + else if day < 1 || day > max_day month then + Error (Printf.sprintf "date_spec: day %d out of range for month %d" day month) + else Ok (Fixed { month; day }) + +let resolve t ~year = + match t with + | Fixed { month; day } -> Result.to_option (Date.make ~year ~month ~day) + +let sexp_of_t = function + | Fixed { month; day } -> + Sexplib0.Sexp.List [ + Sexplib0.Sexp_conv.sexp_of_string "Fixed"; + Sexplib0.Sexp.List [ + Sexplib0.Sexp.List [ + Sexplib0.Sexp_conv.sexp_of_string "month"; + Sexplib0.Sexp_conv.sexp_of_int month + ]; + Sexplib0.Sexp.List [ + Sexplib0.Sexp_conv.sexp_of_string "day"; + Sexplib0.Sexp_conv.sexp_of_int day + ] + ] + ] + +let t_of_sexp sexp = + match sexp with + | Sexplib0.Sexp.List [ + Sexplib0.Sexp.Atom "Fixed"; + Sexplib0.Sexp.List [ + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "month"; month_sexp ]; + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "day"; day_sexp ] + ] + ] -> + let month = Sexplib0.Sexp_conv.int_of_sexp month_sexp in + let day = Sexplib0.Sexp_conv.int_of_sexp day_sexp in + Fixed { month; day } + | _ -> Sexplib0.Sexp_conv.of_sexp_error "Date_spec.t_of_sexp: expected Fixed record format" sexp diff --git a/lib/kernel/date_spec.mli b/lib/kernel/date_spec.mli new file mode 100644 index 0000000..600f1eb --- /dev/null +++ b/lib/kernel/date_spec.mli @@ -0,0 +1,12 @@ +(** A sanctoral entry's date expression. *) +type t = Fixed of { month : int; day : int } [@@deriving sexp] + +val sexp_of_t : t -> Sexplib0.Sexp.t +val t_of_sexp : Sexplib0.Sexp.t -> t + +(** Validates against the leap-year maximum, so 29 February is constructible. *) +val fixed : month:int -> day:int -> (t, string) result + +(** [None] when the spec does not occur in that year (29 February in a common + year) or falls outside the supported domain. *) +val resolve : t -> year:int -> Date.t option diff --git a/lib/kernel/names.ml b/lib/kernel/names.ml new file mode 100644 index 0000000..5f433ce --- /dev/null +++ b/lib/kernel/names.ml @@ -0,0 +1,31 @@ +(* Celebration names by language. An open assoc list rather than a fixed record, + so an overlay can add a language purely as data (spec §2.1). Kept sorted by + language code so sexp output is byte-stable. *) +type t = (Lang.t * string) list + +let empty = [] +let canonical t = List.sort (fun (a, _) (b, _) -> Lang.compare a b) t +let remove t lang = List.filter (fun (l, _) -> not (Lang.equal l lang)) t +let set t lang name = canonical ((lang, name) :: remove t lang) +let of_list l = List.fold_left (fun acc (lang, name) -> set acc lang name) empty l +let find t lang = List.find_map (fun (l, n) -> if Lang.equal l lang then Some n else None) t +let rec find_first t = function + | [] -> None + | lang :: rest -> ( match find t lang with Some n -> Some n | None -> find_first t rest) +let to_list t = t + +let sexp_of_t t = + Sexplib0.Sexp_conv.sexp_of_list (fun (lang, name) -> + Sexplib0.Sexp.List [ Lang.sexp_of_t lang; Sexplib0.Sexp_conv.sexp_of_string name ]) + t + +let t_of_sexp sexp = + let list = Sexplib0.Sexp_conv.list_of_sexp (fun sexp -> + match sexp with + | Sexplib0.Sexp.List [ lang_sexp; name_sexp ] -> + let lang = Lang.t_of_sexp lang_sexp in + let name = Sexplib0.Sexp_conv.string_of_sexp name_sexp in + (lang, name) + | _ -> Sexplib0.Sexp_conv.of_sexp_error "Names.t_of_sexp: expected [lang_sexp name_sexp]" sexp) + sexp in + canonical list diff --git a/lib/kernel/names.mli b/lib/kernel/names.mli new file mode 100644 index 0000000..567ce2e --- /dev/null +++ b/lib/kernel/names.mli @@ -0,0 +1,20 @@ +(** Celebration names keyed by language. The language set is open; entries are + kept sorted by language code, so equal name sets have equal sexp forms. *) +type t = (Lang.t * string) list [@@deriving sexp] + +val sexp_of_t : t -> Sexplib0.Sexp.t +val t_of_sexp : Sexplib0.Sexp.t -> t + +val empty : t + +(** Canonicalises; on duplicate languages the last entry wins. *) +val of_list : (Lang.t * string) list -> t + +val set : t -> Lang.t -> string -> t +val remove : t -> Lang.t -> t +val find : t -> Lang.t -> string option + +(** [find_first t langs] returns the name for the first language present. *) +val find_first : t -> Lang.t list -> string option + +val to_list : t -> (Lang.t * string) list diff --git a/test/test_colitur.ml b/test/test_colitur.ml index 3341c36..af642d6 100644 --- a/test/test_colitur.ml +++ b/test/test_colitur.ml @@ -1,4 +1,4 @@ (* Aggregating test runner. Per-module suites live in test_.ml. *) let () = Alcotest.run "colitur" - [ Test_date.suite; Test_computus.suite; Test_colour.suite; Test_slug.suite ] + [ Test_date.suite; Test_computus.suite; Test_colour.suite; Test_slug.suite; Test_names.suite ] diff --git a/test/test_names.ml b/test/test_names.ml new file mode 100644 index 0000000..6089b5f --- /dev/null +++ b/test/test_names.ml @@ -0,0 +1,56 @@ +module N = Colitur_kernel.Names +module L = Colitur_kernel.Lang +module C = Colitur_kernel.Citation +module DS = Colitur_kernel.Date_spec +module D = Colitur_kernel.Date + +let lang s = L.of_string_exn s + +let test_names_basics () = + let n = N.of_list [ (lang "pl", "Wielkanoc"); (lang "la", "Pascha") ] in + Alcotest.(check (option string)) "find la" (Some "Pascha") (N.find n (lang "la")); + Alcotest.(check (option string)) "find en" None (N.find n (lang "en")); + Alcotest.(check (option string)) "fallback la then en" + (Some "Pascha") (N.find_first n [ lang "en"; lang "la" ]); + (* canonical order is by language code, so sexp output is byte-stable *) + Alcotest.(check (list string)) "canonical order" [ "la"; "pl" ] + (List.map (fun (l, _) -> L.to_string l) (N.to_list n)) + +let test_names_set_remove () = + let n = N.of_list [ (lang "la", "Pascha") ] in + let n = N.set n (lang "en") "Easter" in + Alcotest.(check (option string)) "set en" (Some "Easter") (N.find n (lang "en")); + let n = N.set n (lang "en") "Easter Sunday" in + Alcotest.(check (option string)) "last writer wins" (Some "Easter Sunday") (N.find n (lang "en")); + let n = N.remove n (lang "en") in + Alcotest.(check (option string)) "removed" None (N.find n (lang "en")) + +let test_citation () = + let c = { C.part = C.Gospel; reference = "Jn 3:16" } in + Alcotest.(check bool) "sexp roundtrip" true (C.t_of_sexp (C.sexp_of_t c) = c); + Alcotest.(check string) "part string" "gospel" (C.part_to_string C.Gospel); + Alcotest.(check bool) "part of_string" true (C.part_of_string "first" = Some C.First) + +let test_date_spec () = + (match DS.fixed ~month:3 ~day:25 with + | Ok ds -> ( + match DS.resolve ds ~year:2026 with + | Some d -> Alcotest.(check string) "resolve" "2026-03-25" (D.to_iso8601 d) + | None -> Alcotest.fail "resolve returned None") + | Error e -> Alcotest.failf "fixed: %s" e); + (* Feb 29 is a legitimate fixed date that simply does not occur every year. *) + (match DS.fixed ~month:2 ~day:29 with + | Ok ds -> + Alcotest.(check bool) "Feb 29 resolves in 2024" true (DS.resolve ds ~year:2024 <> None); + Alcotest.(check bool) "Feb 29 absent in 2026" true (DS.resolve ds ~year:2026 = None) + | Error e -> Alcotest.failf "Feb 29 must be constructible: %s" e); + Alcotest.(check bool) "reject Feb 30" true (Result.is_error (DS.fixed ~month:2 ~day:30)); + Alcotest.(check bool) "reject Apr 31" true (Result.is_error (DS.fixed ~month:4 ~day:31)); + Alcotest.(check bool) "reject month 13" true (Result.is_error (DS.fixed ~month:13 ~day:1)) + +let suite = + ( "Names/Citation/DateSpec", + [ Alcotest.test_case "names basics" `Quick test_names_basics; + Alcotest.test_case "names set/remove" `Quick test_names_set_remove; + Alcotest.test_case "citation" `Quick test_citation; + Alcotest.test_case "date_spec" `Quick test_date_spec ] ) -- cgit v1.3