Declarative JSON data manipulation for OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2024 The jsont programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6module String_map = Map.Make (String)
7
8(* Items to do. *)
9
10module Status = struct
11 type t = Todo | Done | Cancelled
12
13 let assoc = [ ("todo", Todo); ("done", Done); ("cancelled", Cancelled) ]
14 let codec = Json.Codec.enum ~kind:"Status" assoc
15end
16
17module Item = struct
18 type t = { task : string; status : Status.t; tags : string list }
19
20 let make task status tags = { task; status; tags }
21 let task i = i.task
22 let status i = i.status
23 let tags i = i.tags
24
25 let codec =
26 Json.Codec.Object.map ~kind:"Item" make
27 |> Json.Codec.Object.member "task" Json.Codec.string ~enc:task
28 |> Json.Codec.Object.member "status" Status.codec ~enc:status
29 |> Json.Codec.Object.member "tags"
30 Json.Codec.(list string)
31 ~dec_absent:[] ~enc:tags ~enc_omit:(( = ) [])
32 |> Json.Codec.Object.seal
33end
34
35module Item_data = struct
36 let i0 = Item.{ task = "Hey"; status = Todo; tags = [ "huhu"; "haha" ] }
37
38 let i0_json =
39 (* Indented JSON format. *)
40 "{\n\
41 \ \"task\": \"Hey\",\n\
42 \ \"status\": \"todo\",\n\
43 \ \"tags\": [\n\
44 \ \"huhu\",\n\
45 \ \"haha\"\n\
46 \ ]\n\
47 }"
48
49 let i1 = Item.{ task = "Ho"; status = Done; tags = [] }
50
51 let i1_json =
52 (* Indented JSON format. *)
53 "{\n \"task\": \"Ho\",\n \"status\": \"done\"\n}"
54end
55
56(* Codecs to exercise the different unknown member behaviours. *)
57
58module Unknown = struct
59 type t = { m : bool }
60
61 let make m = { m }
62 let m v = v.m
63
64 let skip_codec =
65 Json.Codec.Object.map ~kind:"unknown-skip" make
66 |> Json.Codec.Object.member "m" Json.Codec.bool ~enc:m
67 |> Json.Codec.Object.skip_unknown |> Json.Codec.Object.seal
68
69 let error_codec =
70 Json.Codec.Object.map ~kind:"unknown-skip" make
71 |> Json.Codec.Object.member "m" Json.Codec.bool ~enc:m
72 |> Json.Codec.Object.error_unknown |> Json.Codec.Object.seal
73
74 let keep_codec : (t * int String_map.t) Json.Codec.t =
75 let unknown = Json.Codec.Object.Members.string_map Json.Codec.int in
76 Json.Codec.Object.map ~kind:"unknown-keep" (fun m imap -> (make m, imap))
77 |> Json.Codec.Object.member "m" Json.Codec.bool ~enc:(fun (v, _) -> m v)
78 |> Json.Codec.Object.keep_unknown unknown ~enc:snd
79 |> Json.Codec.Object.seal
80end
81
82module Unknown_data = struct
83 let u0 = {| { "m": true } |}
84 let u1 = {| { "m": true, "u0": 0, "u1": 1 } |}
85 let u2 = {| { "u": 0, "m": true } |}
86end
87
88(* Object cases *)
89
90module Cases = struct
91 (* There are two ways to encode object cases in OCaml, either as a toplevel
92 variant or as a record with a field that is a variant. With the design
93 we have the encoding is mostly the same. This is the JSON we deal with:
94
95 { "type": "author",
96 "name": "…",
97 "pseudo": "…",
98 "book_count": 1 }
99
100 { "type": "editor",
101 "name": "…",
102 "publisher": "…" } *)
103
104 module Person_top = struct
105 (* Toplevel variant *)
106 module Author = struct
107 type t = { name : string; pseudo : string; book_count : int }
108
109 let make name book_count pseudo = { name; pseudo; book_count }
110 let name a = a.name
111 let book_count a = a.book_count
112 let pseudo a = a.pseudo
113
114 let codec =
115 Json.Codec.Object.map ~kind:"Author" make
116 |> Json.Codec.Object.member "name" Json.Codec.string ~enc:name
117 |> Json.Codec.Object.member "book_count" Json.Codec.int ~enc:book_count
118 |> Json.Codec.Object.member "pseudo" Json.Codec.string ~enc:pseudo
119 |> Json.Codec.Object.seal
120 end
121
122 module Editor = struct
123 type t = { name : string; publisher : string }
124
125 let make name publisher = { name; publisher }
126 let name e = e.name
127 let publisher e = e.publisher
128
129 let codec =
130 Json.Codec.Object.map ~kind:"Editor" make
131 |> Json.Codec.Object.member "name" Json.Codec.string ~enc:name
132 |> Json.Codec.Object.member "publisher" Json.Codec.string ~enc:publisher
133 |> Json.Codec.Object.seal
134 end
135
136 type t = Author of Author.t | Editor of Editor.t
137
138 let author a = Author a
139 let editor e = Editor e
140
141 let codec =
142 let case_a =
143 Json.Codec.Object.Case.map "author" Author.codec ~dec:author
144 in
145 let case_e =
146 Json.Codec.Object.Case.map "editor" Editor.codec ~dec:editor
147 in
148 let cases = Json.Codec.Object.Case.[ make case_a; make case_e ] in
149 let enc_case = function
150 | Author a -> Json.Codec.Object.Case.value case_a a
151 | Editor e -> Json.Codec.Object.Case.value case_e e
152 in
153 Json.Codec.Object.map ~kind:"Person" Fun.id
154 |> Json.Codec.Object.case_member "type" Json.Codec.string
155 ~tag_to_string:Fun.id ~enc:Fun.id ~enc_case cases
156 |> Json.Codec.Object.seal
157 end
158
159 module Person_field = struct
160 (* Variant in a field *)
161 type author = { pseudo : string; book_count : int }
162
163 let make_author pseudo book_count = { pseudo; book_count }
164 let pseudo a = a.pseudo
165 let book_count a = a.book_count
166
167 let author_codec =
168 Json.Codec.Object.map ~kind:"Author" make_author
169 |> Json.Codec.Object.member "pseudo" Json.Codec.string ~enc:pseudo
170 |> Json.Codec.Object.member "book_count" Json.Codec.int ~enc:book_count
171 |> Json.Codec.Object.seal
172
173 type editor = { publisher : string }
174
175 let make_editor publisher = { publisher }
176 let publisher e = e.publisher
177
178 let editor_codec =
179 Json.Codec.Object.map ~kind:"Editor" make_editor
180 |> Json.Codec.Object.member "publisher" Json.Codec.string ~enc:publisher
181 |> Json.Codec.Object.seal
182
183 type type' = Author of author | Editor of editor
184
185 let author a = Author a
186 let editor e = Editor e
187
188 type t = { type' : type'; name : string }
189
190 let make type' name = { type'; name }
191 let type' v = v.type'
192 let name v = v.name
193
194 let codec =
195 let case_a =
196 Json.Codec.Object.Case.map "author" author_codec ~dec:author
197 in
198 let case_e =
199 Json.Codec.Object.Case.map "editor" editor_codec ~dec:editor
200 in
201 let cases = Json.Codec.Object.Case.[ make case_a; make case_e ] in
202 let enc_case = function
203 | Author a -> Json.Codec.Object.Case.value case_a a
204 | Editor e -> Json.Codec.Object.Case.value case_e e
205 in
206 Json.Codec.Object.map ~kind:"Person" make
207 |> Json.Codec.Object.case_member "type" ~tag_to_string:Fun.id
208 Json.Codec.string ~enc:type' ~enc_case cases
209 |> Json.Codec.Object.member "name" Json.Codec.string ~enc:name
210 |> Json.Codec.Object.seal
211 end
212
213 module Keep_unknown = struct
214 type a = string String_map.t
215
216 let a_codec =
217 let unknown = Json.Codec.Object.Members.string_map Json.Codec.string in
218 Json.Codec.Object.map ~kind:"A" Fun.id
219 |> Json.Codec.Object.keep_unknown unknown ~enc:Fun.id
220 |> Json.Codec.Object.seal
221
222 type b = { name : string }
223
224 let name b = b.name
225
226 let b_codec =
227 Json.Codec.Object.map ~kind:"B" (fun name -> { name })
228 |> Json.Codec.Object.member "name" Json.Codec.string ~enc:name
229 |> Json.Codec.Object.error_unknown |> Json.Codec.Object.seal
230
231 type type' = A of a | B of b
232
233 let a a = A a
234 let b b = B b
235
236 type t = { type' : type'; unknown : Json.t }
237
238 let make type' unknown = { type'; unknown }
239 let type' v = v.type'
240 let unknown v = v.unknown
241
242 let equal v0 v1 =
243 match (v0.type', v1.type') with
244 | A a0, A a1 ->
245 String_map.equal String.equal a0 a1
246 && Json.Value.equal v0.unknown v1.unknown
247 | B b0, B b1 ->
248 String.equal b0.name b1.name && Json.Value.equal v0.unknown v1.unknown
249 | _, _ -> false
250
251 let pp ppf v = B0_std.Fmt.string ppf "<value>"
252
253 let codec =
254 let case_a = Json.Codec.Object.Case.map "A" a_codec ~dec:a in
255 let case_b = Json.Codec.Object.Case.map "B" b_codec ~dec:b in
256 let cases = Json.Codec.Object.Case.[ make case_a; make case_b ] in
257 let enc_case = function
258 | A a -> Json.Codec.Object.Case.value case_a a
259 | B b -> Json.Codec.Object.Case.value case_b b
260 in
261 Json.Codec.Object.map ~kind:"Keep_unknown" make
262 |> Json.Codec.Object.case_member "type" ~tag_to_string:Fun.id
263 Json.Codec.string ~enc:type' ~enc_case cases
264 |> Json.Codec.Object.keep_unknown Json.Codec.Value.members ~enc:unknown
265 |> Json.Codec.Object.seal
266 end
267end
268
269module Cases_data = struct
270 let author0_top, author0_field =
271 let name = "Jane" and book_count = 2 and pseudo = "Jude" in
272 ( Cases.Person_top.Author { name; book_count; pseudo },
273 { Cases.Person_field.type' = Author { book_count; pseudo }; name } )
274
275 let invalid_miss =
276 (* Missing type field. *)
277 {| { "name": "Jane", "tope": "ha", "tape": "ha",
278 "book_count": 2, "pseudo": "Jude" }|}
279
280 let invalid_case = {| { "type": "reader", "name": "Jane" }|}
281
282 let author0 =
283 {| { "type": "author", "name": "Jane", "book_count": 2, "pseudo": "Jude" }|}
284
285 let author0' =
286 (* out of order case field in the middle *)
287 {| { "name": "Jane", "book_count": 2, "type": "author", "pseudo": "Jude" }|}
288
289 let editor0_top, editor0_field =
290 let name = "Joe" and publisher = "Red books" in
291 ( Cases.Person_top.Editor { name; publisher },
292 { Cases.Person_field.type' = Editor { publisher }; name } )
293
294 let editor0 =
295 {| { "type": "editor", "name": "Joe", "publisher": "Red books" } |}
296
297 let editor0' =
298 (* out of order case field at the end *)
299 {| { "name": "Joe", "publisher": "Red books", "type": "editor" } |}
300
301 let unknown_a = {| { "m1": "n", "type": "A", "m0": "o" } |}
302 let unknown_b = {| { "type": "B", "m1": "v1", "name": "ha", "m2": 0 } |}
303
304 let unknown_a_value =
305 let unknown =
306 Json.Value.(
307 object'
308 [ member (name "m0") (string "o"); member (name "m1") (string "n") ])
309 in
310 Cases.Keep_unknown.make (A String_map.empty) unknown
311
312 let unknown_a_a_value =
313 String_map.empty |> String_map.add "m0" "o" |> String_map.add "m1" "n"
314 |> String_map.add "type" "A"
315
316 let unknown_a_no_a_unknown = "{\n \"type\": \"A\"\n}"
317
318 let unknown_a_no_a_unknown_value =
319 (* Since the map should be ignored since the case object overides it *)
320 let unknown = Json.Value.object' [] in
321 Cases.Keep_unknown.make (A String_map.(empty |> add "bli" "bla")) unknown
322
323 let unknown_b_value =
324 let unknown =
325 Json.Value.(
326 object'
327 [ member (name "m1") (string "v1"); member (name "m2") (number 0.0) ])
328 in
329 Cases.Keep_unknown.make (B { name = "ha" }) unknown
330end
331
332(* Type recursion *)
333
334module Tree = struct
335 type 'a tree = Empty | Node of 'a tree * 'a * 'a tree
336
337 let rec pp pp_v ppf = function
338 | Empty -> Format.fprintf ppf "Empty"
339 | Node (l, v, r) ->
340 Format.fprintf ppf "@[Node @[<1>(%a,@ %a,@ %a)@]@]" (pp pp_v) l pp_v v
341 (pp pp_v) r
342
343 (* Encoded with null for Empty and nodes with:
344
345 { "left": …,
346 "value": …,
347 "right": … }
348
349 and null is used for empty. *)
350 let codec_with_null t =
351 let rec tree =
352 lazy begin
353 let empty = Json.Codec.null Empty in
354 let node =
355 let not_a_node () = failwith "not a node" in
356 let value = function Node (_, v, _) -> v | _ -> not_a_node () in
357 let left = function Node (l, _, _) -> l | _ -> not_a_node () in
358 let right = function Node (_, _, r) -> r | _ -> not_a_node () in
359 Json.Codec.Object.map ~kind:"node" (fun l v r -> Node (l, v, r))
360 |> Json.Codec.Object.member ~enc:left "left" (Json.Codec.fix tree)
361 |> Json.Codec.Object.member ~enc:value "value" t
362 |> Json.Codec.Object.member ~enc:right "right" (Json.Codec.fix tree)
363 |> Json.Codec.Object.seal
364 in
365 let enc = function Empty -> empty | Node _ -> node in
366 Json.Codec.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc ()
367 end
368 in
369 Lazy.force tree
370
371 (* Encoded as two cases :
372
373 { "type": "empty" }
374
375 { "type": "node",
376 "left": …,
377 "value": …,
378 "right": … } *)
379
380 let codec_with_cases t =
381 let rec tree =
382 lazy begin
383 let leaf_codec =
384 Json.Codec.Object.map Empty |> Json.Codec.Object.seal
385 in
386 let node_codec =
387 let not_a_node () = failwith "not a node" in
388 let value = function Node (_, v, _) -> v | _ -> not_a_node () in
389 let left = function Node (l, _, _) -> l | _ -> not_a_node () in
390 let right = function Node (_, _, r) -> r | _ -> not_a_node () in
391 Json.Codec.Object.map (fun l v r -> Node (l, v, r))
392 |> Json.Codec.Object.member ~enc:left "left" (Json.Codec.fix tree)
393 |> Json.Codec.Object.member ~enc:value "value" t
394 |> Json.Codec.Object.member ~enc:right "right" (Json.Codec.fix tree)
395 |> Json.Codec.Object.seal
396 in
397 let case_leaf =
398 Json.Codec.Object.Case.map "empty" leaf_codec ~dec:Fun.id
399 in
400 let case_node =
401 Json.Codec.Object.Case.map "node" node_codec ~dec:Fun.id
402 in
403 let enc_case = function
404 | Empty as v -> Json.Codec.Object.Case.value case_leaf v
405 | Node _ as v -> Json.Codec.Object.Case.value case_node v
406 in
407 let cases = Json.Codec.Object.Case.[ make case_leaf; make case_node ] in
408 Json.Codec.Object.map ~kind:"tree" Fun.id
409 |> Json.Codec.Object.case_member "type" Json.Codec.string ~enc:Fun.id
410 ~enc_case cases
411 |> Json.Codec.Object.seal
412 end
413 in
414 Lazy.force tree
415end
416
417module Tree_data = struct
418 let empty = Tree.Empty
419 let empty_null = {| null |}
420 let empty_cases = {| { "type": "empty" } |}
421
422 let tree0 =
423 Tree.Node
424 (Node (Node (Empty, 1, Empty), 2, Empty), 3, Node (Empty, 4, Empty))
425
426 let tree0_null =
427 {| { "left": { "left": { "left": null, "value": 1, "right": null },
428 "value": 2,
429 "right": null },
430 "value": 3,
431 "right": { "left": null, "value": 4, "right": null } } |}
432
433 let tree0_cases =
434 (* Case member not in order to check decode delays. *)
435 {| { "left": { "type": "node",
436 "left": { "type": "node",
437 "left": { "type": "empty" },
438 "right": { "type": "empty" },
439 "value": 1 },
440 "value": 2,
441 "right": { "type" : "empty" }},
442 "value": 3,
443 "type": "node",
444 "right": { "type": "node",
445 "left": { "type" : "empty" },
446 "value": 4,
447 "right": { "type" : "empty" }}} |}
448end