path: root/test/test_overlay.ml

module L = Colitur_kernel.Layer
module Cel = Colitur_kernel.Celebration
module S = Colitur_kernel.Slug
module DS = Colitur_kernel.Date_spec
module Col = Colitur_kernel.Colour

type rank = Class1 | Class3 [@@deriving sexp]

let slug = S.of_string_exn

let cel ?(rank = Class3) ?(colour = Col.White) ?subject ?names ?citations s =
  Cel.make ~slug:(slug s) ~rank ~colour ?subject ?names ?citations ~layer:"base" ()

let entry ?(month = 1) ?(day = 1) ?rank ?colour ?subject ?names ?citations s =
  { L.date = (match DS.fixed ~month ~day with Ok d -> d | Error e -> failwith e);
    cel = cel ?rank ?colour ?subject ?names ?citations s }

let base () =
  L.of_entries ~id:"base" ~name:"Test base"
    [ entry ~month:1 ~day:5 "telesphorus"; entry ~month:1 ~day:14 "hilary" ]

(* First occurrence only -- used to corrupt one field (the slug atom) of an
   otherwise well-formed serialised layer, without hand-writing the whole
   sexp shape by hand. *)
let replace_first ~sub ~by s =
  let sub_len = String.length sub and s_len = String.length s in
  let rec find i =
    if i + sub_len > s_len then None
    else if String.sub s i sub_len = sub then Some i
    else find (i + 1)
  in
  match find 0 with
  | None -> s
  | Some i -> String.sub s 0 i ^ by ^ String.sub s (i + sub_len) (s_len - i - sub_len)

let with_temp_file f =
  let path = Filename.temp_file "colitur_layer" ".sexp" in
  Fun.protect ~finally:(fun () -> try Sys.remove path with Sys_error _ -> ()) (fun () -> f path)

let test_layer_basics () =
  let l = base () in
  Alcotest.(check bool) "find present" true (L.find l (slug "hilary") <> None);
  Alcotest.(check bool) "find absent" true (L.find l (slug "nobody") = None);
  Alcotest.(check bool) "mem" true (L.mem l (slug "telesphorus"));
  (* canonical order is by slug, so sexp output is byte-stable *)
  Alcotest.(check (list string)) "canonical order" [ "hilary"; "telesphorus" ]
    (List.map (fun e -> S.to_string e.L.cel.Cel.slug) l.L.entries)

let test_layer_index () =
  let idx = L.index_by_date (base ()) in
  Alcotest.(check int) "Jan 14 has one" 1 (List.length (L.on_date idx ~month:1 ~day:14));
  Alcotest.(check int) "Jan 20 has none" 0 (List.length (L.on_date idx ~month:1 ~day:20))

(* Three entries sharing a date, inserted deliberately out of canonical
   (by-slug) order: this is what actually pins accumulation (the bucket must
   hold all three, not overwrite) and deterministic ordering (the bucket must
   come back sorted regardless of insertion order). Entries already inserted
   in sorted order would pass even with the sort dropped. *)
let test_layer_index_same_date () =
  let l =
    L.of_entries ~id:"base" ~name:"Test same-date"
      [ entry ~month:3 ~day:17 "zeta"; entry ~month:3 ~day:17 "alpha"; entry ~month:3 ~day:17 "mu" ]
  in
  let idx = L.index_by_date l in
  let bucket = L.on_date idx ~month:3 ~day:17 in
  Alcotest.(check int) "three entries share Mar 17" 3 (List.length bucket);
  Alcotest.(check (list string)) "bucket sorted by slug" [ "alpha"; "mu"; "zeta" ]
    (List.map (fun e -> S.to_string e.L.cel.Cel.slug) bucket)

let test_layer_sexp () =
  let l = base () in
  let sexp = L.sexp_of_t sexp_of_rank l in
  Alcotest.(check bool) "roundtrip" true (L.t_of_sexp rank_of_sexp sexp = l)

let test_layer_load_success () =
  let l = base () in
  with_temp_file (fun path ->
      let oc = open_out path in
      output_string oc (Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank l));
      close_out oc;
      match L.load rank_of_sexp path with
      | Ok loaded -> Alcotest.(check bool) "round-trip equal" true (loaded = l)
      | Error msg -> Alcotest.failf "expected Ok, got Error %s" msg)

let test_layer_load_missing_file () =
  let path = Filename.temp_file "colitur_layer_missing" ".sexp" in
  Sys.remove path;
  match L.load rank_of_sexp path with
  | Ok _ -> Alcotest.fail "expected Error for a missing file"
  | Error _ -> ()

