merge: a flat INI overlay front end

A convenience format for simple local calendars, transpiled to the existing
S-expression form and verified against it before emitting.

1 files changed, 294 insertions, 0 deletions

diff --git a/lib/kernel/overlay_ini.ml b/lib/kernel/overlay_ini.ml
new file mode 100644
index 0000000..6b6249f
--- /dev/null
+++ b/lib/kernel/overlay_ini.ml
@@ -0,0 +1,294 @@
+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.")