2 files changed, 138 insertions, 0 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