diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/kernel/overlay.ml | 83 |
1 files changed, 81 insertions, 2 deletions
diff --git a/lib/kernel/overlay.ml b/lib/kernel/overlay.ml index d1d03b3..58d8847 100644 --- a/lib/kernel/overlay.ml +++ b/lib/kernel/overlay.ml @@ -83,6 +83,72 @@ let merge layer overlays = (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 @@ -93,6 +159,19 @@ let load rank_of_sexp path = [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 + (* 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 (Printexc.to_string exn))) + | exception exn -> + Error (Printf.sprintf "%s: %s" path (humanise_error (Printexc.to_string exn)))) |