lib/kernel/lectionary.ml


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

open Sexplib0.Sexp_conv

type entry = Slug.t * Citation.t list [@@deriving sexp]
type t = entry list [@@deriving sexp]

let empty = []

let of_entries es =
  let sorted = List.stable_sort (fun (a, _) (b, _) -> Slug.compare a b) es in
  let rec dup = function
    | (a, _) :: ((b, _) :: _ as rest) ->
        if Slug.equal a b then Some a else dup rest
    | _ -> None
  in
  match dup sorted with
  | Some s ->
      Error (Printf.sprintf "lectionary: duplicate slug %S" (Slug.to_string s))
  | None -> Ok sorted

let find t s = List.assoc_opt s t
let mem t s = List.mem_assoc s t
let entries t = t

let load path =
  match Sexplib.Sexp.load_sexp path with
  | exception Sexplib.Sexp.Parse_error e ->
      Error (Printf.sprintf "lectionary: %s: %s" path e.err_msg)
  | exception Sys_error e -> Error (Printf.sprintf "lectionary: %s" e)
  (* Mirrors Layer.load/Overlay.load: this sexplib version raises [Failure]
     for some malformed inputs (e.g. an unterminated list or string, an
     empty file, or a file holding more than one sexp) 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 "lectionary: %s: %s" path (Printexc.to_string exn))
  | sexp -> (
      match t_of_sexp sexp with
      | exception Sexplib0.Sexp_conv_error.Of_sexp_error (exn, _) ->
          Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn))
      (* Defence in depth: every conversion below is currently
         [Of_sexp_error] (including [Slug.t_of_sexp] on a malformed slug
         atom), but [t_of_sexp] is derived and could raise something else
         after a future type change -- this catch-all is what would keep
         that inside [Error] too, the same reasoning as the outer one above. *)
      | exception exn -> Error (Printf.sprintf "lectionary: %s: %s" path (Printexc.to_string exn))
      | parsed -> of_entries parsed)