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. --- lib/kernel/overlay.ml | 98 +++++++++++++++++++++++++++++++++++++++++++++++ lib/kernel/overlay.mli | 40 ++++++++++++++++++++ test/test_overlay.ml | 101 ++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 238 insertions(+), 1 deletion(-) create mode 100644 lib/kernel/overlay.ml create mode 100644 lib/kernel/overlay.mli 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 ] ) -- cgit v1.3