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

(* A user-supplied overlay is the only sexp this engine reads that a HUMAN
   writes by hand, and two of [Celebration.t]'s eight fields carry nothing such
   an author can meaningfully supply: [citations] is always empty for a local
   feast (citations come from the rite's lectionary, never from calendar data),
   and [layer] merely repeats the overlay file's own [id]. Requiring both made
   the commonest first mistake -- omitting them -- fail with
   "lib/kernel/celebration.ml.t_of_sexp: the following record elements were
   undefined: citations layer", which names a source file the author will never
   open and does not say what to write instead.

   [fill_defaults] walks the raw sexp before the derived parser sees it and
   supplies each field only where it is ABSENT, so an explicitly stated value
   always wins -- an overlay may legitimately name a layer different from its
   own id, and defaulting must not silently overwrite that.

   Deliberately scoped to overlays. {!Layer.load}, which reads the SHIPPED
   sanctoral, is untouched and stays strict: that data is the project's own,
   every field of it is asserted by tests, and a missing one there is a defect
   rather than a convenience. This is a leniency for user input only. *)
let fill_defaults ~id sexp =
  let open Sexplib0.Sexp in
  let has_field name = function
    | List (Atom k :: _) -> String.equal k name
    | _ -> false
  in
  (* [cel] is a record: a list of (key value) pairs. Add what is missing. *)
  let rec fix_cel = function
    | List fields when List.exists (has_field "slug") fields ->
        let add name v acc = if List.exists (has_field name) acc then acc else acc @ [ v ] in
        fields
        |> add "citations" (List [ Atom "citations"; List [] ])
        |> add "layer" (List [ Atom "layer"; Atom id ])
        |> fun fs -> List fs
    | List l -> List (List.map fix_cel l)
    | a -> a
  in
  let rec walk = function
    | List [ Atom "cel"; body ] -> List [ Atom "cel"; fix_cel body ]
    | List l -> List (List.map walk l)
    | a -> a
  in
  walk sexp

(* The derived parsers report failures as [Of_sexp_error] carrying the
   defining module's own path -- accurate for a colitur developer, useless to
   someone editing their parish's calendar. Rewrite the two prefixes that
   actually reach a user into the vocabulary of the file they are looking at.
   Anything unrecognised passes through verbatim rather than being reworded
   into something possibly wrong. *)
let humanise_error msg =
  let replace ~sub ~by s =
    let n = String.length sub and len = String.length s in
    let rec go i acc =
      if i > len - n then acc ^ String.sub s i (len - i)
      else if String.equal (String.sub s i n) sub then go (i + n) (acc ^ by)
      else go (i + 1) (acc ^ String.make 1 s.[i])
    in
    if n = 0 then s else go 0 ""
  in
  msg
  |> replace ~sub:"lib/kernel/celebration.ml.t_of_sexp" ~by:"celebration"
  |> replace ~sub:"lib/kernel/colour.ml.t_of_sexp" ~by:"colour"
  |> replace ~sub:"lib/kernel/subject.ml.t_of_sexp" ~by:"subject"
  |> replace ~sub:"lib/kernel/date_spec.ml.t_of_sexp" ~by:"date"
  |> replace ~sub:"lib/kernel/overlay.ml.directive_of_sexp" ~by:"directive"

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 -> (
      (* The overlay's own [id] is needed to default [layer], so read it off
         the raw sexp first. If it is missing or malformed the derived parser
         below reports that properly; "" here just means no useful default. *)
      let id =
        let open Sexplib0.Sexp in
        let rec find = function
          | List [ Atom "id"; Atom v ] -> Some v
          | List l -> List.find_map find l
          | Atom _ -> None
        in
        Option.value (find sexp) ~default:""
      in
      match t_of_sexp rank_of_sexp (fill_defaults ~id sexp) with
      | t -> Ok t
      | exception exn ->
          Error (Printf.sprintf "%s: %s" path (humanise_error (Printexc.to_string exn))))