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)))