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) s =
  Cel.make ~slug:(slug s) ~rank ~colour ~layer:"base" ()

let entry ?(month = 1) ?(day = 1) ?rank ?colour s =
  { L.date = (match DS.fixed ~month ~day with Ok d -> d | Error e -> failwith e);
    cel = cel ?rank ?colour 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 _ -> ())

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

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_diagnostics () =
  let l = base () in
  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 "hilary") ])
  in
  (* unknown suppress, unknown edit, and add-over-existing: three, none silent *)
  Alcotest.(check int) "three diagnostics" 3 (List.length diags);
  Alcotest.(check bool) "add-over-existing still applied (last writer wins)" true
    (L.mem (fst (O.apply l (ov "o" [ O.Add (entry ~month:1 ~day:14 "hilary") ]))) (slug "hilary"))

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_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 "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 "diagnostics" `Quick test_diagnostics;
      Alcotest.test_case "merge order" `Quick test_merge_order;
      Alcotest.test_case "overlay sexp" `Quick test_overlay_sexp ]
    @ List.map QCheck_alcotest.to_alcotest [ prop_deterministic ] )