diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/kernel/overlay_ini.ml | 294 | ||||
| -rw-r--r-- | lib/kernel/overlay_ini.mli | 69 |
2 files changed, 363 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.") diff --git a/lib/kernel/overlay_ini.mli b/lib/kernel/overlay_ini.mli new file mode 100644 index 0000000..bace93b --- /dev/null +++ b/lib/kernel/overlay_ini.mli @@ -0,0 +1,69 @@ +(** A flat INI front end for overlay files. + + This is a CONVENIENCE FORMAT, not a second data model. It parses to exactly + the {!Overlay.t} the S-expression form parses to, and everything downstream + -- merge, diagnostics, validation -- is the same code on the same values. + There is deliberately no second semantics to keep in step. + + It is also deliberately LESS EXPRESSIVE than the sexp form. It covers [Add], + [Suppress] and single-field [Edit], which is what a diocesan or parish + calendar needs; [Replace], multi-field edits and citation edits are not + expressible and the parser says so by name rather than failing obscurely. + Anything it cannot say is a reason to write sexp, not a reason to grow this. + + {1 Format} + + Section names are slugs. A [\[overlay\]] section carries the file's id. + + {v + [overlay] + id = my-parish + + [our-patron] + date = 07-11 + rank = class-3 + colour = white + name.en = St Example, Patron + + [some-universal-slug] + suppress = yes + v} + + Dates take three forms, matching {!Date_spec}: [MM-DD], [easter+N] or + [easter-N], and [mon/day/nth] such as [oct/sun/1] or [oct/sun/-1]. *) + +(** [parse ~rank_of_string text] is the overlay [text] denotes. + + [rank_of_string] is supplied by the rite, exactly as [Overlay.load] takes + [rank_of_sexp]: the kernel does not know one rite's rank vocabulary from + another's. + + Errors carry the section name and the offending value, never a source-file + path -- this format exists for people who are not reading the source. *) +val parse : + rank_of_string:(string -> 'r option) -> string -> ('r Overlay.t, string) result + +(** [to_sexp_string t] renders [t] as the S-expression form, with a header + noting that it was generated. *) +val to_sexp_string : ('r -> Sexplib0.Sexp.t) -> 'r Overlay.t -> string + +(** [convert ~rank_of_string ~rank_to_sexp ~rank_of_sexp text] parses [text], + renders it, and PROVES the rendering before returning it: the emitted text + is parsed back with the very function the engine uses to load an overlay, + and the result must equal what the INI denoted. + + That check is the point of this module. A transpiler that emits + syntactically valid but semantically wrong output is the failure mode a + convenience format invites, and it is one [colitur check] could not catch, + since the emitted file would parse cleanly and simply mean something else. + Verifying the round trip here makes that class of bug impossible to ship + rather than merely unlikely. + + [Error] on a parse failure, and on a round-trip mismatch -- which is a bug + in this module, and says so. *) +val convert : + rank_of_string:(string -> 'r option) -> + rank_to_sexp:('r -> Sexplib0.Sexp.t) -> + rank_of_sexp:(Sexplib0.Sexp.t -> 'r) -> + string -> + (string, string) result |