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
|
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
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 (Printexc.to_string exn))
| sexp -> (
match t_of_sexp rank_of_sexp sexp with
| t -> Ok t
| exception exn -> Error (Printf.sprintf "%s: %s" path (Printexc.to_string exn)))
|
