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
type t =
[ `Null
| `Bool of bool
| `String of string
| `List of t list
| `Assoc of (string * t) list ]
let params_value = function
| [] -> `Null
| [ x ] -> `String x
| xs -> `List (List.map (fun s -> `String s) xs)
let rec value_of_directive (d : Bcfg.directive) : t =
match d.Bcfg.children with
| [] -> params_value d.Bcfg.parameters
| children ->
let entries = assoc_of_directives children in
let entries =
match d.Bcfg.parameters with
| [] -> entries
| params -> ("$params", params_value params) :: entries
in
`Assoc entries
and assoc_of_directives (ds : Bcfg.t) : (string * t) list =
let order = ref [] in
let tbl = Hashtbl.create 16 in
List.iter
(fun (d : Bcfg.directive) ->
let v = value_of_directive d in
match Hashtbl.find_opt tbl d.Bcfg.name with
| None ->
order := d.Bcfg.name :: !order;
Hashtbl.replace tbl d.Bcfg.name [ v ]
| Some vs -> Hashtbl.replace tbl d.Bcfg.name (v :: vs))
ds;
List.rev_map
(fun name ->
match Hashtbl.find tbl name with
| [ v ] -> (name, v)
| vs -> (name, `List (List.rev vs)))
!order
let of_config (ds : Bcfg.t) : t = `Assoc (assoc_of_directives ds)
let escape_string buf s =
Buffer.add_char buf '"';
String.iter
(fun c ->
match c with
| '"' -> Buffer.add_string buf "\\\""
| '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n"
| '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| '\b' -> Buffer.add_string buf "\\b"
| '\012' -> Buffer.add_string buf "\\f"
| c when Char.code c < 0x20 ->
Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c))
| c -> Buffer.add_char buf c)
s;
Buffer.add_char buf '"'
let to_string ?(minify = false) (json : t) =
let buf = Buffer.create 256 in
let nl indent =
if not minify then begin
Buffer.add_char buf '\n';
Buffer.add_string buf (String.make (indent * 2) ' ')
end
in
let colon = if minify then ":" else ": " in
let rec go indent = function
| `Null -> Buffer.add_string buf "null"
| `Bool b -> Buffer.add_string buf (string_of_bool b)
| `String s -> escape_string buf s
| `List [] -> Buffer.add_string buf "[]"
| `List items ->
Buffer.add_char buf '[';
List.iteri
(fun i item ->
if i > 0 then Buffer.add_char buf ',';
nl (indent + 1);
go (indent + 1) item)
items;
nl indent;
Buffer.add_char buf ']'
| `Assoc [] -> Buffer.add_string buf "{}"
| `Assoc fields ->
Buffer.add_char buf '{';
List.iteri
(fun i (k, v) ->
if i > 0 then Buffer.add_char buf ',';
nl (indent + 1);
escape_string buf k;
Buffer.add_string buf colon;
go (indent + 1) v)
fields;
nl indent;
Buffer.add_char buf '}'
in
go 0 json;
Buffer.contents buf
let pp ppf json = Format.pp_print_string ppf (to_string json)