From 3cb45720f5e2ba7bd8be9a5113d866be22ad07a8 Mon Sep 17 00:00:00 2001 From: Lukasz Kasprzak Date: Tue, 11 Aug 2026 12:37:22 +0200 Subject: kernel(overlay): ordered layer-merge algebra with diagnostics add/suppress/replace/field-edit folded in order, last writer wins per field, empty the identity. A directive naming an unknown slug, or adding one that already exists, yields a diagnostic rather than silence or a hard failure: overlays must survive a shifted base while still surfacing authoring errors. --- test/test_overlay.ml | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 100 insertions(+), 1 deletion(-) (limited to 'test/test_overlay.ml') diff --git a/test/test_overlay.ml b/test/test_overlay.ml index b3a8f26..1b42eaf 100644 --- a/test/test_overlay.ml +++ b/test/test_overlay.ml @@ -111,6 +111,96 @@ let test_layer_load_invalid_slug () = | 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; @@ -121,4 +211,13 @@ let suite = 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 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 ] ) -- cgit v1.3