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.

3 files changed, 238 insertions, 1 deletions

diff --git a/lib/kernel/overlay.ml b/lib/kernel/overlay.ml
new file mode 100644
index 0000000..d1d03b3
--- /dev/null
+++ b/lib/kernel/overlay.ml
@@ -0,0 +1,98 @@
+open Sexplib0.Sexp_conv
+
+(* The layer-merge algebra (spec §3.2-3.3). Ordered directives, ordered
+   overlays, last writer wins per field, [empty] the identity.
+
+   A closed field_edit variant rather than a string-keyed field map: an unknown
+   field is then a compile error in code and a parse error in data, never a
+   silent no-op. *)
+type 'r field_edit =
+  | Set_rank of 'r
+  | Set_colour of Colour.t
+  | Set_subject of Subject.t
+  | Set_name of Lang.t * string
+  | Remove_name of Lang.t
+  | Set_citation of Citation.part * string
+  | Remove_citation of Citation.part
+[@@deriving sexp]
+
+type 'r directive =
+  | Add of 'r Layer.entry
+  | Suppress of Slug.t
+  | Replace of Slug.t * 'r Layer.entry
+  | Edit of Slug.t * 'r field_edit list
+[@@deriving sexp]
+
+type 'r t = { id : string; directives : 'r directive list } [@@deriving sexp]
+
+type diagnostic = { overlay : string; directive : string; slug : string; message : string }
+
+let diagnostic_to_string d =
+  Printf.sprintf "overlay %s: %s %s: %s" d.overlay d.directive d.slug d.message
+
+let empty = { id = "empty"; directives = [] }
+
+let apply_field_edit cel = function
+  | Set_rank r -> { cel with Celebration.rank = r }
+  | Set_colour c -> { cel with Celebration.colour = c }
+  | Set_subject s -> { cel with Celebration.subject = s }
+  | Set_name (lang, name) -> { cel with Celebration.names = Names.set cel.Celebration.names lang name }
+  | Remove_name lang -> { cel with Celebration.names = Names.remove cel.Celebration.names lang }
+  | Set_citation (part, reference) ->
+      let others = List.filter (fun c -> c.Citation.part <> part) cel.Celebration.citations in
+      { cel with Celebration.citations = others @ [ { Citation.part; reference } ] }
+  | Remove_citation part ->
+      { cel with
+        Celebration.citations = List.filter (fun c -> c.Citation.part <> part) cel.Celebration.citations }
+
+let apply_directive ~overlay (layer, diags) directive =
+  let diag directive slug message = { overlay; directive; slug; message } in
+  match directive with
+  | Add entry ->
+      let slug = entry.Layer.cel.Celebration.slug in
+      let diags =
+        if Layer.mem layer slug then
+          (* Not silently swallowed, and not fatal: last writer wins, loudly. *)
+          diag "add" (Slug.to_string slug) "slug already present; replaced (last writer wins)"
+          :: diags
+        else diags
+      in
+      (Layer.set layer entry, diags)
+  | Suppress slug ->
+      if Layer.mem layer slug then (Layer.remove layer slug, diags)
+      else (layer, diag "suppress" (Slug.to_string slug) "slug not present; nothing to suppress" :: diags)
+  | Replace (slug, entry) ->
+      let diags =
+        if Layer.mem layer slug then diags
+        else diag "replace" (Slug.to_string slug) "slug not present; added instead" :: diags
+      in
+      (Layer.set (Layer.remove layer slug) entry, diags)
+  | Edit (slug, edits) -> (
+      match Layer.find layer slug with
+      | None -> (layer, diag "edit" (Slug.to_string slug) "slug not present; edit ignored" :: diags)
+      | Some entry ->
+          let cel = List.fold_left apply_field_edit entry.Layer.cel edits in
+          (Layer.set layer { entry with Layer.cel = cel }, diags))
+
+let apply layer t =
+  let layer, diags = List.fold_left (apply_directive ~overlay:t.id) (layer, []) t.directives in
+  (layer, List.rev diags)
+
+let merge layer overlays =
+  List.fold_left
+    (fun (l, acc) o -> let l, d = apply l o in (l, acc @ d))
+    (layer, []) overlays
+
+let load rank_of_sexp path =
+  match Sexplib.Sexp.load_sexp path with
+  | exception Sys_error msg -> Error msg
+  (* Mirrors Layer.load: this sexplib version raises [Failure] for some
+     malformed inputs (e.g. an unterminated list or string) rather than
+     [Sexplib.Sexp.Parse_error], so a catch-all here -- placed last among the
+     exception branches -- is what actually keeps every parse failure inside
+     [Error] instead of escaping. *)
+  | exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn))
+  | sexp -> (
+      match t_of_sexp rank_of_sexp sexp with
+      | t -> Ok t
+      | exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)))
diff --git a/lib/kernel/overlay.mli b/lib/kernel/overlay.mli
new file mode 100644
index 0000000..fff284e
--- /dev/null
+++ b/lib/kernel/overlay.mli
@@ -0,0 +1,40 @@
+(** The layer-merge algebra: ordered directives over slugs, last writer wins per
+    field, [empty] the identity. *)
+
+type 'r field_edit =
+  | Set_rank of 'r
+  | Set_colour of Colour.t
+  | Set_subject of Subject.t
+  | Set_name of Lang.t * string
+  | Remove_name of Lang.t
+  | Set_citation of Citation.part * string
+  | Remove_citation of Citation.part
+[@@deriving sexp]
+
+type 'r directive =
+  | Add of 'r Layer.entry
+  | Suppress of Slug.t
+  | Replace of Slug.t * 'r Layer.entry
+  | Edit of Slug.t * 'r field_edit list
+[@@deriving sexp]
+
+type 'r t = { id : string; directives : 'r directive list } [@@deriving sexp]
+
+(** A directive that did not apply cleanly. Never silently dropped, never fatal:
+    an overlay written against a slightly different base must stay usable, and an
+    authoring error must still be visible. *)
+type diagnostic = { overlay : string; directive : string; slug : string; message : string }
+
+val diagnostic_to_string : diagnostic -> string
+
+(** The identity overlay: [apply l empty = (l, [])]. *)
+val empty : 'r t
+
+val apply : 'r Layer.t -> 'r t -> 'r Layer.t * diagnostic list
+
+(** Folds overlays in order; diagnostics accumulate in application order. *)
+val merge : 'r Layer.t -> 'r t list -> 'r Layer.t * diagnostic list
+
+(** Loads an overlay from a sexp file. Parse and validation failures come back
+    as [Error], never as an exception. *)
+val load : (Sexplib0.Sexp.t -> 'r) -> string -> ('r t, string) result
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 ] )