let test_layer_load_malformed () =
  with_temp_file (fun path ->
      let oc = open_out path in
      (* unterminated list -- sexplib raises Failure here, not Parse_error *)
      output_string oc "((id \"x\") (name \"y\") (entries (";
      close_out oc;
      match L.load rank_of_sexp path with
      | Ok _ -> Alcotest.fail "expected Error for a malformed sexp"
      | Error _ -> ())

let test_layer_load_invalid_slug () =
  let single = L.of_entries ~id:"base" ~name:"Test" [ entry ~month:2 ~day:2 "hilary" ] in
  let text = Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank single) in
  let corrupted = replace_first ~sub:"hilary" ~by:"Bad_Slug!" text in
  with_temp_file (fun path ->
      let oc = open_out path in
      output_string oc corrupted;
      close_out oc;
      match L.load rank_of_sexp path with
      | Ok _ -> Alcotest.fail "expected Error for an invalid slug"
      | Error _ -> ())

let test_layer_load_rank_of_sexp_raises_other_exception () =
  (* Register finding 7: [rank_of_sexp] is caller-supplied and may raise
     anything, not only [Of_sexp_error] -- [layer.mli] promises "never as an
     exception". Before the fix this call did not reach the [Ok]/[Error]
     match at all: [Invalid_argument] escaped [L.load] uncaught, and this
     test would have errored rather than exercised the [Error _ -> ()]
     branch. *)
  let l = base () in
  with_temp_file (fun path ->
      let oc = open_out path in
      output_string oc (Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank l));
      close_out oc;
      let exploding_rank_of_sexp _sexp = invalid_arg "boom" in
      match L.load exploding_rank_of_sexp path with
      | Ok _ -> Alcotest.fail "expected Error, not a successful load"
      | Error _ -> ())

module O = Colitur_kernel.Overlay
module N = Colitur_kernel.Names
module Lang = Colitur_kernel.Lang
module Cit = Colitur_kernel.Citation
module Subj = Colitur_kernel.Subject

let ov id directives = { O.id; directives }

let rank_of l s = match L.find l (slug s) with
  | Some e -> Some e.L.cel.Cel.rank | None -> None

