path: root/lib/kernel/overlay_ini.ml

open Sexplib0.Sexp_conv

type section = { name : string; fields : (string * string) list }

let err fmt = Printf.ksprintf (fun s -> Error s) fmt

(* A minimal INI reader: [section] headers, [key = value] lines, ';' and '#'
   comments, blank lines ignored. Values keep interior spaces and are trimmed
   at both ends. Deliberately not a general INI implementation -- no
   continuations, no quoting, no repeated-key semantics -- because every
   feature here is one a user can trip over, and the format's whole purpose is
   to be unsurprising. *)
let parse_sections text =
  let lines = String.split_on_char '\n' text in
  let sections = ref [] and cur = ref None and fields = ref [] in
  let flush () =
    match !cur with
    | Some n -> sections := { name = n; fields = List.rev !fields } :: !sections
    | None -> ()
  in
  let rec go n = function
    | [] ->
        flush ();
        Ok (List.rev !sections)
    | raw :: rest -> (
        let line = String.trim raw in
        let n = n + 1 in
        if line = "" || line.[0] = ';' || line.[0] = '#' then go n rest
        else if line.[0] = '[' then
          if line.[String.length line - 1] <> ']' then
            err "line %d: %S looks like a section header but does not end with ']'" n line
          else begin
            flush ();
            cur := Some (String.sub line 1 (String.length line - 2));
            fields := [];
            go n rest
          end
        else
          match String.index_opt line '=' with
          | None -> err "line %d: %S is neither a [section] nor a key = value line" n line
          | Some i ->
              if !cur = None then
                err "line %d: %S appears before any [section] header" n line
              else begin
                let k = String.trim (String.sub line 0 i) in
                let v = String.trim (String.sub line (i + 1) (String.length line - i - 1)) in
                fields := (k, v) :: !fields;
                go n rest
              end)
  in
  go 0 lines

let get sec k = List.assoc_opt k sec.fields
let is_yes v = List.mem (String.lowercase_ascii v) [ "yes"; "true"; "1" ]

let months =
  [ ("jan", 1); ("feb", 2); ("mar", 3); ("apr", 4); ("may", 5); ("jun", 6);
    ("jul", 7); ("aug", 8); ("sep", 9); ("oct", 10); ("nov", 11); ("dec", 12) ]

let weekdays =
  [ ("sun", Date.Sun); ("mon", Date.Mon); ("tue", Date.Tue); ("wed", Date.Wed);
    ("thu", Date.Thu); ("fri", Date.Fri); ("sat", Date.Sat) ]

(* The three {!Date_spec} shapes, flattened. Every failure names the section
   and shows the three forms, because a wrong date is the commonest mistake
   and "invalid date" alone does not tell anyone what to type. *)
let parse_date ~section raw =
  let bad () =
    err
      "section [%s]: date %S is not one of the three forms: MM-DD (a civil \
       date), easter+N or easter-N (signed days from Easter), or mon/day/nth \
       such as oct/sun/1 or oct/sun/-1 (nth may be negative to count from the \
       end of the month)"
      section raw
  in
  let low = String.lowercase_ascii raw in
  let starts p = String.length low >= String.length p && String.sub low 0 (String.length p) = p in
  if starts "easter" then
    let tail = String.sub raw 6 (String.length raw - 6) in
    match int_of_string_opt (String.trim tail) with
    | Some n -> (
        match Date_spec.easter_offset n with Ok d -> Ok d | Error e -> err "section [%s]: %s" section e)
    | None -> bad ()
  else
    match String.split_on_char '/' low with
    | [ m; w; n ] -> (
        match (List.assoc_opt m months, List.assoc_opt w weekdays, int_of_string_opt n) with
        | Some month, Some weekday, Some nth -> (
            match Date_spec.nth_weekday ~month ~nth ~weekday with
            | Ok d -> Ok d
            | Error e -> err "section [%s]: %s" section e)
        | _ -> bad ())
    | _ -> (
        match String.split_on_char '-' low with
        | [ mm; dd ] -> (
            match (int_of_string_opt mm, int_of_string_opt dd) with
            | Some month, Some day -> (
                match Date_spec.fixed ~month ~day with
                | Ok d -> Ok d
                | Error e -> err "section [%s]: %s" section e)
            | _ -> bad ())
        | _ -> bad ())

