1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
open Sexplib0.Sexp_conv
(* The layer-merge algebra (spec §3.2-3.3). Ordered directives, ordered
overlays, last writer wins per field, [empty] the identity.
A closed field_edit variant rather than a string-keyed field map: an unknown
field is then a compile error in code and a parse error in data, never a
silent no-op. *)
type 'r field_edit =
| Set_rank of 'r
| Set_colour of Colour.t
| Set_subject of Subject.t
| Set_name of Lang.t * string
| Remove_name of Lang.t
| Set_citation of Citation.part * string
| Remove_citation of Citation.part
[@@deriving sexp]
type 'r directive =
| Add of 'r Layer.entry
| Suppress of Slug.t
| Replace of Slug.t * 'r Layer.entry
| Edit of Slug.t * 'r field_edit list
[@@deriving sexp]
type 'r t = { id : string; directives : 'r directive list } [@@deriving sexp]
type diagnostic = { overlay : string; directive : string; slug : string; message : string }
let diagnostic_to_string d =
Printf.sprintf "overlay %s: %s %s: %s" d.overlay d.directive d.slug d.message
let empty = { id = "empty"; directives = [] }
let apply_field_edit cel = function
| Set_rank r -> { cel with Celebration.rank = r }
| Set_colour c -> { cel with Celebration.colour = c }
| Set_subject s -> { cel with Celebration.subject = s }
| Set_name (lang, name) -> { cel with Celebration.names = Names.set cel.Celebration.names lang name }
| Remove_name lang -> { cel with Celebration.names = Names.remove cel.Celebration.names lang }
| Set_citation (part, reference) ->
let others = List.filter (fun c -> c.Citation.part <> part) cel.Celebration.citations in
{ cel with Celebration.citations = others @ [ { Citation.part; reference } ] }
| Remove_citation part ->
{ cel with
Celebration.citations = List.filter (fun c -> c.Citation.part <> part) cel.Celebration.citations }
let apply_directive ~overlay (layer, diags) directive =
let diag directive slug message = { overlay; directive; slug; message } in
match directive with
| Add entry ->
let slug = entry.Layer.cel.Celebration.slug in
let diags =
if Layer.mem layer slug then
(* Not silently swallowed, and not fatal: last writer wins, loudly. *)
diag "add" (Slug.to_string slug) "slug already present; replaced (last writer wins)"
:: diags
else diags
in
(Layer.set layer entry, diags)
| Suppress slug ->
if Layer.mem layer slug then (Layer.remove layer slug, diags)
else (layer, diag "suppress" (Slug.to_string slug) "slug not present; nothing to suppress" :: diags)
| Replace (slug, entry) ->
let diags =
if Layer.mem layer slug then diags
else diag "replace" (Slug.to_string slug) "slug not present; added instead" :: diags
in
(Layer.set (Layer.remove layer slug) entry, diags)
| Edit (slug, edits) -> (
match Layer.find layer slug with
| None -> (layer, diag "edit" (Slug.to_string slug) "slug not present; edit ignored" :: diags)
| Some entry ->
let cel = List.fold_left apply_field_edit entry.Layer.cel edits in
(Layer.set layer { entry with Layer.cel = cel }, diags))
let apply layer t =
let layer, diags = List.fold_left (apply_directive ~overlay:t.id) (layer, []) t.directives in
(layer, List.rev diags)
let merge layer overlays =
List.fold_left
(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 load rank_of_sexp path =
match Sexplib.Sexp.load_sexp path with
| exception Sys_error msg -> Error msg
(* Mirrors Layer.load: this sexplib version raises [Failure] for some
malformed inputs (e.g. an unterminated list or string) rather than
[Sexplib.Sexp.Parse_error], so a catch-all here -- placed last among the
exception branches -- is what actually keeps every parse failure inside
[Error] instead of escaping. *)
| exception exn ->
Error (Printf.sprintf "%s: %s" path (Sexp_error.humanise (Printexc.to_string exn)))
| sexp -> (
(* 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 (Sexp_error.humanise (Printexc.to_string exn))))
|