let test_empty_is_identity () =
  let l = base () in
  let l', diags = O.apply l O.empty in
  Alcotest.(check bool) "layer unchanged" true (l' = l);
  Alcotest.(check int) "no diagnostics" 0 (List.length diags)

let test_add_and_suppress () =
  let l = base () in
  let l', _ = O.apply l (ov "o" [ O.Add (entry ~month:2 ~day:2 "candlemas") ]) in
  Alcotest.(check bool) "added" true (L.mem l' (slug "candlemas"));
  let l'', _ = O.apply l' (ov "o" [ O.Suppress (slug "candlemas") ]) in
  Alcotest.(check bool) "suppressed" false (L.mem l'' (slug "candlemas"))

(* Order matters, and this test pins which way. *)
let test_order_matters () =
  let l = base () in
  let add = O.Add (entry ~month:2 ~day:2 "candlemas") in
  let sup = O.Suppress (slug "candlemas") in
  let a, _ = O.apply l (ov "o" [ add; sup ]) in
  Alcotest.(check bool) "add then suppress -> absent" false (L.mem a (slug "candlemas"));
  let b, _ = O.apply l (ov "o" [ sup; add ]) in
  Alcotest.(check bool) "suppress then add -> present" true (L.mem b (slug "candlemas"))

let test_edit_is_field_scoped () =
  let l = base () in
  let before = match L.find l (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  let l', _ = O.apply l (ov "o" [ O.Edit (slug "hilary", [ O.Set_colour Col.Red ]) ]) in
  let after = match L.find l' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check bool) "colour changed" true (after.L.cel.Cel.colour = Col.Red);
  Alcotest.(check bool) "every other field untouched" true
    ({ after with L.cel = { after.L.cel with Cel.colour = before.L.cel.Cel.colour } } = before)

let test_last_writer_wins () =
  let l = base () in
  let l', _ =
    O.apply l (ov "o" [ O.Edit (slug "hilary", [ O.Set_rank Class1 ]);
                        O.Edit (slug "hilary", [ O.Set_rank Class3 ]) ])
  in
  Alcotest.(check bool) "second edit wins" true (rank_of l' "hilary" = Some Class3)

let test_replace () =
  let l = base () in
  (* Replace on an existing slug: the entry is swapped, no diagnostic. *)
  let l', diags =
    O.apply l (ov "o" [ O.Replace (slug "hilary", entry ~month:1 ~day:14 ~rank:Class1 "hilary") ])
  in
  Alcotest.(check int) "no diagnostic when slug present" 0 (List.length diags);
  Alcotest.(check bool) "entry replaced" true (rank_of l' "hilary" = Some Class1);
  (* Replace on an absent slug: diagnostic recorded, but the entry is still
     added -- an overlay must survive a shifted base, not just complain. *)
  let l'', diags' =
    O.apply l (ov "o" [ O.Replace (slug "candlemas", entry ~month:2 ~day:2 "candlemas") ])
  in
  Alcotest.(check int) "one diagnostic when slug absent" 1 (List.length diags');
  Alcotest.(check bool) "entry added anyway" true (L.mem l'' (slug "candlemas"))

let test_edit_set_subject () =
  let l = base () in
  let before = match L.find l (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  let l', _ = O.apply l (ov "o" [ O.Edit (slug "hilary", [ O.Set_subject Subj.Saint ]) ]) in
  let after = match L.find l' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check bool) "subject changed" true (after.L.cel.Cel.subject = Subj.Saint);
  Alcotest.(check bool) "every other field untouched" true
    ({ after with L.cel = { after.L.cel with Cel.subject = before.L.cel.Cel.subject } } = before)

let test_edit_names () =
  let en = Lang.of_string_exn "en" and pl = Lang.of_string_exn "pl" in
  let l =
    L.of_entries ~id:"base" ~name:"Test names"
      [ entry ~month:1 ~day:14 ~names:(N.of_list [ (en, "Hilary of Poitiers") ]) "hilary" ]
  in
  let l', _ = O.apply l (ov "o" [ O.Edit (slug "hilary", [ O.Set_name (pl, "Hilary z Poitiers") ]) ]) in
  let after_set = match L.find l' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check bool) "existing language untouched by set" true
    (N.find after_set.L.cel.Cel.names en = Some "Hilary of Poitiers");
  Alcotest.(check bool) "new language added" true
    (N.find after_set.L.cel.Cel.names pl = Some "Hilary z Poitiers");
  let l'', _ = O.apply l' (ov "o" [ O.Edit (slug "hilary", [ O.Remove_name en ]) ]) in
  let after_remove = match L.find l'' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check bool) "removed language gone" true (N.find after_remove.L.cel.Cel.names en = None);
  Alcotest.(check bool) "other language survives removal" true
    (N.find after_remove.L.cel.Cel.names pl = Some "Hilary z Poitiers")

let test_edit_citations () =
  let existing =
    [ { Cit.part = Cit.Gospel; reference = "Mt 1:1" }; { Cit.part = Cit.First; reference = "Is 1:1" } ]
  in
  let l =
    L.of_entries ~id:"base" ~name:"Test citations" [ entry ~month:1 ~day:14 ~citations:existing "hilary" ]
  in
  (* Setting a part that already exists must replace it, not append a
     duplicate -- the list length is the load-bearing check here. *)
  let l', _ = O.apply l (ov "o" [ O.Edit (slug "hilary", [ O.Set_citation (Cit.Gospel, "Jn 3:16") ]) ]) in
  let after_set = match L.find l' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check int) "still two citations, not three" 2 (List.length after_set.L.cel.Cel.citations);
  Alcotest.(check bool) "gospel replaced" true
    (List.exists
       (fun c -> c.Cit.part = Cit.Gospel && c.Cit.reference = "Jn 3:16")
       after_set.L.cel.Cel.citations);
  Alcotest.(check bool) "first untouched by set" true
    (List.exists (fun c -> c.Cit.part = Cit.First && c.Cit.reference = "Is 1:1") after_set.L.cel.Cel.citations);
  let l'', _ = O.apply l' (ov "o" [ O.Edit (slug "hilary", [ O.Remove_citation Cit.Gospel ]) ]) in
  let after_remove = match L.find l'' (slug "hilary") with Some e -> e | None -> Alcotest.fail "missing" in
  Alcotest.(check int) "one citation left" 1 (List.length after_remove.L.cel.Cel.citations);
  Alcotest.(check bool) "first survives removal" true
    (List.exists
       (fun c -> c.Cit.part = Cit.First && c.Cit.reference = "Is 1:1")
       after_remove.L.cel.Cel.citations)

let test_diagnostics () =
  let l = base () in
  (* Add-over-existing uses a rank that genuinely differs from base()'s hilary
     (Class3, the [entry] helper's own default) -- otherwise re-adding with
     the default would leave [hilary] indistinguishable from doing nothing,
     and [L.mem] alone cannot tell "replaced" from "left untouched". *)
  let _, diags =
    O.apply l (ov "o" [ O.Suppress (slug "nobody");
                        O.Edit (slug "nobody", [ O.Set_colour Col.Red ]);
                        O.Add (entry ~month:1 ~day:14 ~rank:Class1 "hilary") ])
  in
  (* unknown suppress, unknown edit, and add-over-existing: three, none silent *)
  Alcotest.(check int) "three diagnostics" 3 (List.length diags);
  let l', _ = O.apply l (ov "o" [ O.Add (entry ~month:1 ~day:14 ~rank:Class1 "hilary") ]) in
  Alcotest.(check bool) "add-over-existing still applied (last writer wins)" true
    (rank_of l' "hilary" = Some Class1)

let test_merge_order () =
  let l = base () in
  let l', _ =
    O.merge l [ ov "a" [ O.Edit (slug "hilary", [ O.Set_rank Class1 ]) ];
                ov "b" [ O.Edit (slug "hilary", [ O.Set_rank Class3 ]) ] ]
  in
  Alcotest.(check bool) "later overlay wins" true (rank_of l' "hilary" = Some Class3)

let test_merge_diagnostics () =
  let l = base () in
  let _, diags =
    O.merge l
      [ ov "a" [ O.Suppress (slug "nobody-a") ];
        ov "b" [ O.Edit (slug "nobody-b", [ O.Set_colour Col.Red ]) ] ]
  in
  Alcotest.(check int) "two diagnostics" 2 (List.length diags);
  Alcotest.(check (list string)) "diagnostics in application order" [ "a"; "b" ]
    (List.map (fun d -> d.O.overlay) diags)

let test_overlay_sexp () =
  let o = ov "o" [ O.Edit (slug "hilary", [ O.Set_colour Col.Red ]);
                   O.Suppress (slug "telesphorus") ] in
  let sexp = O.sexp_of_t sexp_of_rank o in
  Alcotest.(check bool) "roundtrip" true (O.t_of_sexp rank_of_sexp sexp = o)

(* Property: applying the same overlay twice to the same layer is deterministic. *)
let prop_deterministic =
  QCheck.Test.make ~name:"overlay apply is deterministic" QCheck.(list (int_range 0 3))
    (fun ops ->
      let directive = function
        | 0 -> O.Add (entry ~month:3 ~day:3 "extra")
        | 1 -> O.Suppress (slug "hilary")
        | 2 -> O.Edit (slug "hilary", [ O.Set_colour Col.Red ])
        | _ -> O.Edit (slug "telesphorus", [ O.Set_rank Class1 ])
      in
      let o = ov "p" (List.map directive ops) in
      let a, da = O.apply (base ()) o and b, db = O.apply (base ()) o in
      a = b && da = db)

let suite =
  ( "Layer/Overlay",
    [ Alcotest.test_case "layer basics" `Quick test_layer_basics;
      Alcotest.test_case "layer by-date index" `Quick test_layer_index;
      Alcotest.test_case "layer by-date index accumulates same date" `Quick
        test_layer_index_same_date;
      Alcotest.test_case "layer sexp" `Quick test_layer_sexp;
      Alcotest.test_case "layer load success round-trip" `Quick test_layer_load_success;
      Alcotest.test_case "layer load missing file" `Quick test_layer_load_missing_file;
      Alcotest.test_case "layer load malformed sexp" `Quick test_layer_load_malformed;
      Alcotest.test_case "layer load invalid slug" `Quick test_layer_load_invalid_slug;
      Alcotest.test_case "layer load: rank_of_sexp raises a non-Of_sexp_error exception" `Quick
        test_layer_load_rank_of_sexp_raises_other_exception;
      Alcotest.test_case "empty is identity" `Quick test_empty_is_identity;
      Alcotest.test_case "add and suppress" `Quick test_add_and_suppress;
      Alcotest.test_case "order matters" `Quick test_order_matters;
      Alcotest.test_case "edit is field-scoped" `Quick test_edit_is_field_scoped;
      Alcotest.test_case "last writer wins" `Quick test_last_writer_wins;
      Alcotest.test_case "replace" `Quick test_replace;
      Alcotest.test_case "edit sets subject" `Quick test_edit_set_subject;
      Alcotest.test_case "edit sets and removes names" `Quick test_edit_names;
      Alcotest.test_case "edit sets and removes citations" `Quick test_edit_citations;
      Alcotest.test_case "diagnostics" `Quick test_diagnostics;
      Alcotest.test_case "merge order" `Quick test_merge_order;
      Alcotest.test_case "merge diagnostics" `Quick test_merge_diagnostics;
      Alcotest.test_case "overlay sexp" `Quick test_overlay_sexp ]
    @ List.map QCheck_alcotest.to_alcotest [ prop_deterministic ] )