path: root/test/test_calendar.ml

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

  (* Admits at most one commemoration -- mirrors test_precedence.ml's own
     example and, unlike "admit everything", actually gives the accounting
     test below a genuine Precedence-native omission (distinct from a
     deferred one) to exercise. *)
  let rules : (season, rank) P.rules =
    { P.band; disposition; admit = (fun ~observed:_ cs -> List.filteri (fun i _ -> i < 1) 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

  (* 20 Dec: four sanctoral entries on one date, for the full-accounting test.
     "day-winner" and "eclipsed" tie on band (both Hi, both Sanctoral); ties
     break on slug, so "day-winner" wins and "eclipsed" -- a Hi-rank loser --
     is [Transfer]-disposed, landing in [deferred]. "loser-a" and "loser-b"
     are both Lo, both [Commemorate]-disposed, but [admit] only keeps one:
     the other lands in Precedence's own [omitted] ("admission limit
     reached"), distinct from "eclipsed"'s deferred reason. Four candidates,
     three different fates -- observed, one specific omission reason, two
     more. *)
  let day_winner = entry ~month:12 ~day:20 ~slug:"day-winner" ~rank:Hi
  let eclipsed = entry ~month:12 ~day:20 ~slug:"eclipsed" ~rank:Hi
  let loser_a = entry ~month:12 ~day:20 ~slug:"loser-a" ~rank:Lo
  let loser_b = entry ~month:12 ~day:20 ~slug:"loser-b" ~rank:Lo

  let layer =
    Layer.of_entries ~id:"synthetic" ~name:"Synthetic sanctoral"
      [ big_feast; commem_worthy; day_winner; eclipsed; loser_a; loser_b ]

  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)

(* Full-day accounting through the whole Calendar pipeline (Layer -> Calendar
   -> Liturgical_day), not just Precedence in isolation: every candidate fed
   in for 20 Dec 2026 -- the feria plus Fixture's four colliding sanctoral
   entries -- appears exactly once across observed/commemorations/omitted.
   Checked as a slug SET (Alcotest.slist), matching test_precedence.ml's own
   "nothing silently lost" test: a length-only check would pass even if one
   slug were duplicated into two buckets and another dropped, which this
   project has shipped before (register finding). *)
let test_full_day_accounting () =
  let date = mk 2026 12 20 in
  let d = C.day Fixture.rite Fixture.layer date in
  let feria_slug = Sl.to_string (Fixture.office date).Cel.slug in
  let bucketed =
    (Sl.to_string d.LD.observed.Cel.slug
     :: List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.commemorations)
    @ List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.omitted
  in
  Alcotest.(check (slist string compare)) "every candidate appears exactly once"
    [ feria_slug; "day-winner"; "eclipsed"; "loser-a"; "loser-b" ]
    bucketed;
  (* Identity within [omitted], not just membership: "eclipsed" (a deferred
     transfer candidate, RG 96-98) must carry the deferred reason, not
     Precedence's native "admission limit reached" that "loser-a"/"loser-b"
     -- the ones Precedence itself dropped -- carry. Without this, a bug
     that folded [resolution.deferred] into [omitted] with the wrong reason,
     or dropped [resolution.omitted]'s own reasons, would still pass the
     slug-set check above. *)
  let reason_of slug =
    d.LD.omitted |> List.find (fun (c, _) -> Sl.to_string c.Cel.slug = slug) |> snd
  in
  Alcotest.(check string) "eclipsed carries the deferred reason"
    "deferred: transfer placement not yet implemented (Task 6)" (reason_of "eclipsed");
  Alcotest.(check string) "loser-a carries Precedence's own admission-limit reason"
    "omitted: admission limit reached" (reason_of "loser-a")

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;
      Alcotest.test_case "full day accounting" `Quick test_full_day_accounting ] )