Source file Render_json.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
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
open Prelude
open Core

module E = Render_effect.Perform

module Printer =
struct
  module P0 =
  struct
    type out = Format.formatter
    let text txt fmt =
      Format.fprintf fmt "%s" txt
  end

  include Printer_kit.Kit (P0)

  let contents (printer : t) : string =
    Format.asprintf "%a" (fun fmt _ -> printer fmt) ()
end

let squares x =
  Printer.seq ~sep:Printer.space
    [Printer.text "["; x; Printer.text "]"]

let braces x =
  Printer.seq ~sep:Printer.space
    [Printer.text "{"; x; Printer.text "}"]

let comma = Printer.text ", "

let render_string_literal body =
  Printer.seq [Printer.text "\""; body; Printer.text "\""]


let render_key k p =
  Printer.seq ~sep:Printer.space
    [render_string_literal @@ Printer.text k;
     Printer.text ":";
     p]

let escape =
  Str.global_substitute (Str.regexp {|"|}) @@
  fun _ -> {|\"|}

let render_tree (doc : Sem.tree) : Printer.t =
  match doc.addr with
  | None -> Printer.nil
  | Some addr ->
    render_key addr @@ braces @@
    Printer.iter ~sep:comma (fun (k, x) -> render_key k x)
      ["title",
       begin
         match doc.title with
         | None -> Printer.text "null"
         | Some title ->
           let title_string =
             String.trim @@
             String_util.sentence_case @@
             Render_text.Printer.contents @@
             Render_text.render title
           in
           render_string_literal @@ Printer.text @@ escape title_string
       end;
       "taxon",
       begin
         match doc.taxon with
         | None -> Printer.text "null"
         | Some taxon -> render_string_literal @@ Printer.text @@ String_util.sentence_case taxon
       end;
       "tags",
       begin
         squares @@
         Printer.iter ~sep:comma (fun tag -> render_string_literal @@ Printer.text tag) doc.tags
       end;
       "route",
       render_string_literal @@ Printer.text @@
       E.route Xml addr]

let render_trees (docs : Sem.tree list) : Printer.t =
  braces @@ Printer.iter ~sep:comma render_tree docs