let ( let* ) r f = match r with Ok v -> f v | Error e -> Error e

let parse_names ~section sec =
  let entries =
    List.filter_map
      (fun (k, v) ->
        if String.length k > 5 && String.sub k 0 5 = "name." then
          Some (String.sub k 5 (String.length k - 5), v)
        else None)
      sec.fields
  in
  match entries with
  | [] -> err "section [%s]: at least one name.<lang> is required (e.g. name.en)" section
  | _ ->
      List.fold_left
        (fun acc (l, v) ->
          let* names = acc in
          match Lang.of_string l with
          | Error e -> err "section [%s]: name.%s: %s" section l e
          | Ok lang -> Ok (Names.set names lang v))
        (Ok Names.empty) entries

let celebration ~section ~id ~rank_of_string sec =
  let* slug =
    match Slug.of_string section with
    | Ok s -> Ok s
    | Error e -> err "section [%s]: %s" section e
  in
  let* names = parse_names ~section sec in
  let* rank =
    match get sec "rank" with
    | None -> err "section [%s]: rank is required (class-1, class-2, class-3 or class-4)" section
    | Some r -> (
        match rank_of_string r with
        | Some r -> Ok r
        | None -> err "section [%s]: unknown rank %S -- expected class-1..class-4" section r)
  in
  let* colour =
    match get sec "colour" with
    | None -> err "section [%s]: colour is required (white, red, violet, green, black, rose)" section
    | Some c -> (
        match Colour.of_string (String.lowercase_ascii c) with
        | Some c -> Ok c
        | None ->
            err "section [%s]: unknown colour %S -- expected white, red, violet, green, black or rose"
              section c)
  in
  let* status =
    match get sec "status" with
    | None | Some "feast" -> Ok Celebration.Feast
    | Some "commemoration" -> Ok Celebration.Commemoration_only
    | Some s -> err "section [%s]: unknown status %S -- expected feast or commemoration" section s
  in
  let* subject =
    match Option.map String.lowercase_ascii (get sec "subject") with
    | None | Some "saint" -> Ok Subject.Saint
    | Some "lord" -> Ok Subject.Lord
    | Some "bvm" -> Ok Subject.Bvm
    | Some "temporal" -> Ok Subject.Temporal
    | Some s -> err "section [%s]: unknown subject %S -- expected lord, bvm, saint or temporal" section s
  in
  Ok (Celebration.make ~slug ~names ~rank ~status ~colour ~subject ~citations:[] ~layer:id ())

(* Field edits the flat form can express. Citation edits and Remove_name are
   deliberately absent: both need a structured key this format has no shape
   for, and a half-expressible edit is worse than one the parser refuses by
   name. *)
let edits ~section ~rank_of_string sec =
  List.fold_left
    (fun acc (k, v) ->
      let* es = acc in
      match k with
      | "edit" -> Ok es
      | "rank" -> (
          match rank_of_string v with
          | Some r -> Ok (Overlay.Set_rank r :: es)
          | None -> err "section [%s]: unknown rank %S" section v)
      | "colour" -> (
          match Colour.of_string (String.lowercase_ascii v) with
          | Some c -> Ok (Overlay.Set_colour c :: es)
          | None -> err "section [%s]: unknown colour %S" section v)
      | "subject" -> (
          match String.lowercase_ascii v with
          | "lord" -> Ok (Overlay.Set_subject Subject.Lord :: es)
          | "bvm" -> Ok (Overlay.Set_subject Subject.Bvm :: es)
          | "saint" -> Ok (Overlay.Set_subject Subject.Saint :: es)
          | "temporal" -> Ok (Overlay.Set_subject Subject.Temporal :: es)
          | _ -> err "section [%s]: unknown subject %S" section v)
      | k when String.length k > 5 && String.sub k 0 5 = "name." -> (
          let l = String.sub k 5 (String.length k - 5) in
          match Lang.of_string l with
          | Ok lang -> Ok (Overlay.Set_name (lang, v) :: es)
          | Error e -> err "section [%s]: name.%s: %s" section l e)
      | _ ->
          err
            "section [%s]: %S cannot be edited from an INI overlay -- this form \
             expresses rank, colour, subject and name.<lang> only. Write the \
             S-expression form for anything else (see colitur-overlay(5))."
            section k)
    (Ok []) sec.fields
  |> Result.map List.rev

