diff options
| -rw-r--r-- | lib/kernel/overlay.ml | 83 | ||||
| -rw-r--r-- | test/test_overlay.ml | 66 |
2 files changed, 146 insertions, 3 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)))) diff --git a/test/test_overlay.ml b/test/test_overlay.ml index f3d1aee..12eb56d 100644 --- a/test/test_overlay.ml +++ b/test/test_overlay.ml @@ -307,9 +307,73 @@ let prop_deterministic = let a, da = O.apply (base ()) o and b, db = O.apply (base ()) o in a = b && da = db) +(* Overlay ERGONOMICS (branch overlay-ergonomics). A user-supplied overlay is + hand-written, unlike every other sexp this engine reads, and two of + [Celebration.t]'s eight fields carry no information a user could supply + meaningfully: [citations] is always empty for a local feast (colitur emits + citations from the lectionary, not the calendar), and [layer] just repeats + the overlay file's own [id]. Requiring both meant the commonest first + mistake -- omitting them -- produced + "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. + + {!Overlay.load} now fills both in before the strict parser runs. This is + deliberately scoped to OVERLAY loading: {!Layer.load}, which reads the + SHIPPED sanctoral, stays strict, because that data is the project's own and + a missing field there is a defect rather than a convenience. *) +let overlay_missing_citations_and_layer = + {|((id my-parish) + (directives + ((Add + ((date (Fixed (month 5) (day 20))) + (cel + ((slug st-example) + (names ((en "St Example"))) + (rank Class3) (status Feast) (colour White) (subject Saint))))))))|} + +let test_overlay_defaults_citations_and_layer () = + with_temp_file (fun path -> + let oc = open_out path in + output_string oc overlay_missing_citations_and_layer; + close_out oc; + match O.load rank_of_sexp path with + | Error e -> Alcotest.failf "expected the overlay to load, got: %s" e + | Ok o -> + Alcotest.(check string) "id" "my-parish" o.O.id; + (match o.O.directives with + | [ O.Add e ] -> + Alcotest.(check string) "citations defaulted to empty" "0" + (string_of_int (List.length e.L.cel.Cel.citations)); + (* [layer] defaults to the overlay's own id: the value the author + would have typed, so a later Suppress/Edit naming it works. *) + Alcotest.(check string) "layer defaulted to the overlay id" "my-parish" + e.L.cel.Cel.layer + | _ -> Alcotest.fail "expected exactly one Add directive")) + +(* An explicit [layer] must still win: an overlay may deliberately claim a + different layer name from its own id (e.g. one file shipping two logical + layers), and defaulting must not overwrite a stated value. *) +let test_overlay_explicit_layer_wins () = + with_temp_file (fun path -> + let oc = open_out path in + output_string oc + (replace_first ~sub:"(subject Saint)" + ~by:"(subject Saint) (layer stated-explicitly)" overlay_missing_citations_and_layer); + close_out oc; + match O.load rank_of_sexp path with + | Ok { O.directives = [ O.Add e ]; _ } -> + Alcotest.(check string) "explicit layer preserved" "stated-explicitly" e.L.cel.Cel.layer + | Ok _ -> Alcotest.fail "expected exactly one Add directive" + | Error e -> Alcotest.failf "expected the overlay to load, got: %s" e) + let suite = ( "Layer/Overlay", - [ Alcotest.test_case "layer basics" `Quick test_layer_basics; + [ Alcotest.test_case "overlay: citations and layer default when omitted" `Quick + test_overlay_defaults_citations_and_layer; + Alcotest.test_case "overlay: an explicit layer is not overwritten" `Quick + test_overlay_explicit_layer_wins; + Alcotest.test_case "layer basics" `Quick test_layer_basics; Alcotest.test_case "layer by-date index" `Quick test_layer_index; Alcotest.test_case "layer by-date index accumulates same date" `Quick test_layer_index_same_date; |