let parse ~rank_of_string text =
  let* sections = parse_sections text in
  let header, entries = List.partition (fun s -> s.name = "overlay") sections in
  let* id =
    match header with
    | [ h ] -> (
        match get h "id" with
        | Some id when String.trim id <> "" -> Ok id
        | _ -> err "the [overlay] section needs an id (e.g. id = my-parish)")
    | [] -> err "no [overlay] section: the file must open with one, carrying id = <name>"
    | _ -> err "more than one [overlay] section"
  in
  let* directives =
    List.fold_left
      (fun acc sec ->
        let* ds = acc in
        let section = sec.name in
        match (get sec "suppress", get sec "replace", get sec "edit") with
        | Some v, _, _ when is_yes v -> (
            match Slug.of_string section with
            | Ok s -> Ok (Overlay.Suppress s :: ds)
            | Error e -> err "section [%s]: %s" section e)
        | _, Some v, _ when is_yes v ->
            err
              "section [%s]: replace is not expressible in the INI form -- it \
               needs a whole entry, which is what the S-expression form is for \
               (see colitur-overlay(5)). Suppress plus a fresh section is \
               usually what you want instead."
              section
        | _, _, Some v when is_yes v -> (
            let* es = edits ~section ~rank_of_string sec in
            match Slug.of_string section with
            | Ok s when es <> [] -> Ok (Overlay.Edit (s, es) :: ds)
            | Ok _ -> err "section [%s]: edit = yes but no editable field given" section
            | Error e -> err "section [%s]: %s" section e)
        | _ ->
            let* date =
              match get sec "date" with
              | None -> err "section [%s]: date is required" section
              | Some d -> parse_date ~section d
            in
            let* cel = celebration ~section ~id ~rank_of_string sec in
            Ok (Overlay.Add { Layer.date; cel } :: ds))
      (Ok []) entries
    |> Result.map List.rev
  in
  Ok { Overlay.id; directives }

let to_sexp_string rank_to_sexp t =
  Printf.sprintf
    ";; GENERATED by `colitur convert` from an INI overlay -- edit the INI and\n\
     ;; regenerate, or adopt this file and drop the INI, but do not maintain\n\
     ;; both. The conversion verified that this file parses back to exactly\n\
     ;; what the INI denoted.\n\
     %s\n"
    (Sexplib0.Sexp.to_string_hum (Overlay.sexp_of_t rank_to_sexp t))

let convert ~rank_of_string ~rank_to_sexp ~rank_of_sexp text =
  let* t = parse ~rank_of_string text in
  let rendered = to_sexp_string rank_to_sexp t in
  (* The self-check this module exists for. Parse the emitted text back with
     the SAME function the engine uses, and require the result to equal what
     the INI denoted. A transpiler emitting valid-but-wrong sexp is the failure
     a convenience format invites, and `colitur check` could never catch it:
     the output would parse cleanly and simply mean something else. *)
  (* Parse the ACTUAL text about to be returned -- not a fresh serialisation of
     [t], which would make this check vacuous: [t] round-tripping through
     [sexp_of_t]/[t_of_sexp] is true by construction and proves nothing about
     [rendered]. The first version of this function did exactly that, and a
     mutation corrupting the renderer (emitting a different overlay id) sailed
     straight through it and exited 0. Two tests in test_overlay_ini.ml catch
     that mutation now; they did not before, because they too must parse the
     RETURNED text rather than re-derive it. *)
  match Sexplib.Sexp.of_string rendered with
  | exception exn ->
      err "internal: generated sexp does not re-parse (%s) -- this is a bug in colitur, not in your file"
        (Printexc.to_string exn)
  | sexp -> (
      match Overlay.t_of_sexp rank_of_sexp sexp with
      | exception exn ->
          err
            "internal: generated sexp does not load (%s) -- this is a bug in colitur, not in your file"
            (Printexc.to_string exn)
      | back ->
          if back = t then Ok rendered
          else
            err
              "internal: the generated sexp does not mean what the INI said -- \
               this is a bug in colitur, not in your file. Nothing was written.")