├── BRZO ├── src ├── brr │ ├── jsont_brr.mllib │ ├── jsont_brr.mli │ └── jsont_brr.ml ├── jsont.mllib ├── bytesrw │ ├── jsont_bytesrw.mllib │ └── jsont_bytesrw.mli └── jsont_base.mli ├── test ├── expect │ ├── bool.indent.json │ ├── bool.minify.json │ ├── bool.pretty.json │ ├── invalid-array3.json │ ├── bool.json │ ├── invalid-array0.json │ ├── invalid-array2.json │ ├── invalid-obj0.json │ ├── invalid-obj2.json │ ├── invalid-array1.json │ ├── invalid-bool0.json │ ├── invalid-obj1.json │ ├── bool.layout.json │ ├── invalid-obj3.json │ ├── bool.locs │ ├── array.minify.json │ ├── invalid-obj1.stderr │ ├── invalid-obj2.stderr │ ├── array.json │ ├── array.layout.json │ ├── invalid-bool0.stderr │ ├── array.pretty.json │ ├── invalid-array1.stderr │ ├── invalid-obj3.stderr │ ├── doc.minify.json │ ├── invalid-obj0.stderr │ ├── doc.pretty.json │ ├── doc.json │ ├── doc.layout.json │ ├── invalid-array0.stderr │ ├── invalid-array2.stderr │ ├── invalid-array3.stderr │ ├── array.indent.json │ ├── doc.indent.json │ ├── array.locs │ └── doc.locs ├── test_json.ml ├── test_brr.ml ├── test_bytesrw.ml ├── trials.ml ├── quickstart.ml ├── test_seriot_suite.ml ├── json_rpc.ml ├── cookbook.ml ├── topojson.ml ├── geojson.ml ├── test_common_samples.ml └── jsont_tool.ml ├── .gitignore ├── .merlin ├── paper ├── soup.pdf ├── README.md ├── soup_test.ml ├── jfp-reject.txt └── soup.ml ├── _tags ├── LICENSE.md ├── pkg ├── pkg.ml └── META ├── DEVEL.md ├── CHANGES.md ├── attic ├── json_stat.ml └── caret.ml ├── opam ├── README.md ├── doc ├── index.mld └── cookbook.mld └── B0.ml /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg tmp) -------------------------------------------------------------------------------- /src/brr/jsont_brr.mllib: -------------------------------------------------------------------------------- 1 | Jsont_brr -------------------------------------------------------------------------------- /test/expect/bool.indent.json: -------------------------------------------------------------------------------- 1 | true -------------------------------------------------------------------------------- /test/expect/bool.minify.json: -------------------------------------------------------------------------------- 1 | true -------------------------------------------------------------------------------- /test/expect/bool.pretty.json: -------------------------------------------------------------------------------- 1 | true 2 | -------------------------------------------------------------------------------- /src/jsont.mllib: -------------------------------------------------------------------------------- 1 | Jsont_base 2 | Jsont 3 | -------------------------------------------------------------------------------- /test/expect/invalid-array3.json: -------------------------------------------------------------------------------- 1 | [1,2,3, 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *.install -------------------------------------------------------------------------------- /src/bytesrw/jsont_bytesrw.mllib: -------------------------------------------------------------------------------- 1 | Jsont_bytesrw -------------------------------------------------------------------------------- /test/expect/bool.json: -------------------------------------------------------------------------------- 1 | 2 | 3 | true 4 | 5 | -------------------------------------------------------------------------------- /test/expect/invalid-array0.json: -------------------------------------------------------------------------------- 1 | [1,2,,3] 2 | -------------------------------------------------------------------------------- /test/expect/invalid-array2.json: -------------------------------------------------------------------------------- 1 | [1,2,3,] 2 | -------------------------------------------------------------------------------- /test/expect/invalid-obj0.json: -------------------------------------------------------------------------------- 1 | { "bla": } 2 | -------------------------------------------------------------------------------- /test/expect/invalid-obj2.json: -------------------------------------------------------------------------------- 1 | { "bla": 1, } 2 | -------------------------------------------------------------------------------- /test/expect/invalid-array1.json: -------------------------------------------------------------------------------- 1 | [1, 2, 3 4,5] 2 | -------------------------------------------------------------------------------- /test/expect/invalid-bool0.json: -------------------------------------------------------------------------------- 1 | 2 | 3 | tru 4 | -------------------------------------------------------------------------------- /test/expect/invalid-obj1.json: -------------------------------------------------------------------------------- 1 | { "bla": 1, 2 } 2 | -------------------------------------------------------------------------------- /test/expect/bool.layout.json: -------------------------------------------------------------------------------- 1 | 2 | 3 | true 4 | 5 | -------------------------------------------------------------------------------- /test/expect/invalid-obj3.json: -------------------------------------------------------------------------------- 1 | { "bla": 1, "hey": "ho" 2 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit brr bytesrw 2 | S src/** 3 | S test/** 4 | B _b0/** -------------------------------------------------------------------------------- /paper/soup.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dbuenzli/jsont/main/paper/soup.pdf -------------------------------------------------------------------------------- /test/expect/bool.locs: -------------------------------------------------------------------------------- 1 | Bool true: 2 | File "bool.json", line 3, characters 2-6 3 | -------------------------------------------------------------------------------- /test/expect/array.minify.json: -------------------------------------------------------------------------------- 1 | [[],["hey",true],"something",100,{"has":true,"to":null,"be":[0,1,2,3,4,5,6,7,8,9,10],"said":{}},45,45,48] -------------------------------------------------------------------------------- /test/expect/invalid-obj1.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected object member but found 2 2 | File "invalid-obj1.json", line 1, characters 12-13: 3 | -------------------------------------------------------------------------------- /test/expect/invalid-obj2.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected object member but found } 2 | File "invalid-obj2.json", line 1, characters 12-13: 3 | -------------------------------------------------------------------------------- /test/expect/array.json: -------------------------------------------------------------------------------- 1 | [ [], ["hey", true] 2 | 3 | , "something", 4 | 1e2 , 5 | { "has": true, "to": 6 | null, "be": [0,1,2,3,4,5,6,7,8,9,10], "said": {}}, 7 | 45, 45, 48 ] 8 | -------------------------------------------------------------------------------- /test/expect/array.layout.json: -------------------------------------------------------------------------------- 1 | [ [], ["hey", true] 2 | 3 | , "something", 4 | 100 , 5 | { "has": true, "to": 6 | null, "be": [0,1,2,3,4,5,6,7,8,9,10], "said": {}}, 7 | 45, 45, 48 ] 8 | -------------------------------------------------------------------------------- /test/expect/invalid-bool0.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected e while parsing true but found: U+000A 2 | File "invalid-bool0.json", lines 3-4, characters 2-0: 3 | -------------------------------------------------------------------------------- /test/expect/array.pretty.json: -------------------------------------------------------------------------------- 1 | [[], ["hey", true], "something", 100, 2 | { 3 | "has": true, 4 | "to": null, 5 | "be": [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10], 6 | "said": {} 7 | }, 45, 45, 48] 8 | -------------------------------------------------------------------------------- /test/expect/invalid-array1.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected , or ] after array element but found 4 2 | File "invalid-array1.json", line 1, characters 11-12: 3 | -------------------------------------------------------------------------------- /test/expect/invalid-obj3.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected , or } after object member but found: end of text 2 | File "invalid-obj3.json", line 2, characters 0-1: 3 | -------------------------------------------------------------------------------- /test/expect/doc.minify.json: -------------------------------------------------------------------------------- 1 | {"name":"hey","version":1.45,"deprecated":false,"ignore":["README.md","LICENSE.md"],"other":[{"a":1},{"a":2},{"a":3},{"a":4},{"a":5},{"a":6},{"a":7},{"hu":null}],"metameta":true,"obj":{"magic":null}} -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | <_b0> : -traverse 3 | : include 4 | 5 | : include 6 | : package(bytesrw) 7 | 8 | : package(brr) 9 | : package(cmdliner bytesrw) -------------------------------------------------------------------------------- /test/expect/invalid-obj0.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected JSON value but found } 2 | File "invalid-obj0.json", line 1, characters 9-10: 3 | File "invalid-obj0.json": in member bla of 4 | File "invalid-obj0.json", line 1, characters 0-10: object 5 | -------------------------------------------------------------------------------- /test/expect/doc.pretty.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "hey", 3 | "version": 1.45, 4 | "deprecated": false, 5 | "ignore": ["README.md", "LICENSE.md"], 6 | "other": [{"a": 1}, {"a": 2}, {"a": 3}, {"a": 4}, {"a": 5}, {"a": 6}, 7 | {"a": 7}, {"hu": null}], 8 | "metameta": true, 9 | "obj": {"magic": null} 10 | } 11 | -------------------------------------------------------------------------------- /test/expect/doc.json: -------------------------------------------------------------------------------- 1 | { "name": "hey", 2 | "version": 1.45, 3 | "deprecated": false , 4 | "ignore": ["README.md", 5 | "LICENSE.md"], 6 | "other": [{ "a": 1 }, {"a": 2 }, {"a": 3 }, {"a": 4 }, {"a": 5 }, {"a": 6 }, {"a":7}, {"hu":null }], 7 | "metameta": true, 8 | "obj": 9 | { "magic": null } 10 | } 11 | -------------------------------------------------------------------------------- /test/expect/doc.layout.json: -------------------------------------------------------------------------------- 1 | { "name": "hey", 2 | "version": 1.45, 3 | "deprecated": false , 4 | "ignore": ["README.md", 5 | "LICENSE.md"], 6 | "other": [{ "a": 1 }, {"a": 2 }, {"a": 3 }, {"a": 4 }, {"a": 5 }, {"a": 6 }, {"a":7}, {"hu":null }], 7 | "metameta": true, 8 | "obj": 9 | { "magic": null } 10 | } 11 | -------------------------------------------------------------------------------- /test/expect/invalid-array0.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected JSON value but found , 2 | File "invalid-array0.json", line 1, characters 7-8: 3 | File "invalid-array0.json", line 1, characters 7-8: at index 2 of 4 | File "invalid-array0.json", line 1, characters 2-8: array 5 | -------------------------------------------------------------------------------- /test/expect/invalid-array2.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected JSON value but found ] 2 | File "invalid-array2.json", line 1, characters 7-8: 3 | File "invalid-array2.json", line 1, characters 7-8: at index 3 of 4 | File "invalid-array2.json", line 1, characters 0-8: array 5 | -------------------------------------------------------------------------------- /test/expect/invalid-array3.stderr: -------------------------------------------------------------------------------- 1 | jsont: Error: Expected JSON value but found end of text 2 | File "invalid-array3.json", line 2, characters 0-1: 3 | File "invalid-array3.json", line 2, characters 0-1: at index 3 of 4 | File "invalid-array3.json", lines 1-2, characters 0-1: array 5 | -------------------------------------------------------------------------------- /test/expect/array.indent.json: -------------------------------------------------------------------------------- 1 | [ 2 | [], 3 | [ 4 | "hey", 5 | true 6 | ], 7 | "something", 8 | 100, 9 | { 10 | "has": true, 11 | "to": null, 12 | "be": [ 13 | 0, 14 | 1, 15 | 2, 16 | 3, 17 | 4, 18 | 5, 19 | 6, 20 | 7, 21 | 8, 22 | 9, 23 | 10 24 | ], 25 | "said": {} 26 | }, 27 | 45, 28 | 45, 29 | 48 30 | ] -------------------------------------------------------------------------------- /test/expect/doc.indent.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "hey", 3 | "version": 1.45, 4 | "deprecated": false, 5 | "ignore": [ 6 | "README.md", 7 | "LICENSE.md" 8 | ], 9 | "other": [ 10 | { 11 | "a": 1 12 | }, 13 | { 14 | "a": 2 15 | }, 16 | { 17 | "a": 3 18 | }, 19 | { 20 | "a": 4 21 | }, 22 | { 23 | "a": 5 24 | }, 25 | { 26 | "a": 6 27 | }, 28 | { 29 | "a": 7 30 | }, 31 | { 32 | "hu": null 33 | } 34 | ], 35 | "metameta": true, 36 | "obj": { 37 | "magic": null 38 | } 39 | } -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) 2024 The jsont programmers 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 10 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 11 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 13 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 14 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let cmdliner = Conf.with_pkg "cmdliner" 7 | let bytesrw = Conf.with_pkg "bytesrw" 8 | let brr = Conf.with_pkg "brr" 9 | let () = 10 | Pkg.describe "jsont" @@ fun c -> 11 | let cmdliner = Conf.value c cmdliner in 12 | let bytesrw = Conf.value c bytesrw in 13 | let brr = Conf.value c brr in 14 | Ok [ Pkg.mllib ~api:["Jsont"] "src/jsont.mllib"; 15 | Pkg.mllib ~cond:bytesrw 16 | ~dst_dir:"bytesrw" "src/bytesrw/jsont_bytesrw.mllib"; 17 | Pkg.mllib ~cond:brr ~dst_dir:"brr" "src/brr/jsont_brr.mllib"; 18 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 19 | Pkg.doc "doc/cookbook.mld" ~dst:"odoc-pages/cookbook.mld"; 20 | Pkg.bin ~cond:(cmdliner && bytesrw) "test/jsont_tool" ~dst:"jsont"; ] 21 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Declarative JSON data manipulation for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "jsont.cma" 5 | archive(native) = "jsont.cmxa" 6 | plugin(byte) = "jsont.cma" 7 | plugin(native) = "jsont.cmxs" 8 | exists_if = "jsont.cma jsont.cmxa" 9 | 10 | package "brr" ( 11 | directory = "brr" 12 | description = "The jsont.brr library" 13 | version = "%%VERSION_NUM%%" 14 | requires = "brr jsont" 15 | exports = "brr jsont" 16 | archive(byte) = "jsont_brr.cma" 17 | archive(native) = "jsont_brr.cmxa" 18 | plugin(byte) = "jsont_brr.cma" 19 | plugin(native) = "jsont_brr.cmxs" 20 | exists_if = "jsont_brr.cma jsont_brr.cmxa" 21 | ) 22 | 23 | package "bytesrw" ( 24 | directory = "bytesrw" 25 | description = "The jsont.bytesrw library" 26 | version = "%%VERSION_NUM%%" 27 | requires = "bytesrw jsont" 28 | exports = "bytesrw jsont" 29 | archive(byte) = "jsont_bytesrw.cma" 30 | archive(native) = "jsont_bytesrw.cmxa" 31 | plugin(byte) = "jsont_bytesrw.cma" 32 | plugin(native) = "jsont_bytesrw.cmxs" 33 | exists_if = "jsont_bytesrw.cma jsont_bytesrw.cmxa" 34 | ) 35 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | This project uses (perhaps the development version of) [`b0`] for 2 | development. Consult [b0 occasionally] for quick hints on how to 3 | perform common development tasks. 4 | 5 | [`b0`]: https://erratique.ch/software/b0 6 | [b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html 7 | 8 | # Testing 9 | 10 | b0 test 11 | 12 | # Testing the codec with Nicolas Seriot's test suite 13 | 14 | b0 -- download-seriot-suite 15 | b0 test 16 | 17 | # Benchmarking 18 | 19 | ## Decode only 20 | 21 | hyperfine 'json_xs -t none < tmp/parcels.json' 22 | hyperfine 'jsontrip -dec tmp/parcels.json' 23 | hyperfine "$(b0 --path -- jsont) fmt -d tmp/parcels.json" 24 | hyperfine "$(b0 --path -- geojson) -d tmp/parcels.json" 25 | 26 | ## Decode and minify 27 | 28 | hyperfine 'json_xs -t json < tmp/parcels.json' 29 | hyperfine 'jq -c . tmp/parcels.json' 30 | hyperfine 'ydump -std -c tmp/parcels.json' 31 | hyperfine 'jsontrip tmp/parcels.json' 32 | hyperfine "$(b0 --path -- jsont) fmt -fminify tmp/parcels.json" 33 | hyperfine "$(b0 --path -- geojson) tmp/parcels.json" 34 | 35 | 36 | -------------------------------------------------------------------------------- /test/test_json.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_std 7 | open B0_testing 8 | 9 | (* Tests the common test suite with the Jsont.Json codec. *) 10 | 11 | (* Since the Jsont.Json codec works only on Jsont.json values we use 12 | Jsont_bytesrw to codec JSON to Jsont.json values and then apply the 13 | Jsont.Json codec. So the tests rely on a working Jsont_bytesrw 14 | codec *) 15 | 16 | let decode ?layout t json = 17 | match Jsont_bytesrw.decode_string ?layout ~locs:true Jsont.json json with 18 | | Error _ as e -> e 19 | | Ok json -> Jsont.Json.decode t json 20 | 21 | let encode ?format t v = 22 | match Jsont.Json.encode t v with 23 | | Error _ as e -> e 24 | | Ok json -> Jsont_bytesrw.encode_string ?format Jsont.json json 25 | 26 | let test_funs = { Test_common.supports_layout = true; decode; encode } 27 | 28 | let main () = 29 | Test.main @@ fun () -> 30 | Test_common.test_funs := test_funs; 31 | Test_common.tests (); 32 | () 33 | 34 | let () = if !Sys.interactive then () else exit (main ()) 35 | -------------------------------------------------------------------------------- /test/test_brr.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Brr 7 | open B0_testing 8 | 9 | (* Tests the common test suite with the Jsont_brr codec. *) 10 | 11 | let error_to_string e = Jstr.to_string (Jv.Error.message e) 12 | 13 | let decode ?layout t json = 14 | Result.map_error error_to_string @@ Jsont_brr.decode t (Jstr.v json) 15 | 16 | let encode ?format t v = match Jsont_brr.encode ?format t v with 17 | | Ok v -> Ok (Jstr.to_string v) | Error e -> Error (error_to_string e) 18 | 19 | let test_funs = { Test_common.supports_layout = false; decode; encode } 20 | 21 | let main () = 22 | let exit = Test.main @@ fun () -> 23 | Test_common.test_funs := test_funs; 24 | Test_common.tests (); 25 | in 26 | let result = if exit = 0 then "All tests passed!" else "Some tests FAILED!" in 27 | let children = 28 | [ El.h1 [ El.txt' "Jsont_brr tests" ]; 29 | El.p [ El.txt' result]; 30 | El.p [ El.txt' "Open the browser console for details."] ] 31 | in 32 | El.set_children (Document.body G.document) children 33 | 34 | let () = if !Sys.interactive then () else main () 35 | -------------------------------------------------------------------------------- /test/test_bytesrw.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_std 7 | open B0_testing 8 | open Bytesrw 9 | 10 | (* Tests the common test suite with the Jsont_bytesrw codec. *) 11 | 12 | let decode ?layout t json = 13 | Jsont_bytesrw.decode_string ?layout ~locs:true t json 14 | 15 | let encode ?format t v = Jsont_bytesrw.encode_string ?format t v 16 | let test_funs = { Test_common.supports_layout = true; decode; encode } 17 | 18 | (* Other tests *) 19 | 20 | let test_eod = 21 | Test.test "Jsont_bytesrw.encode ~eod" @@ fun () -> 22 | let b = Buffer.create 255 in 23 | let w = Bytes.Writer.of_buffer b in 24 | let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:false w) in 25 | let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:true w) in 26 | Test.string (Buffer.contents b) "truetrue"; 27 | Snap.raise (fun () -> Jsont_bytesrw.encode' Jsont.bool true ~eod:true w) @@ 28 | __POS_OF__ (Invalid_argument("slice written after eod")); 29 | () 30 | 31 | let main () = 32 | Test.main @@ fun () -> 33 | Test_common.test_funs := test_funs; 34 | Test.autorun (); 35 | () 36 | 37 | let () = if !Sys.interactive then () else exit (main ()) 38 | -------------------------------------------------------------------------------- /test/trials.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | module Message = struct 7 | type t = { content : string; public : bool } 8 | let make content public = { content; public } 9 | let content msg = msg.content 10 | let public msg = msg.public 11 | let jsont : t Jsont.t = 12 | Jsont.Object.map make 13 | |> Jsont.Object.mem "content" Jsont.string ~enc:content 14 | |> Jsont.Object.mem "public" Jsont.bool ~enc:public 15 | |> Jsont.Object.finish 16 | end 17 | 18 | type ('ret, 'f) app = 19 | | Fun : 'f -> ('ret, 'f) app 20 | | App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app 21 | 22 | let ret : 'f -> ('ret, 'f) app = fun f -> Fun f 23 | let app : ('ret, 'a -> 'b) app -> 'a -> ('ret, 'b) app = fun f a -> App (f, a) 24 | 25 | let g ~i ~s = string_of_int i ^ s 26 | 27 | let t0 : (string, string) app = 28 | app (app (ret (fun i s -> g ~i ~s)) 2) "bla" 29 | 30 | (* That works but it's not the tructure that we want. *) 31 | 32 | let ( let+ ) : 'a -> ('a -> 'b) -> ('ret, 'b) app = fun v f -> App (Fun f, v) 33 | let ( and+ ) : 'a -> 'b -> 'a * 'b = fun x y -> (x, y) 34 | 35 | let t1 : (string, string) app = 36 | let+ i = 2 37 | and+ s = "bla" in 38 | g ~i ~s 39 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.2.0 2025-07-25 Zagreb 2 | ------------------------ 3 | 4 | - Fix `Jsont_bytesrw.{encode,encode'}`. Do not write the `eod` slice if 5 | `eod:false` is specified. Thanks to Benjamin Nguyen-Van-Yen for 6 | the report and the fix (#8). 7 | - Fix `Jsont.zero` failing encodes rather than encoding `null` as 8 | advertised. Thanks to Adrián Montesinos González for the report (#6). 9 | - Add `Jsont.Error.expected` to help format error messages. 10 | - Add `Jsont.with_doc` to update kind and doc strings of existing JSON 11 | types. 12 | - Add `Jsont.Object.Case.{tag,map_tag}` to access a case and case map tags. 13 | - Fix `META` file. Really export all requires and 14 | remove uneeded `bytesrw` dependency from `jsont` library. 15 | 16 | v0.1.1 2024-12-06 La Forclaz (VS) 17 | --------------------------------- 18 | 19 | - `Jsont.Object.Mems.map` make encoding and decoding optional. Like 20 | in every other map. 21 | - `Jsont.Array.map` make encoding and decoding optional. Like 22 | in every other map. 23 | - `Jsont_bytesrw.encode` change the default buffer size 24 | to match the one hinted by the writer rather than 25 | `Bytesrw.Bytes.Slice.io_buffer_size`. 26 | - `jsont.{bytesrw,brr}` export all requires. 27 | - `jsont` tool remove spurious dependency on `b0.std` (#2). 28 | 29 | v0.1.0 2024-11-29 Zagreb 30 | ------------------------ 31 | 32 | First release. 33 | 34 | Supported by a grant from the OCaml Software Foundation. 35 | -------------------------------------------------------------------------------- /attic/json_stat.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* https://json-stat.org/ *) 7 | 8 | open Jsonit 9 | 10 | module Int_map = Map.Make (Int) 11 | module String_map = Map.Make (String) 12 | 13 | type 'a vec = Array of 'a list | Sparse of 'a Int_map.t 14 | 15 | type status = 16 | | All of string 17 | | Vec of string vec 18 | 19 | type index = (* ?? *) 20 | | Array of string list 21 | | Map of int String_map.t 22 | 23 | type category = 24 | { index : index; 25 | label : string String_map.t } 26 | 27 | type date = 28 | (* https://262.ecma-international.org/6.0/#sec-date-time-string-format *) 29 | string 30 | 31 | module Dimension_id = struct 32 | type t = 33 | { category : Json.obj; 34 | label : string option; 35 | extension : Json.obj option; } 36 | end 37 | 38 | 39 | type dataset = 40 | { id : string list; 41 | size : int list; 42 | value : float vec; 43 | dimension : Dimension_id.t String_map.t; 44 | status : status vec option; 45 | label : string option; 46 | source : string option; 47 | updated : date option; 48 | extension : Json.obj option; } 49 | 50 | type collection = unit 51 | 52 | type class' = 53 | | Dataset of dataset 54 | | Dimension of Dimension_id.t 55 | | Collection of collection 56 | 57 | type t = 58 | { version : string; 59 | class' : class'; } 60 | -------------------------------------------------------------------------------- /test/quickstart.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Examples from the docs *) 7 | 8 | let data = 9 | {|{ "task": "Make new release", 10 | "status": "todo", 11 | "tags": ["work", "softwre"] }|} 12 | 13 | let () = 14 | let p = Jsont.Path.(root |> mem "tags" |> nth 1) in 15 | let update = Jsont.(set_path string p "software") in 16 | let correct = Jsont_bytesrw.recode_string ~layout:true update data in 17 | print_endline (Result.get_ok correct) 18 | 19 | module Status = struct 20 | type t = Todo | Done | Cancelled 21 | let assoc = ["todo", Todo; "done", Done; "cancelled", Cancelled ] 22 | let jsont = Jsont.enum ~kind:"Status" assoc 23 | end 24 | 25 | module Item = struct 26 | type t = { task : string; status : Status.t; tags : string list; } 27 | let make task status tags = { task; status; tags } 28 | let task i = i.task 29 | let status i = i.status 30 | let tags i = i.tags 31 | let jsont = 32 | Jsont.Object.map ~kind:"Item" make 33 | |> Jsont.Object.mem "task" Jsont.string ~enc:task 34 | |> Jsont.Object.mem "status" Status.jsont ~enc:status 35 | |> Jsont.Object.mem "tags" Jsont.(list string) ~enc:tags 36 | ~dec_absent:[] ~enc_omit:(( = ) []) 37 | |> Jsont.Object.finish 38 | end 39 | 40 | let items = Jsont.list Item.jsont 41 | let items_of_json s = Jsont_bytesrw.decode_string items s 42 | let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is 43 | -------------------------------------------------------------------------------- /paper/README.md: -------------------------------------------------------------------------------- 1 | This is a [paper] written as a functional pearl about the general 2 | technique used by the library. It was [rejected] by the [Journal of 3 | Functional Progamming][jfp] but I don't have the time and energy to 4 | significantly rewrite it (see below). 5 | 6 | I think it's readable in its current form if you are an OCaml 7 | programmer and either want to understand how the library works or to 8 | apply the technique on other generic data formats. 9 | 10 | [paper]: soup.pdf 11 | [rejected]: jfp-reject.txt 12 | [jfp]: https://www.cambridge.org/core/journals/journal-of-functional-programming 13 | 14 | 15 | ## Rewrite (if ever happens) 16 | 17 | - Address reviewer comments and their misunderstandings. 18 | 19 | Part of the problem is that we wanted to expose a real world 20 | blueprint of a technique, have it as a pearl and limit the 21 | exposition to fit on 15 pages (self-imposed). 22 | 23 | Now we have the following conflicting complaints: 24 | 25 | - It's too technical and detailed for a pearl. It's not "joyful" enough. 26 | Indeed it's a very boring exposition of the full details it takes to 27 | have an ergonomic system in ML for dealing with the serialisation disaster 28 | that JSON is. 29 | - There are not enough motivating examples and details about design choices 30 | (though honestly there's not thousands ways to construct and deconstruct 31 | an array) and we get complaints that we do not reference related works. 32 | 33 | So if anything it should likely rather be turned into a regular 34 | academic paper but I'm not sure it's worth the effort. The document 35 | as it stands is likely already useful for a motivated individual. 36 | 37 | - Like was eventually done in `jsont`, also have an optional 38 | `unknowns_mems` in `Obj_cases` shapes. This makes the exposition 39 | slightly more complex though as we need to talk about the overriding 40 | behaviour. 41 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "jsont" 3 | synopsis: "Declarative JSON data manipulation for OCaml" 4 | description: """\ 5 | Jsont is an OCaml library for declarative JSON data manipulation. It 6 | provides: 7 | 8 | - Combinators for describing JSON data using the OCaml values of your 9 | choice. The descriptions can be used by generic functions to 10 | decode, encode, query and update JSON data without having to 11 | construct a generic JSON representation. 12 | - A JSON codec with optional text location tracking and layout 13 | preservation. The codec is compatible with effect-based concurrency. 14 | 15 | The descriptions are independent from the codec and can be used by 16 | third-party processors or codecs. 17 | 18 | Jsont is distributed under the ISC license. It has no dependencies. 19 | The codec is optional and depends on the [`bytesrw`] library. The JavaScript 20 | support is optional and depends on the [`brr`] library. 21 | 22 | Homepage: 23 | 24 | [`bytesrw`]: https://erratique.ch/software/bytesrw 25 | [`brr`]: https://erratique.ch/software/brr""" 26 | maintainer: "Daniel Bünzli " 27 | authors: "The jsont programmers" 28 | license: "ISC" 29 | tags: ["json" "codec" "org:erratique"] 30 | homepage: "https://erratique.ch/software/jsont" 31 | doc: "https://erratique.ch/software/jsont/doc" 32 | bug-reports: "https://github.com/dbuenzli/jsont/issues" 33 | depends: [ 34 | "ocaml" {>= "4.14.0"} 35 | "ocamlfind" {build} 36 | "ocamlbuild" {build} 37 | "topkg" {build & >= "1.1.0"} 38 | "b0" {dev & with-test} 39 | ] 40 | depopts: ["cmdliner" "brr" "bytesrw"] 41 | conflicts: [ 42 | "cmdliner" {< "1.3.0"} 43 | "brr" {< "0.0.6"} 44 | ] 45 | build: [ 46 | "ocaml" 47 | "pkg/pkg.ml" 48 | "build" 49 | "--dev-pkg" 50 | "%{dev}%" 51 | "--with-cmdliner" 52 | "%{cmdliner:installed}%" 53 | "--with-bytesrw" 54 | "%{bytesrw:installed}%" 55 | "--with-brr" 56 | "%{brr:installed}%" 57 | ] 58 | dev-repo: "git+https://erratique.ch/repos/jsont.git" 59 | x-maintenance-intent: ["(latest)"] 60 | -------------------------------------------------------------------------------- /test/expect/array.locs: -------------------------------------------------------------------------------- 1 | Array: 2 | File "array.json", lines 1-7, characters 0-14 3 | Array: 4 | File "array.json", line 1, characters 2-4 5 | 6 | Array: 7 | File "array.json", line 1, characters 6-19 8 | String "hey": 9 | File "array.json", line 1, characters 7-12 10 | 11 | Bool true: 12 | File "array.json", line 1, characters 14-18 13 | 14 | String "something": 15 | File "array.json", line 3, characters 11-22 16 | 17 | Number 100: 18 | File "array.json", line 4, characters 2-5 19 | 20 | Object: 21 | File "array.json", lines 5-6, characters 2-54 22 | Member "has": 23 | File "array.json", line 5, characters 5-10 24 | Bool true: 25 | File "array.json", line 5, characters 12-16 26 | 27 | Member "to": 28 | File "array.json", line 5, characters 18-22 29 | null: 30 | File "array.json", line 6, characters 5-9 31 | 32 | Member "be": 33 | File "array.json", line 6, characters 11-15 34 | Array: 35 | File "array.json", line 6, characters 17-41 36 | Number 0: 37 | File "array.json", line 6, characters 18-19 38 | 39 | Number 1: 40 | File "array.json", line 6, characters 20-21 41 | 42 | Number 2: 43 | File "array.json", line 6, characters 22-23 44 | 45 | Number 3: 46 | File "array.json", line 6, characters 24-25 47 | 48 | Number 4: 49 | File "array.json", line 6, characters 26-27 50 | 51 | Number 5: 52 | File "array.json", line 6, characters 28-29 53 | 54 | Number 6: 55 | File "array.json", line 6, characters 30-31 56 | 57 | Number 7: 58 | File "array.json", line 6, characters 32-33 59 | 60 | Number 8: 61 | File "array.json", line 6, characters 34-35 62 | 63 | Number 9: 64 | File "array.json", line 6, characters 36-37 65 | 66 | Number 10: 67 | File "array.json", line 6, characters 38-40 68 | 69 | Member "said": 70 | File "array.json", line 6, characters 43-49 71 | Object: 72 | File "array.json", line 6, characters 51-53 73 | 74 | Number 45: 75 | File "array.json", line 7, characters 2-4 76 | 77 | Number 45: 78 | File "array.json", line 7, characters 6-8 79 | 80 | Number 48: 81 | File "array.json", line 7, characters 10-12 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Jsont – Declarative JSON data manipulation for OCaml 2 | ==================================================== 3 | 4 | Jsont is an OCaml library for declarative JSON data manipulation. It 5 | provides: 6 | 7 | - Combinators for describing JSON data using the OCaml values of your 8 | choice. The descriptions can be used by generic functions to 9 | decode, encode, query and update JSON data without having to 10 | construct a generic JSON representation. 11 | - A JSON codec with optional text location tracking and layout 12 | preservation. The codec is compatible with effect-based concurrency. 13 | 14 | The descriptions are independent from the codec and can be used by 15 | third-party processors or codecs. 16 | 17 | Jsont is distributed under the ISC license. It has no dependencies. 18 | The codec is optional and depends on the [`bytesrw`] library. The JavaScript 19 | support is optional and depends on the [`brr`] library. 20 | 21 | Homepage: 22 | 23 | [`bytesrw`]: https://erratique.ch/software/bytesrw 24 | [`brr`]: https://erratique.ch/software/brr 25 | 26 | ## Installation 27 | 28 | Jsont can be installed with `opam`: 29 | 30 | opam install jsont 31 | opam install jsont bytesrw # For the optional codec support 32 | opam install jsont brr # For the optional JavaScript support 33 | opam install jsont bytesrw cmdliner # For the jsont tool 34 | 35 | ## Documentation 36 | 37 | The documentation can be consulted [online] or via `odig doc jsont`. 38 | 39 | Questions are welcome but better asked on the [OCaml forum] than on the 40 | issue tracker. 41 | 42 | [online]: https://erratique.ch/software/jsont/doc 43 | [OCaml forum]: https://discuss.ocaml.org/ 44 | 45 | ## Examples 46 | 47 | A few examples can be found in the [documentation][online] and in the 48 | [test](test/) directory. The [`test/topojson.ml`], 49 | [`test/geojson.ml`], [`test/json_rpc.ml`], show use of the library on 50 | concrete JSON data formats. 51 | 52 | [`test/topojson.ml`]: test/topojson.ml 53 | [`test/geojson.ml`]: test/geojson.ml 54 | [`test/json_rpc.ml`]: test/json_rpc.ml 55 | 56 | ## Paper & technique 57 | 58 | If you want to understand the *finally tagged* technique used by the 59 | library, the [`paper/soup.ml`] source implements the abridged version 60 | of the underlying data type used in [the paper]. 61 | 62 | [the paper]: paper/ 63 | [`paper/soup.ml`]: paper/soup.ml 64 | 65 | ## Acknowledgments 66 | 67 | A grant from the [OCaml Software Foundation] helped to bring the first 68 | public release of `jsont`. 69 | 70 | [OCaml Software Foundation]: http://ocaml-sf.org/ 71 | -------------------------------------------------------------------------------- /test/test_seriot_suite.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Runs the codec on https://github.com/nst/JSONTestSuite *) 7 | 8 | open B0_std 9 | open B0_testing 10 | open Result.Syntax 11 | 12 | let status_of_filename name = 13 | if String.starts_with ~prefix:"y_" name then `Accept else 14 | if String.starts_with ~prefix:"n_" name then `Reject else 15 | if String.starts_with ~prefix:"i_" name then `Indeterminate else 16 | Test.failstop "Unknown kind of test: %s" name 17 | 18 | let test ~show_errors file = 19 | let name = Fpath.basename file in 20 | Test.test name @@ fun () -> 21 | Test.noraise ~__POS__ @@ fun () -> 22 | Result.get_ok' @@ 23 | let* json = Os.File.read file in 24 | let status = status_of_filename name in 25 | let file = Fpath.to_string file in 26 | match Jsont_bytesrw.decode_string ~file ~locs:true Jsont.json json with 27 | | Ok _ -> 28 | if status = `Accept || status = `Indeterminate 29 | then Ok () 30 | else (Test.failstop " @[Should have been rejected:@,%s@]" json) 31 | | Error e -> 32 | if show_errors then Log.err (fun m -> m "%s" e); 33 | if status = `Reject || status = `Indeterminate 34 | then Ok () 35 | else (Test.failstop " @[Should have been accepted:@,%s@]" json) 36 | 37 | let run ~dir ~show_errors = 38 | let dir = Fpath.v dir in 39 | Log.if_error ~use:1 @@ 40 | let* exists = Os.Dir.exists dir in 41 | if not exists 42 | then begin 43 | Fmt.pr "@[%a @[JSONTestSuite not found@,\ 44 | Use %a to download it@]@]" Test.Fmt.skip () 45 | Fmt.code "b0 -- download-seriot-suite"; 46 | Ok 0 47 | end else 48 | let dir = Fpath.(dir / "test_parsing") in 49 | let* files = Os.Dir.fold_files ~recurse:false Os.Dir.path_list dir [] in 50 | Result.ok @@ Test.main @@ fun () -> 51 | List.iter (fun file -> test ~show_errors file ()) files 52 | 53 | open Cmdliner 54 | open Cmdliner.Term.Syntax 55 | 56 | let cmd = 57 | let doc = "Run Nicolas Seriot's JSON test suite" in 58 | Cmd.v (Cmd.info "test_seriot_suite" ~doc) @@ 59 | let+ show_errors = 60 | let doc = "Show errors" in 61 | Arg.(value & flag & info ["e"; "show-errors"] ~doc) 62 | and+ dir = 63 | let doc = "Repository directory of the test suite." in 64 | Arg.(value & pos 0 dir "tmp/JSONTestSuite" & info [] ~doc ~docv:"REPO") 65 | in 66 | run ~dir ~show_errors 67 | 68 | let main () = Cmd.eval' cmd 69 | let () = if !Sys.interactive then () else exit (main ()) 70 | -------------------------------------------------------------------------------- /src/brr/jsont_brr.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** JavaScript support. 7 | 8 | {b Note.} These functions incur a bit of overhead but should work 9 | fast enough for medium sized structures. Get in touch if you run 10 | into problems, some improvements may be possible. 11 | 12 | The JSON functions use JavaScript's 13 | {{:https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Global_Objects/JSON/parse}[JSON.parse]} and 14 | {{:https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify}[JSON.stringify]} to convert to JavaScript values 15 | which are then converted with {!decode_jv} and {!encode_jv}. Parse 16 | locations and layout preservation are unsupported. *) 17 | 18 | (** {1:decode Decode} *) 19 | 20 | val decode : 'a Jsont.t -> Jstr.t -> ('a, Jv.Error.t) result 21 | (** [decode t s] decodes the JSON data [s] according to [t]. *) 22 | 23 | val decode' : 'a Jsont.t -> Jstr.t -> ('a, Jsont.Error.t) result 24 | (** [decode' t s] is like {!val-decode} but preserves the error structure. *) 25 | 26 | val decode_jv : 'a Jsont.t -> Jv.t -> ('a, Jv.Error.t) result 27 | (** [decode_jv t v] decodes the JavaScript value [v] according to [t]. *) 28 | 29 | val decode_jv' : 'a Jsont.t -> Jv.t -> ('a, Jsont.Error.t) result 30 | (** [decode_jv'] is like {!decode_jv'} but preserves the error structure. *) 31 | 32 | (** {1:encode Encode} *) 33 | 34 | val encode : 35 | ?format:Jsont.format -> 'a Jsont.t -> 'a -> (Jstr.t, Jv.Error.t) result 36 | (** [encode t v] encodes [v] to JSON according to [t]. [format] 37 | specifies how the JSON is formatted, defaults to 38 | {!Jsont.Minify}. The {!Jsont.Layout} format is unsupported, 39 | {!Jsont.Indent} is used instead. *) 40 | 41 | val encode' : 42 | ?format:Jsont.format -> 'a Jsont.t -> 'a -> (Jstr.t, Jsont.Error.t) result 43 | (** [encode'] is like {!val-encode} but preserves the error structure. 44 | [format] specifies how the JSON is formatted, defaults to 45 | {!Jsont.Minify}. The {!Jsont.Layout} format is unsupported, 46 | {!Jsont.Indent} is used instead. *) 47 | 48 | val encode_jv : 'a Jsont.t -> 'a -> (Jv.t, Jv.Error.t) result 49 | (** [encode_jv t v] encodes [v] to a JavaScript value according to [t]. *) 50 | 51 | val encode_jv' : 'a Jsont.t -> 'a -> (Jv.t, Jsont.Error.t) result 52 | (** [encode_jv'] is like {!val-encode_jv} but preserves the error structure. *) 53 | 54 | (** {1:recode Recode} *) 55 | 56 | val recode : ?format:Jsont.format -> 'a Jsont.t -> Jstr.t -> 57 | (Jstr.t, Jv.Error.t) result 58 | (** [recode] is {!val-decode} followed by {!val-encode}. *) 59 | 60 | val recode' : ?format:Jsont.format -> 'a Jsont.t -> Jstr.t -> 61 | (Jstr.t, Jsont.Error.t) result 62 | (** [recode] is {!val-decode'} followed by {!val-encode'}. *) 63 | 64 | val recode_jv : 'a Jsont.t -> Jv.t -> (Jv.t, Jv.Error.t) result 65 | (** [recode] is {!val-decode} followed by {!val-encode}. *) 66 | 67 | val recode_jv' : 'a Jsont.t -> Jv.t -> (Jv.t, Jsont.Error.t) result 68 | (** [recode] is {!val-decode_jv'} followed by {!encode_jv'}. *) 69 | -------------------------------------------------------------------------------- /test/expect/doc.locs: -------------------------------------------------------------------------------- 1 | Object: 2 | File "doc.json", lines 1-10, characters 0-1 3 | Member "name": 4 | File "doc.json", line 1, characters 2-8 5 | String "hey": 6 | File "doc.json", line 1, characters 10-15 7 | 8 | Member "version": 9 | File "doc.json", line 2, characters 2-11 10 | Number 1.45: 11 | File "doc.json", line 2, characters 13-17 12 | 13 | Member "deprecated": 14 | File "doc.json", line 3, characters 2-14 15 | Bool false: 16 | File "doc.json", line 3, characters 16-21 17 | 18 | Member "ignore": 19 | File "doc.json", line 4, characters 2-10 20 | Array: 21 | File "doc.json", lines 4-5, characters 12-30 22 | String "README.md": 23 | File "doc.json", line 4, characters 13-24 24 | 25 | String "LICENSE.md": 26 | File "doc.json", line 5, characters 17-29 27 | 28 | Member "other": 29 | File "doc.json", line 6, characters 2-9 30 | Array: 31 | File "doc.json", line 6, characters 11-105 32 | Object: 33 | File "doc.json", line 6, characters 12-22 34 | Member "a": 35 | File "doc.json", line 6, characters 14-17 36 | Number 1: 37 | File "doc.json", line 6, characters 19-20 38 | 39 | Object: 40 | File "doc.json", line 6, characters 25-34 41 | Member "a": 42 | File "doc.json", line 6, characters 26-29 43 | Number 2: 44 | File "doc.json", line 6, characters 31-32 45 | 46 | Object: 47 | File "doc.json", line 6, characters 38-47 48 | Member "a": 49 | File "doc.json", line 6, characters 39-42 50 | Number 3: 51 | File "doc.json", line 6, characters 44-45 52 | 53 | Object: 54 | File "doc.json", line 6, characters 49-58 55 | Member "a": 56 | File "doc.json", line 6, characters 50-53 57 | Number 4: 58 | File "doc.json", line 6, characters 55-56 59 | 60 | Object: 61 | File "doc.json", line 6, characters 60-69 62 | Member "a": 63 | File "doc.json", line 6, characters 61-64 64 | Number 5: 65 | File "doc.json", line 6, characters 66-67 66 | 67 | Object: 68 | File "doc.json", line 6, characters 71-80 69 | Member "a": 70 | File "doc.json", line 6, characters 72-75 71 | Number 6: 72 | File "doc.json", line 6, characters 77-78 73 | 74 | Object: 75 | File "doc.json", line 6, characters 82-89 76 | Member "a": 77 | File "doc.json", line 6, characters 83-86 78 | Number 7: 79 | File "doc.json", line 6, characters 87-88 80 | 81 | Object: 82 | File "doc.json", line 6, characters 91-104 83 | Member "hu": 84 | File "doc.json", line 6, characters 92-96 85 | null: 86 | File "doc.json", line 6, characters 97-101 87 | 88 | Member "metameta": 89 | File "doc.json", line 7, characters 2-12 90 | Bool true: 91 | File "doc.json", line 7, characters 14-18 92 | 93 | Member "obj": 94 | File "doc.json", line 8, characters 2-7 95 | Object: 96 | File "doc.json", line 9, characters 2-19 97 | Member "magic": 98 | File "doc.json", line 9, characters 4-11 99 | null: 100 | File "doc.json", line 9, characters 13-17 101 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Jsont {%html: %%VERSION%%%}} 2 | 3 | Jsont is an OCaml library for declarative JSON data manipulation. It 4 | provides: 5 | 6 | - Combinators for describing JSON data using the OCaml values of your 7 | choice. The descriptions can be used by generic functions to 8 | decode, encode, query and update JSON data without having to 9 | construct a generic JSON representation. 10 | - A {{!Jsont_bytesrw}JSON codec} with optional text location tracking and layout 11 | preservation. The codec is compatible with effect-based concurrency. 12 | 13 | The descriptions are independent from the codec and can be used by 14 | third-party processors or codecs. 15 | 16 | {1:manuals Manuals} 17 | 18 | The following manuals are available. 19 | 20 | {ul 21 | {- The {{!quick_start}quick start} should do so.} 22 | {- The {{!cookbook}[Jsont] cookbook} has a few conventions and JSON 23 | data modelling recipes.}} 24 | 25 | The {{:https://erratique.ch/repos/jsont/tree/test}test directory} 26 | in the source repository of Jsont has a few more examples. 27 | 28 | {1:jsont Library [jsont]} 29 | 30 | {!modules:Jsont} 31 | 32 | {1:jsont_bytesrw Library [jsont.bytesrw]} 33 | 34 | This library depends on the {!bytesrw} library and exports the [jsont] library. 35 | 36 | {!modules:Jsont_bytesrw} 37 | 38 | {1:jsont_brr Library [jsont.brr]} 39 | 40 | This library depends on the {!brr} library and exports the [jsont] library. 41 | 42 | {!modules: 43 | Jsont_brr} 44 | 45 | {1:quick_start Quick start} 46 | 47 | Given JSON for task items encoded in JSON as follows: 48 | {[ 49 | let data = 50 | {| 51 | { "task": "Make new release", 52 | "status": "todo", 53 | "tags": ["work", "softwre"] }|} 54 | ]} 55 | 56 | First we can correct that typo in the ["tags"] list with: 57 | 58 | {[ 59 | let () = 60 | let p = Jsont.Path.(root |> mem "tags" |> nth 1) in 61 | let update = Jsont.(set_path string p "software") in 62 | let correct = Jsont_bytesrw.recode_string ~layout:true update data in 63 | print_endline (Result.get_ok correct) 64 | ]} 65 | 66 | Now to work with the data in OCaml without pain we can model it by: 67 | 68 | {[ 69 | module Status = struct 70 | type t = Todo | Done | Cancelled 71 | let assoc = ["todo", Todo; "done", Done; "cancelled", Cancelled ] 72 | let jsont = Jsont.enum ~kind:"Status" assoc 73 | end 74 | 75 | module Item = struct 76 | type t = { task : string; status : Status.t; tags : string list; } 77 | let make task status tags = { task; status; tags } 78 | let task i = i.task 79 | let status i = i.status 80 | let tags i = i.tags 81 | let jsont = 82 | Jsont.Object.map ~kind:"Item" make 83 | |> Jsont.Object.mem "task" Jsont.string ~enc:task 84 | |> Jsont.Object.mem "status" Status.jsont ~enc:status 85 | |> Jsont.Object.mem "tags" Jsont.(list string) ~enc:tags 86 | ~dec_absent:[] ~enc_omit:(( = ) []) 87 | |> Jsont.Object.finish 88 | end 89 | ]} 90 | 91 | Lists of task items can be serialized to strings with, for example, 92 | {!Jsont_bytesrw}: 93 | 94 | {[ 95 | let items = Jsont.list Item.jsont 96 | let items_of_json s = Jsont_bytesrw.decode_string items s 97 | let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is 98 | ]} 99 | 100 | If you are using [js_of_ocaml] the browser's built-in JavaScript 101 | parser can be used with {!Jsont_brr} from the [jsont.brr] library: 102 | 103 | {[ 104 | let items_of_json s = Jsont_brr.decode items s 105 | let items_to_json is = Jsont_brr.encode items is 106 | ]} 107 | 108 | The {{!page-cookbook}cookbook} has more JSON modelling recipes, the 109 | {{:https://erratique.ch/repos/jsont/tree/test/topojson.ml}[topojson.ml]}, 110 | {{:https://erratique.ch/repos/jsont/tree/test/geojson.ml}[geojson.ml]}, 111 | {{:https://erratique.ch/repos/jsont/tree/test/json_rpc.ml}[json_rpc.ml]}, 112 | in the source repository provide full examples of JSON schema modelisations. -------------------------------------------------------------------------------- /test/json_rpc.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** JSON-RPC codec https://www.jsonrpc.org/ *) 7 | 8 | (* JSON-RPC version *) 9 | 10 | type jsonrpc = [`V2] 11 | let jsonrpc_jsont = Jsont.enum ["2.0", `V2] 12 | 13 | (* JSON-RPC identifiers *) 14 | 15 | type id = [ `String of string | `Number of float | `Null ] 16 | let id_jsont : id Jsont.t = 17 | let null = Jsont.null `Null in 18 | let string = 19 | let dec s = `String s in 20 | let enc = function `String s -> s | _ -> assert false in 21 | Jsont.map ~dec ~enc Jsont.string 22 | in 23 | let number = 24 | let dec n = `Number n in 25 | let enc = function `Number n -> n | _ -> assert false in 26 | Jsont.map ~dec ~enc Jsont.number 27 | in 28 | let enc = function 29 | | `Null -> null | `String _ -> string | `Number _ -> number 30 | in 31 | Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc () 32 | 33 | (* JSON-RPC request object *) 34 | 35 | type params = Jsont.json (* An array or object *) 36 | let params_jsont = 37 | let enc = function 38 | | Jsont.Object _ | Jsont.Array _ -> Jsont.json 39 | | j -> 40 | let meta = Jsont.Meta.none in 41 | let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in 42 | Jsont.Error.expected meta "object or array" ~fnd 43 | in 44 | let kind = "JSON-RPC params" in 45 | Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc () 46 | 47 | type request = 48 | { jsonrpc : jsonrpc; 49 | method' : string; 50 | params : params option; 51 | id : id option; } 52 | 53 | let request jsonrpc method' params id = { jsonrpc; method'; params; id } 54 | let request_jsont : request Jsont.t = 55 | Jsont.Object.map request 56 | |> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc) 57 | |> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method') 58 | |> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params) 59 | |> Jsont.Object.opt_mem "id" id_jsont ~enc:(fun r -> r.id) 60 | |> Jsont.Object.finish 61 | 62 | (* JSON-RPC error objects *) 63 | 64 | type error = 65 | { code : int; 66 | message : string; 67 | data : Jsont.json option; } 68 | 69 | let error code message data = { code; message; data } 70 | let error_jsont = 71 | Jsont.Object.map error 72 | |> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code) 73 | |> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message) 74 | |> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data) 75 | |> Jsont.Object.finish 76 | 77 | (* JSON-RPC response object *) 78 | 79 | type response = 80 | { jsonrpc : jsonrpc; 81 | value : (Jsont.json, error) result; 82 | id : id; } 83 | 84 | let response jsonrpc result error id : response = 85 | let err_both () = 86 | Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined" 87 | Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error" 88 | in 89 | let err_none () = 90 | Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" 91 | Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error" 92 | in 93 | match result, error with 94 | | Some result, None -> { jsonrpc; value = Ok result; id } 95 | | None, Some error -> { jsonrpc; value = Error error; id } 96 | | Some _ , Some _ -> err_both () 97 | | None, None -> err_none () 98 | 99 | let response_result r = match r.value with Ok v -> Some v | Error _ -> None 100 | let response_error r = match r.value with Ok _ -> None | Error e -> Some e 101 | 102 | let response_jsont : response Jsont.t = 103 | Jsont.Object.map response 104 | |> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc) 105 | |> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result 106 | |> Jsont.Object.opt_mem "error" error_jsont ~enc:response_error 107 | |> Jsont.Object.mem "id" id_jsont ~enc:(fun r -> r.id) 108 | |> Jsont.Object.finish 109 | -------------------------------------------------------------------------------- /paper/soup_test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 Daniel C. Bünzli. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Tests for soup.ml *) 7 | 8 | open B0_testing 9 | 10 | open Soup 11 | 12 | (* More combinators *) 13 | 14 | let number = Number { dec = Fun.id; enc = Fun.id } 15 | let array elt = 16 | let dec_empty = [] and dec_add a _i v = v :: a in 17 | let dec_finish elts = List.rev elts in 18 | let dec_skip _ _ = false in 19 | let enc f acc vs = List.fold_left f acc vs in 20 | Array { elt; dec_empty; dec_add; dec_skip; dec_finish; enc } 21 | 22 | (* Test data *) 23 | 24 | let content = "J'aime pas la soupe" and public = true 25 | let json_msg0 = Json.(Obj ["public", Bool public; "content", String content]) 26 | let json_msg1 = 27 | Json.(Obj ["content", String "Heyho!"; "public", Bool public; "time", 28 | Number 1.]) 29 | 30 | let json_msg3 = 31 | Json.(Obj ["public", Bool public; "content", String (content ^ "!")]) 32 | 33 | let json_msgs = Json.Array [json_msg0; json_msg1] 34 | 35 | (* Tests *) 36 | 37 | let test_trip () = 38 | Test.test "generic trip test" @@ fun () -> 39 | let dec = decode json json_msgs in 40 | let trip = encode json dec in 41 | if json_msgs <> trip 42 | then (Test.log_fail "json_msgs <> trip"; assert false); 43 | () 44 | 45 | let test_msg () = 46 | Test.test "Message modelling and queries tests" @@ fun () -> 47 | let msg = { Message.content; public } in 48 | let msg' = decode Message.jsont json_msg0 in 49 | if msg <> msg' then (Test.log_fail "msg <> msg'"; assert false); 50 | let q n = get_nth n @@ get_mem "time" number in 51 | assert (query (q 1) json_msgs = 1.); 52 | Test.failure @@ (fun () -> query (q 0) json_msgs); 53 | let json_msgs' = 54 | let q = 55 | update_nth 0 @@ update_mem "content" @@ 56 | map (fun s -> s ^ "!") Fun.id string 57 | in 58 | query (delete_nth 1) (query q json_msgs) 59 | in 60 | if json_msgs' <> Json.Array[json_msg3] 61 | then (Test.log_fail "json_msgs''"; assert false); 62 | let json_msgs' = 63 | let q = 64 | update_nth 0 @@ update_mem "content" (const string (content ^ "!")) 65 | in 66 | (query q json_msgs) 67 | in 68 | if json_msgs' <> Json.Array[json_msg3;json_msg1] 69 | then (Test.log_fail "json_msgs''"; assert false); 70 | () 71 | 72 | module Cases = struct 73 | 74 | type point = { x : float; y : float } 75 | type line = { p0 : point; p1 : point } 76 | type type' = Point of point | Line of line 77 | type geom = { name : string; type' : type' } 78 | 79 | (* more data *) 80 | 81 | let ml_geom = 82 | { name = "Hey"; 83 | type' = Line { p0 = { x = 0.; y = 1.}; p1 = { x = 2.; y = 3.}} } 84 | 85 | let json_geom = (* out of order *) 86 | Json.(Obj ["name", String "Hey"; 87 | "p0", Obj ["x", Number 0.; "y", Number 1.]; 88 | "p1", Obj ["y", Number 3.; "x", Number 2.]; 89 | "type", String "line"; ]) 90 | 91 | (* JSON types *) 92 | 93 | let point_jsont = 94 | obj_map (fun x y -> { x; y }) 95 | |> obj_mem "x" number ~enc:(fun p -> p.x) 96 | |> obj_mem "y" number ~enc:(fun p -> p.y) 97 | 98 | let line_jsont = 99 | let point = obj_finish point_jsont in 100 | obj_map (fun p0 p1 -> { p0; p1 }) 101 | |> obj_mem "p0" point ~enc:(fun p -> p.p0) 102 | |> obj_mem "p1" point ~enc:(fun p -> p.p1) 103 | 104 | let case_point = 105 | { tag = "point"; obj_map = point_jsont; dec = fun p -> Point p } 106 | 107 | let case_line = 108 | { tag = "line"; obj_map = line_jsont; dec = fun l -> Line l } 109 | 110 | let cases = 111 | { tag = { name = "type"; type' = string; id = Type.Id.make (); 112 | dec_absent = None; enc = (fun _ -> assert false); 113 | enc_omit = (fun _ -> assert false); }; 114 | tag_compare = String.compare; 115 | id = Type.Id.make (); 116 | cases = [Case case_point; Case case_line]; 117 | enc = (fun g -> g.type'); 118 | enc_case = (function 119 | | Point p -> Case_value (case_point, p) 120 | | Line l -> Case_value (case_line, l)) } 121 | 122 | let geom_jsont : geom jsont = 123 | let obj = obj_map (fun name type' -> { name; type' }) in 124 | let obj = obj_mem "name" string obj ~enc:(fun g -> g.name) in 125 | obj_finish @@ 126 | { obj with shape = Obj_cases cases; dec = Dec_app (obj.dec, cases.id) } 127 | end 128 | 129 | let test_cases () = 130 | Test.test "cases" @@ fun () -> 131 | let g = decode Cases.geom_jsont Cases.json_geom in 132 | if Cases.ml_geom <> g then (Test.log_fail "Cases.geom.ml <> g"; assert false); 133 | () 134 | 135 | let main () = 136 | Test.main @@ fun () -> 137 | test_trip (); 138 | test_msg (); 139 | test_cases (); 140 | () 141 | 142 | let () = if !Sys.interactive then () else exit (main ()) 143 | -------------------------------------------------------------------------------- /src/bytesrw/jsont_bytesrw.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** JSON codec. 7 | 8 | According to {{:https://www.rfc-editor.org/rfc/rfc8259}RFC 8259}. 9 | 10 | See notes about {{!layout}layout preservation} and behaviour 11 | on {{!duplicate}duplicate members}. 12 | 13 | {b Tip.} For maximal performance decode with [~layout:false] and 14 | [~locs:false], this is the default. Howver using [~locs:true] improves 15 | some error reports. *) 16 | 17 | open Bytesrw 18 | 19 | (** {1:decode Decode} *) 20 | 21 | val decode : 22 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t -> 23 | Bytes.Reader.t -> ('a, string) result 24 | (** [decode t r] decodes a value from [r] according to [t]. 25 | {ul 26 | {- If [layout] is [true] whitespace is preserved in {!Jsont.Meta.t} 27 | values. Defaults to [false].} 28 | {- If [locs] is [true] locations are preserved in {!Jsont.Meta.t} 29 | values and error messages are precisely located. Defaults to [false].} 30 | {- [file] is the file path from which [r] is assumed to read. 31 | Defaults to {!Jsont.Textloc.file_none}}} *) 32 | 33 | val decode' : 34 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t -> 35 | Bytes.Reader.t -> ('a, Jsont.Error.t) result 36 | (** [decode'] is like {!val-decode} but preserves the error structure. *) 37 | 38 | val decode_string : 39 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t -> 40 | string -> ('a, string) result 41 | (** [decode_string] is like {!val-decode} but decodes directly from a string. *) 42 | 43 | val decode_string' : 44 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t -> 45 | string -> ('a, Jsont.Error.t) result 46 | (** [decode_string'] is like {!val-decode'} but decodes directly from a 47 | string. *) 48 | 49 | (** {1:encode Encode} *) 50 | 51 | val encode : 52 | ?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format -> 53 | 'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, string) result 54 | (** [encode t v w] encodes value [v] according to [t] on [w]. 55 | {ul 56 | {- If [buf] is specified it is used as a buffer for the slices written 57 | on [w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w].} 58 | {- [format] specifies how the JSON should be formatted. 59 | Defaults to {!Jsont.Minify}.} 60 | {- [number_format] specifies the format string to format numbers. Defaults 61 | to {!Jsont.default_number_format}.} 62 | {- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should 63 | be written on [w].}} *) 64 | 65 | val encode' : 66 | ?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format -> 67 | 'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, Jsont.Error.t) result 68 | (** [encode'] is like {!val-encode} but preserves the error structure. *) 69 | 70 | val encode_string : 71 | ?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format -> 72 | 'a Jsont.t -> 'a -> (string, string) result 73 | (** [encode_string] is like {!val-encode} but writes to a string. *) 74 | 75 | val encode_string' : 76 | ?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format -> 77 | 'a Jsont.t -> 'a -> (string, Jsont.Error.t) result 78 | (** [encode_string'] is like {!val-encode'} but writes to a string. *) 79 | 80 | (** {1:recode Recode} 81 | 82 | The defaults in these functions are those of {!val-decode} and 83 | {!val-encode}, except if [layout] is [true], [format] defaults to 84 | [Jsont.Layout] and vice-versa. *) 85 | 86 | val recode : 87 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t -> 88 | ?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t -> 89 | Bytes.Reader.t -> Bytes.Writer.t -> eod:bool -> (unit, string) result 90 | (** [recode] is {!val-decode} followed by {!val-recode}. *) 91 | 92 | val recode' : 93 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t -> 94 | ?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t -> 95 | Bytes.Reader.t -> Bytes.Writer.t -> eod:bool -> (unit, Jsont.Error.t) result 96 | (** [recode'] is like {!val-recode} but preserves the error structure. *) 97 | 98 | val recode_string : 99 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t -> 100 | ?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t -> 101 | string -> (string, string) result 102 | (** [recode] is {!decode_string} followed by {!recode_string}. *) 103 | 104 | val recode_string' : 105 | ?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t -> 106 | ?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t -> 107 | string -> (string, Jsont.Error.t) result 108 | (** [recode_string'] is like {!val-recode_string} but preserves the error 109 | structure. *) 110 | 111 | (** {1:layout Layout preservation} 112 | 113 | In order to simplify the implementation not all layout is preserved. 114 | In particular: 115 | {ul 116 | {- White space in empty arrays and objects is dropped.} 117 | {- Unicode escapes are replaced by their UTF-8 encoding.} 118 | {- The format of numbers is not preserved.}} *) 119 | 120 | (** {1:duplicate Duplicate object members} 121 | 122 | Duplicate object members are undefined behaviour in JSON. We 123 | follow the behaviour of 124 | {{:https://262.ecma-international.org/6.0/#sec-internalizejsonproperty} 125 | [JSON.parse]} and the last one takes over, however duplicate 126 | members all have to parse with the specified type as we error as soon 127 | as possible. Also 128 | {{!Jsont.Object.case_mem}case members} are not allowed to duplicate. *) 129 | -------------------------------------------------------------------------------- /attic/caret.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* This syntax/idea does not work well with JSON it worked well with 7 | s-expressions because of their uniform nature e.g. to insert 8 | bindings. 9 | 10 | That would still work on arrays though. Maybe we could add 11 | something at some point. *) 12 | 13 | module Path : sig 14 | 15 | 16 | (** {1:carets Carets} *) 17 | 18 | (** Carets. 19 | 20 | A path and a spatial localisation. *) 21 | module Caret : sig 22 | 23 | (** {1:caret Carets} *) 24 | 25 | type path := t 26 | 27 | type pos = 28 | | Before (** The void before the data indexed by a path. *) 29 | | Over (** The data indexed by a path. *) 30 | | After (** The void after the data indexed by a path. *) 31 | (** The type for caret positions. *) 32 | 33 | type t = pos * path 34 | (** The type for carets. A path and a caret position. *) 35 | 36 | val of_string : string -> (t, string) result 37 | (** [of_string s] parses a caret according to 38 | the {{!path_caret_syntax}caret syntax} .*) 39 | 40 | val pp : t fmt 41 | (** [pp] formats carets. *) 42 | end 43 | 44 | val over : t -> Caret.t 45 | (** [over p] is the data at the path [p]. *) 46 | 47 | val before : t -> Caret.t 48 | (** [before p] is the void before the path [p]. *) 49 | 50 | val after : t -> Caret.t 51 | (** [after p] is the void after the path [p]. *) 52 | 53 | (** {1:path_caret_syntax Path & caret syntax} 54 | 55 | Path and carets provide a way for end users to address JSON and 56 | edit locations. 57 | 58 | A {e path} is a sequence of member and list indexing 59 | operations. Applying the path to a JSON value leads to either a 60 | JSON value or nothing if one of the indices does not exist, or 61 | an error if ones tries to index a non-indexable value. 62 | 63 | A {e caret} is a path and a spatial specification for the JSON 64 | construct found by the path. The caret indicates either the void 65 | {e before} that JSON construct, the JSON value itself ({e over}) or 66 | the void {e after} it. 67 | 68 | Here are a few examples of paths and carets, syntactically the 69 | charater ['v'] is used to denote the caret's insertion point before or 70 | after a path. There's no distinction between a path and an over caret. 71 | 72 | {@json[ 73 | { 74 | "ocaml": { 75 | "libs": ["jsont", "brr", "cmdliner"] 76 | } 77 | } 78 | ]} 79 | 80 | {@shell[ 81 | ocaml.libs # value of member "libs" of member "ocaml" 82 | ocaml.v[libs] # void before the "libs" member 83 | ocaml.[libs]v # void after "libs" member 84 | 85 | ocaml.libs.[0] # first element of member "libs" of member "ocaml" 86 | ocaml.libs.v[0] # void before first element 87 | ocaml.libs.[0]v # void after first element 88 | 89 | ocaml.libs.[-1] # last element of member "libs" of member "ocaml" 90 | ocaml.libs.v[-1] # before last element (if any) 91 | ocaml.libs.[-1]v # after last element (if any) 92 | ]} 93 | 94 | More formally a {e path} is a [.] seperated list of indices. 95 | 96 | An {e index} is written [[i]]. [i] can a zero-based list index 97 | with negative indices counting from the end of the list ([-1] is 98 | the last element). Or [i] can be an object member name [n]. If 99 | there is no ambiguity, the surrounding brackets can be dropped. 100 | 101 | A {e caret} is a path whose last index brackets can be prefixed or 102 | suffixed by an insertion point, represented by the character 103 | ['v']. This respectively denote the void before or after the 104 | JSON construct found by the path. 105 | 106 | {b Notes.} 107 | {ul 108 | {- The syntax has no form of quoting at the moment this 109 | means key names can't contain, [\[], [\]], or start with a number.} 110 | {- It would be nice to be able to drop the dots in order 111 | to be compatible with {{:https://www.rfc-editor.org/rfc/rfc9535} 112 | JSONPath} syntax.}} *) 113 | end = struct 114 | 115 | 116 | (* Carets *) 117 | 118 | module Caret = struct 119 | type path = t 120 | type pos = Before | Over | After 121 | type t = pos * path 122 | let pp ppf = function 123 | | Over, p -> pp ppf p 124 | | Before, (c :: p)-> 125 | pp ppf p; 126 | (if p <> [] then Fmt.char ppf '.'); 127 | Fmt.char ppf 'v'; pp_bracketed_index ppf c 128 | | After, (c :: p) -> 129 | pp ppf p; 130 | (if p <> [] then Fmt.char ppf '.'); 131 | pp_bracketed_index ppf c; Fmt.char ppf 'v' 132 | | _ -> () 133 | 134 | (* Parsing *) 135 | 136 | let of_string s = 137 | let rec loop p s i max = 138 | if i > max then Over, p else 139 | let next = i + 1 in 140 | match s.[i] with 141 | | 'v' when next <= max && s.[next] = '[' -> 142 | let next, p = parse_index p s next max in 143 | parse_eoi s next max; Before, p 144 | | c -> 145 | let next, p = parse_index p s i max in 146 | if next > max then Over, p else 147 | if s.[next] = 'v' 148 | then (parse_eoi s (next + 1) max; After, p) else 149 | if s.[next] <> '.' then err_unexp_char next s else 150 | if next + 1 <= max then loop p s (next + 1) max else 151 | err_unexp_eoi next 152 | in 153 | try 154 | if s = "" then Ok (Over, []) else 155 | let start = if s.[0] = '.' then 1 else 0 in 156 | Ok (loop [] s start (String.length s - 1)) 157 | with Failure e -> Error e 158 | end 159 | 160 | let over p = Caret.Over, p 161 | let after p = Caret.After, p 162 | let before p = Caret.Before, p 163 | end 164 | -------------------------------------------------------------------------------- /src/jsont_base.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Low-level internal tools for {!Jsont}. *) 7 | 8 | val string_subrange : ?first:int -> ?last:int -> string -> string 9 | val binary_string_of_hex : string -> (string, string) result 10 | val binary_string_to_hex : string -> string 11 | 12 | (** Type identifiers. Can be removed once we require OCaml 5.1 *) 13 | module Type : sig 14 | type (_, _) eq = Equal : ('a, 'a) eq 15 | module Id : sig 16 | type 'a t 17 | val make : unit -> 'a t 18 | val uid : 'a t -> int 19 | val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option 20 | end 21 | end 22 | 23 | (** Resizable arrays. *) 24 | module Rarray : sig 25 | type 'a t 26 | val get : 'a t -> int -> 'a 27 | val empty : unit -> 'a t 28 | val grow : 'a t -> 'a -> unit 29 | val length : 'a t -> int 30 | val add_last : 'a -> 'a t -> 'a t 31 | val to_array : 'a t -> 'a array 32 | end 33 | 34 | (** Resizable bigarrays. *) 35 | module Rbigarray1 : sig 36 | type ('a, 'b, 'c) t 37 | val get : ('a, 'b, 'c) t -> int -> 'a 38 | val empty : ('a, 'b) Bigarray.kind -> 'c Bigarray.layout -> ('a, 'b, 'c) t 39 | val grow : ('a, 'b, 'c) t -> 'a -> unit 40 | val length : ('a, 'b, 'c) t -> int 41 | val add_last : 'a -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t 42 | val to_bigarray : ('a, 'b, 'c) t -> ('a, 'b, 'c) Bigarray.Array1.t 43 | end 44 | 45 | (** Mini fmt *) 46 | module Fmt : sig 47 | type 'a t = Format.formatter -> 'a -> unit 48 | val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a 49 | val str : ('a, Format.formatter, unit, string) format4 -> 'a 50 | val disable_ansi_styler : unit -> unit 51 | 52 | val nop : unit t 53 | val sp : unit t 54 | val list : ?pp_sep:unit t -> 'a t -> 'a list t 55 | val char : char t 56 | val string : string t 57 | val substring : int -> int -> string t 58 | val lines : string t 59 | val bold : string t 60 | val bold_red : string t 61 | val code : string t 62 | val puterr : unit t 63 | val out_of_dom : ?pp_kind:unit t -> unit -> (string * string list) t 64 | val should_it_be_mem : (string * string list) t 65 | val similar_mems : (string * string list) t 66 | 67 | 68 | type json_number_format = (float -> unit, Format.formatter, unit) format 69 | val json_null : unit t 70 | val json_bool : bool t 71 | val json_default_number_format : json_number_format 72 | val json_number' : json_number_format-> float t 73 | val json_number : float t 74 | val json_string : string t 75 | end 76 | 77 | (** See {!Jsont.Textloc} *) 78 | module Textloc : sig 79 | type fpath = string 80 | val file_none : fpath 81 | 82 | type byte_pos = int 83 | val byte_pos_none : byte_pos 84 | 85 | type line_num = int 86 | val line_num_none : line_num 87 | 88 | type line_pos = line_num * byte_pos 89 | val line_pos_first : line_pos 90 | val line_pos_none : line_pos 91 | 92 | type t 93 | val none : t 94 | val make : 95 | file:fpath -> first_byte:byte_pos -> last_byte:byte_pos -> 96 | first_line:line_pos -> last_line:line_pos -> t 97 | 98 | val file : t -> fpath 99 | val set_file : t -> fpath -> t 100 | val first_byte : t -> byte_pos 101 | val last_byte : t -> byte_pos 102 | val first_line : t -> line_pos 103 | val last_line : t -> line_pos 104 | val is_none : t -> bool 105 | val is_empty : t -> bool 106 | val equal : t -> t -> bool 107 | val compare : t -> t -> int 108 | val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t 109 | val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t 110 | val to_first : t -> t 111 | val to_last : t -> t 112 | val before : t -> t 113 | val after : t -> t 114 | val span : t -> t -> t 115 | val reloc : first:t -> last:t -> t 116 | val pp_ocaml : Format.formatter -> t -> unit 117 | val pp_gnu : Format.formatter -> t -> unit 118 | val pp : Format.formatter -> t -> unit 119 | val pp_dump : Format.formatter -> t -> unit 120 | end 121 | 122 | type 'a fmt = Stdlib.Format.formatter -> 'a -> unit 123 | 124 | (** See {!Jsont.Meta} *) 125 | module Meta : sig 126 | type t 127 | val make : ?ws_before:string -> ?ws_after:string -> Textloc.t -> t 128 | val none : t 129 | val is_none : t -> bool 130 | val textloc : t -> Textloc.t 131 | val ws_before : t -> string 132 | val ws_after : t -> string 133 | val with_textloc : t -> Textloc.t -> t 134 | val clear_ws : t -> t 135 | val clear_textloc : t -> t 136 | val copy_ws : t -> dst:t -> t 137 | end 138 | 139 | type 'a node = 'a * Meta.t 140 | 141 | (** JSON number tools. *) 142 | module Number : sig 143 | val number_contains_int : bool 144 | val int_is_uint8 : int -> bool 145 | val int_is_uint16 : int -> bool 146 | val int_is_int8 : int -> bool 147 | val int_is_int16 : int -> bool 148 | val can_store_exact_int : int -> bool 149 | val can_store_exact_int64 : Int64.t -> bool 150 | val in_exact_int_range : float -> bool 151 | val in_exact_uint8_range : float -> bool 152 | val in_exact_uint16_range : float -> bool 153 | val in_exact_int8_range : float -> bool 154 | val in_exact_int16_range : float -> bool 155 | val in_exact_int32_range : float -> bool 156 | val in_exact_int64_range : float -> bool 157 | end 158 | 159 | (** See {!Jsont.Path} *) 160 | module Path : sig 161 | type index = 162 | | Mem of string node 163 | | Nth of int node 164 | 165 | val pp_index : index fmt 166 | val pp_index_trace : index fmt 167 | 168 | type t 169 | val root : t 170 | val is_root : t -> bool 171 | val nth : ?meta:Meta.t -> int -> t -> t 172 | val mem : ?meta:Meta.t -> string -> t -> t 173 | val rev_indices : t -> index list 174 | val of_string : string -> (t, string) result 175 | val pp : t fmt 176 | val pp_trace : t fmt 177 | end 178 | 179 | (** See {!Jsont.Sort} *) 180 | module Sort : sig 181 | type t = Null | Bool | Number | String | Array | Object 182 | val to_string : t -> string 183 | 184 | val kinded' : kind:string -> string -> string 185 | val kinded : kind:string -> t -> string 186 | val or_kind : kind:string -> t -> string 187 | val pp : Format.formatter -> t -> unit 188 | end 189 | -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | open Result.Syntax 3 | 4 | (* Library names *) 5 | 6 | let b0_std = B0_ocaml.libname "b0.std" 7 | let bytesrw = B0_ocaml.libname "bytesrw" 8 | let cmdliner = B0_ocaml.libname "cmdliner" 9 | let brr = B0_ocaml.libname "brr" 10 | 11 | let jsont = B0_ocaml.libname "jsont" 12 | let jsont_bytesrw = B0_ocaml.libname "jsont.bytesrw" 13 | let jsont_brr = B0_ocaml.libname "jsont.brr" 14 | 15 | (* Libraries *) 16 | 17 | let jsont_lib = 18 | let srcs = [ `Dir ~/"src" ] in 19 | B0_ocaml.lib jsont ~name:"jsont-lib" ~srcs 20 | 21 | let jsont_bytesrw_lib = 22 | let srcs = [ `Dir ~/"src/bytesrw" ] in 23 | let requires = [bytesrw; jsont] in 24 | B0_ocaml.lib jsont_bytesrw ~srcs ~requires ~exports:requires 25 | 26 | let jsont_brr_lib = 27 | let srcs = [ `Dir ~/"src/brr" ] in 28 | let requires = [brr; jsont] in 29 | B0_ocaml.lib jsont_brr ~srcs ~requires ~exports:requires 30 | 31 | (* Tools *) 32 | 33 | let jsont_tool = 34 | let srcs = [ `File ~/"test/jsont_tool.ml" ] in 35 | let requires = [cmdliner; bytesrw; jsont_bytesrw; jsont] in 36 | B0_ocaml.exe "jsont" ~public:true ~doc:"The jsont tool" ~srcs ~requires 37 | 38 | (* Tests *) 39 | 40 | let test ?(requires = []) = B0_ocaml.test ~requires:(jsont :: requires) 41 | 42 | let quickstart = 43 | let doc = "Quick start examples" in 44 | test ~/"test/quickstart.ml" ~run:false ~requires:[jsont_bytesrw] ~doc 45 | 46 | let cookbook = 47 | test ~/"test/cookbook.ml" ~run:false ~doc:"Cookbook examples" 48 | 49 | let trials = 50 | test ~/"test/trials.ml" ~run:false ~doc:"Experiments" 51 | 52 | let topojson = 53 | let doc = "Jsont modelling of TopoJSON" in 54 | let requires = [cmdliner; bytesrw; jsont_bytesrw] in 55 | test ~/"test/topojson.ml" ~run:false ~doc ~requires 56 | 57 | let geojson = 58 | let doc = "Jsont modelling of GeoJSON" in 59 | let requires = [cmdliner; bytesrw; jsont_bytesrw] in 60 | test ~/"test/geojson.ml" ~run:false ~doc ~requires 61 | 62 | let jsonrpc = 63 | let doc = "Jsont modelling of JSON-RPC" in 64 | test ~/"test/json_rpc.ml" ~run:false ~doc 65 | 66 | let test_common = 67 | [ `File ~/"test/test_common.ml"; `File ~/"test/test_common_samples.ml" ] 68 | 69 | let test_bytesrw = 70 | let doc = "Test Jsont_bytesrw codec" in 71 | let srcs = test_common in 72 | let requires = [b0_std; jsont_bytesrw] in 73 | test ~/"test/test_bytesrw.ml" ~run:true ~srcs ~requires ~doc 74 | 75 | let test_jsont = 76 | let doc = "Test Jsont.Json codec" in 77 | let srcs = test_common in 78 | let requires = [b0_std; jsont_bytesrw] in 79 | test ~/"test/test_json.ml" ~run:true ~srcs ~requires ~doc 80 | 81 | let test_brr = 82 | let doc = "Test Jsont_brr codec in the browser" in 83 | let srcs = `File ~/"test/test_brr.ml" :: test_common in 84 | let requires = [b0_std; brr; jsont; jsont_brr] in 85 | let meta = B0_meta.(empty |> tag test) in 86 | B0_jsoo.html_page "test_brr" ~doc ~meta ~srcs ~requires 87 | 88 | (* Seriot JSON test suite *) 89 | 90 | let seriot_suite_repo = "https://github.com/nst/JSONTestSuite.git" 91 | let seriot_suite = ~/"tmp/JSONTestSuite" 92 | let download_seriot_suite = 93 | let doc = "Download the Seriot test suite to tmp/" in 94 | B0_unit.of_action "download-seriot-suite" ~doc @@ fun env _ ~args:_ -> 95 | let* git = B0_env.get_cmd env (Cmd.tool "git") in 96 | let suite = B0_env.in_scope_dir env seriot_suite in 97 | let* created = Os.Dir.create ~make_path:true suite in 98 | if created 99 | then Os.Cmd.run Cmd.(git % "clone" % seriot_suite_repo %% path suite) 100 | else Os.Cmd.run Cmd.(git % "-C" %% path suite % "pull") 101 | 102 | let test_seriot_suite = 103 | let doc = "Run the Seriot test suite" in 104 | let requires = [b0_std; cmdliner; jsont_bytesrw] in 105 | test ~/"test/test_seriot_suite.ml" ~doc ~requires 106 | 107 | (* Expectation tests *) 108 | 109 | let expect = 110 | let doc = "Test jsont expectations" in 111 | let meta = B0_meta.(empty |> tag test |> tag run) in 112 | B0_unit.of_action' "expect" ~meta ~units:[jsont_tool] ~doc @@ 113 | B0_expect.action_func ~base:(Fpath.v "test/expect") @@ fun ctx -> 114 | let jsont = B0_expect.get_unit_exe_file_cmd ctx jsont_tool in 115 | let expect_valid_file ctx json file = 116 | let runs = (* command, output suffix *) 117 | [ Cmd.(arg "fmt" % "-fpretty"), ".pretty.json"; 118 | Cmd.(arg "fmt" % "-findent"), ".indent.json"; 119 | Cmd.(arg "fmt" % "-fminify"), ".minify.json"; 120 | Cmd.(arg "fmt" % "-fpreserve"), ".layout.json"; 121 | Cmd.(arg "locs"), ".locs" ] 122 | in 123 | let test_run ctx jsont file (cmd, ext) = 124 | let cmd = Cmd.(cmd %% path file) in 125 | let cwd = B0_expect.base ctx and stdout = Fpath.(file -+ ext) in 126 | B0_expect.stdout ctx ~cwd ~stdout Cmd.(jsont %% cmd) 127 | in 128 | List.iter (test_run ctx json file) runs 129 | in 130 | let expect_invalid_file ctx jsont file = 131 | let cwd = B0_expect.base ctx and stderr = Fpath.(file -+ ".stderr") in 132 | B0_expect.stderr ctx ~cwd ~stderr Cmd.(jsont % "fmt" %% path file) 133 | in 134 | let valid_files, invalid_files = 135 | let base_files = B0_expect.base_files ctx ~rel:true ~recurse:false in 136 | let input f = Fpath.get_ext ~multi:true f = ".json" in 137 | let files = List.filter input base_files in 138 | let is_valid f = 139 | not (String.starts_with ~prefix:"invalid" (Fpath.basename f)) 140 | in 141 | List.partition is_valid files 142 | in 143 | List.iter (expect_valid_file ctx jsont) valid_files; 144 | List.iter (expect_invalid_file ctx jsont) invalid_files; 145 | () 146 | 147 | (* Paper *) 148 | 149 | let paper = B0_meta.Key.make_tag "paper" 150 | 151 | let soup_code = 152 | let doc = "Soup paper code and tests" in 153 | let srcs = [ `File ~/"paper/soup.ml"; `File ~/"paper/soup_test.ml" ] in 154 | let meta = B0_meta.(empty |> tag test |> tag paper) in 155 | B0_ocaml.exe "soup-code" ~srcs ~requires:[b0_std] ~meta ~doc 156 | 157 | let soup = 158 | let doc = "Soup paper" in 159 | let base = Fpath.v "soup.tex" in 160 | let build b = 161 | let m = B0_build.memo b in 162 | let pdflatex = 163 | let vars = ["TEXINPUTS"] in 164 | B0_memo.tool m (B0_memo.Tool.make ~vars (Fpath.v "pdflatex")) 165 | in 166 | let docdir = B0_build.in_scope_dir b ~/"paper" in 167 | let pdf = B0_build.in_current_dir b (Fpath.(base -+ ".pdf")) in 168 | let reads = [Fpath.(docdir / "jfp.cls"); Fpath.(docdir // base) ] in 169 | let writes = [pdf; Fpath.(pdf -+ ".aux"); Fpath.(pdf -+ ".log")] in 170 | let cwd = B0_build.current_dir b in 171 | let env = 172 | Os.Env.(empty |> add "TEXINPUTS" (Fpath.to_string docdir ^ "//:")) 173 | in 174 | let run_tex = 175 | pdflatex Cmd.(arg "-file-line-error" % "-halt-on-error" % 176 | "-interaction=errorstopmode" %% path base) 177 | in 178 | B0_memo.ready_files m reads; 179 | B0_memo.spawn m ~cwd ~env ~reads ~writes:[] run_tex ~k:(fun _ _ -> 180 | (* Let's hope it reaches the fix point :-) *) 181 | B0_memo.spawn m ~cwd ~env ~reads ~writes run_tex); 182 | Fut.return () 183 | in 184 | let show_pdf e u ~args:_ = (* TODO b0: B0_show_pdf action ? *) 185 | let pdf = Fpath.(B0_env.unit_dir e u // base -+ ".pdf") in 186 | let* view = B0_pdf_viewer.find ~search:(B0_env.get_cmd e) () in 187 | let* () = B0_pdf_viewer.show view pdf in 188 | Ok Os.Exit.ok 189 | in 190 | let meta = 191 | B0_meta.empty 192 | |> ~~ B0_unit.Action.key (`Fun ("show-pdf", show_pdf)) 193 | |> B0_meta.tag paper 194 | in 195 | B0_unit.make ~meta ~doc "soup" build 196 | 197 | (* Packs *) 198 | 199 | let soup_pack = 200 | B0_pack.make "soup" ~doc:"Soup paper and code" ~locked:true @@ 201 | [ soup; soup_code ] 202 | 203 | let default = 204 | let meta = 205 | B0_meta.empty 206 | |> ~~ B0_meta.authors ["The jsont programmers"] 207 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 208 | |> ~~ B0_meta.homepage "https://erratique.ch/software/jsont" 209 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/jsont/doc" 210 | |> ~~ B0_meta.licenses ["ISC"] 211 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/jsont.git" 212 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/jsont/issues" 213 | |> ~~ B0_meta.description_tags ["json"; "codec"; "org:erratique"; ] 214 | |> ~~ B0_opam.build 215 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%" 216 | "--with-cmdliner" "%{cmdliner:installed}%" 217 | "--with-bytesrw" "%{bytesrw:installed}%" 218 | "--with-brr" "%{brr:installed}%"]]|} 219 | |> ~~ B0_opam.depopts 220 | ["cmdliner", ""; 221 | "brr", ""; 222 | "bytesrw", ""] 223 | |> ~~ B0_opam.conflicts [ "cmdliner", {|< "1.3.0"|}; 224 | "brr", {|< "0.0.6"|}; ] 225 | |> ~~ B0_opam.depends 226 | [ "ocaml", {|>= "4.14.0"|}; 227 | "ocamlfind", {|build|}; 228 | "ocamlbuild", {|build|}; 229 | "topkg", {|build & >= "1.1.0"|}; 230 | "b0", {|dev & with-test|}; 231 | ] 232 | |> B0_meta.tag B0_opam.tag 233 | in 234 | B0_pack.make "default" ~doc:"The jsont package" ~meta ~locked:true @@ 235 | (* TODO b0: we should have something more convenient *) 236 | List.filter (Fun.negate (B0_unit.has_tag paper)) (B0_unit.list ()) 237 | -------------------------------------------------------------------------------- /test/cookbook.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Dealing with null values. *) 7 | 8 | let string_null_is_empty = 9 | let null = Jsont.null "" in 10 | let enc = function "" -> null | _ -> Jsont.string in 11 | Jsont.any ~dec_null:null ~dec_string:Jsont.string ~enc () 12 | 13 | 14 | (* Base maps *) 15 | 16 | module M = struct 17 | type t = unit 18 | let result_of_string s : (t, string) result = invalid_arg "unimplemented" 19 | let of_string_or_failure s : t = invalid_arg "unimplemented" 20 | let to_string v : string = invalid_arg "unimplemented" 21 | end 22 | 23 | let m_jsont = 24 | let dec = Jsont.Base.dec_result M.result_of_string in 25 | let enc = Jsont.Base.enc M.to_string in 26 | Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ()) 27 | 28 | let m_jsont' = 29 | let dec = Jsont.Base.dec_failure M.of_string_or_failure in 30 | let enc = Jsont.Base.enc M.to_string in 31 | Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ()) 32 | 33 | let m_jsont'' = 34 | Jsont.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string 35 | 36 | (* Objects as records *) 37 | 38 | module Person = struct 39 | type t = { name : string; age : int } 40 | let make name age = { name; age } 41 | let name p = p.name 42 | let age p = p.age 43 | let jsont = 44 | Jsont.Object.map ~kind:"Person" make 45 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 46 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 47 | |> Jsont.Object.finish 48 | end 49 | 50 | (* Objects as key-value maps *) 51 | 52 | module String_map = Map.Make (String) 53 | 54 | let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t = 55 | fun ?kind t -> 56 | Jsont.Object.map ?kind Fun.id 57 | |> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id 58 | |> Jsont.Object.finish 59 | 60 | (* Optional members *) 61 | 62 | module Person_opt_age = struct 63 | type t = { name : string; age : int option } 64 | let make name age = { name; age } 65 | let name p = p.name 66 | let age p = p.age 67 | let jsont = 68 | Jsont.Object.map ~kind:"Person" make 69 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 70 | |> Jsont.Object.mem "age" Jsont.(some int) 71 | ~dec_absent:None ~enc_omit:Option.is_none ~enc:age 72 | |> Jsont.Object.finish 73 | end 74 | 75 | (* Unknown object members *) 76 | 77 | module Person_strict = struct 78 | type t = { name : string; age : int; } 79 | let make name age = { name; age } 80 | let name p = p.name 81 | let age p = p.age 82 | let jsont = 83 | Jsont.Object.map ~kind:"Person" make 84 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 85 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 86 | |> Jsont.Object.error_unknown 87 | |> Jsont.Object.finish 88 | end 89 | 90 | module Person_keep = struct 91 | type t = { name : string; age : int; unknown : Jsont.json ; } 92 | let make name age unknown = { name; age; unknown } 93 | let name p = p.name 94 | let age p = p.age 95 | let unknown v = v.unknown 96 | let jsont = 97 | Jsont.Object.map ~kind:"Person" make 98 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 99 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 100 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 101 | |> Jsont.Object.finish 102 | end 103 | 104 | (* Dealing with recursive JSON *) 105 | 106 | module Tree = struct 107 | type 'a t = Node of 'a * 'a t list 108 | let make v children = Node (v, children) 109 | let value (Node (v, _)) = v 110 | let children (Node (_, children)) = children 111 | let jsont value_type = 112 | let rec t = lazy 113 | (Jsont.Object.map ~kind:"Tree" make 114 | |> Jsont.Object.mem "value" value_type ~enc:value 115 | |> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children 116 | |> Jsont.Object.finish) 117 | in 118 | Lazy.force t 119 | end 120 | 121 | (* Dealing with object types or classes *) 122 | 123 | module Geometry_variant = struct 124 | module Circle = struct 125 | type t = { name : string; radius : float; } 126 | let make name radius = { name; radius } 127 | let name c = c.name 128 | let radius c = c.radius 129 | let jsont = 130 | Jsont.Object.map ~kind:"Circle" make 131 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 132 | |> Jsont.Object.mem "radius" Jsont.number ~enc:radius 133 | |> Jsont.Object.finish 134 | end 135 | 136 | module Rect = struct 137 | type t = { name : string; width : float; height : float } 138 | let make name width height = { name; width; height } 139 | let name r = r.name 140 | let width r = r.width 141 | let height r = r.height 142 | let jsont = 143 | Jsont.Object.map ~kind:"Rect" make 144 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 145 | |> Jsont.Object.mem "width" Jsont.number ~enc:width 146 | |> Jsont.Object.mem "height" Jsont.number ~enc:height 147 | |> Jsont.Object.finish 148 | end 149 | 150 | type t = Circle of Circle.t | Rect of Rect.t 151 | let circle c = Circle c 152 | let rect r = Rect r 153 | let jsont = 154 | let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in 155 | let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in 156 | let enc_case = function 157 | | Circle c -> Jsont.Object.Case.value circle c 158 | | Rect r -> Jsont.Object.Case.value rect r 159 | in 160 | let cases = Jsont.Object.Case.[make circle; make rect] in 161 | Jsont.Object.map ~kind:"Geometry" Fun.id 162 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 163 | |> Jsont.Object.finish 164 | end 165 | 166 | module Geometry_record = struct 167 | module Circle = struct 168 | type t = { radius : float; } 169 | let make radius = { radius } 170 | let radius c = c.radius 171 | let jsont = 172 | Jsont.Object.map ~kind:"Circle" make 173 | |> Jsont.Object.mem "radius" Jsont.number ~enc:radius 174 | |> Jsont.Object.finish 175 | end 176 | 177 | module Rect = struct 178 | type t = { width : float; height : float } 179 | let make width height = { width; height } 180 | let width r = r.width 181 | let height r = r.height 182 | let jsont = 183 | Jsont.Object.map ~kind:"Rect" make 184 | |> Jsont.Object.mem "width" Jsont.number ~enc:width 185 | |> Jsont.Object.mem "height" Jsont.number ~enc:height 186 | |> Jsont.Object.finish 187 | end 188 | 189 | type type' = Circle of Circle.t | Rect of Rect.t 190 | let circle c = Circle c 191 | let rect r = Rect r 192 | 193 | type t = { name : string; type' : type' } 194 | let make name type' = { name; type' } 195 | let name g = g.name 196 | let type' g = g.type' 197 | 198 | let jsont = 199 | let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in 200 | let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in 201 | let enc_case = function 202 | | Circle c -> Jsont.Object.Case.value circle c 203 | | Rect r -> Jsont.Object.Case.value rect r 204 | in 205 | let cases = Jsont.Object.Case.[make circle; make rect] in 206 | Jsont.Object.map ~kind:"Geometry" make 207 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 208 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases 209 | |> Jsont.Object.finish 210 | end 211 | 212 | 213 | (* Untagged object types *) 214 | 215 | module Response = struct 216 | type t = 217 | { id : int; 218 | value : (Jsont.json, string) result } 219 | 220 | let make id result error = 221 | let pp_mem = Jsont.Repr.pp_code in 222 | match result, error with 223 | | Some result, None -> { id; value = Ok result } 224 | | None, Some error -> { id; value = Error error } 225 | | Some _ , Some _ -> 226 | Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined" 227 | pp_mem "result" pp_mem "error" 228 | | None, None -> 229 | Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" 230 | pp_mem "result" pp_mem "error" 231 | 232 | let result r = match r.value with Ok v -> Some v | Error _ -> None 233 | let error r = match r.value with Ok _ -> None | Error e -> Some e 234 | 235 | let jsont = 236 | Jsont.Object.map make 237 | |> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id) 238 | |> Jsont.Object.opt_mem "result" Jsont.json ~enc:result 239 | |> Jsont.Object.opt_mem "error" Jsont.string ~enc:error 240 | |> Jsont.Object.finish 241 | end 242 | 243 | (* Flattening objects on queries *) 244 | 245 | module Group = struct 246 | type t = { id : int; name : string; persons : Person.t list } 247 | let make id name persons = { id; name; persons } 248 | 249 | let info_jsont = 250 | Jsont.Object.map make 251 | |> Jsont.Object.mem "id" Jsont.int 252 | |> Jsont.Object.mem "name" Jsont.string 253 | |> Jsont.Object.finish 254 | 255 | let jsont = 256 | Jsont.Object.map (fun k persons -> k persons) 257 | |> Jsont.Object.mem "info" info_jsont 258 | |> Jsont.Object.mem "persons" (Jsont.list Person.jsont) 259 | |> Jsont.Object.finish 260 | end 261 | -------------------------------------------------------------------------------- /test/topojson.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Topojson codec https://github.com/topojson/topojson-specification *) 7 | 8 | module String_map = Map.Make (String) 9 | 10 | module Position = struct 11 | type t = float array 12 | let jsont = Jsont.(array ~kind:"Position" number) 13 | end 14 | 15 | module Bbox = struct 16 | type t = float array 17 | let jsont = Jsont.(array ~kind:"Bbox" number) 18 | end 19 | 20 | module Arcs = struct 21 | type t = Position.t array array 22 | let jsont = Jsont.(array ~kind:"Arcs" (array Position.jsont)) 23 | end 24 | 25 | module Transform = struct 26 | type v2 = float * float 27 | type t = { scale : v2; translate : v2 } 28 | 29 | let make scale translate = { scale; translate } 30 | let scale t = t.scale 31 | let translate t = t.translate 32 | 33 | let v2_jsont = 34 | let dec x y = x, y in 35 | let enc (x, y) i = if i = 0 then x else y in 36 | Jsont.t2 ~dec ~enc Jsont.number 37 | 38 | let jsont = 39 | Jsont.Object.map ~kind:"Transform" make 40 | |> Jsont.Object.mem "scale" v2_jsont ~enc:scale 41 | |> Jsont.Object.mem "translate" v2_jsont ~enc:translate 42 | |> Jsont.Object.finish 43 | end 44 | 45 | module Point = struct 46 | type t = { coordinates : Position.t } 47 | let make coordinates = { coordinates } 48 | let coordinates v = v.coordinates 49 | let jsont = 50 | Jsont.Object.map ~kind:"Point" make 51 | |> Jsont.Object.mem "coordinates" Position.jsont ~enc:coordinates 52 | |> Jsont.Object.finish 53 | end 54 | 55 | module Multi_point = struct 56 | type t = { coordinates : Position.t list } 57 | let make coordinates = { coordinates } 58 | let coordinates v = v.coordinates 59 | let jsont = 60 | Jsont.Object.map ~kind:"MultiPoint" make 61 | |> Jsont.Object.mem "coordinates" (Jsont.list Position.jsont) 62 | ~enc:coordinates 63 | |> Jsont.Object.finish 64 | end 65 | 66 | module Line_string = struct 67 | type t = { arcs : int32 list } 68 | let make arcs = { arcs } 69 | let arcs v = v.arcs 70 | let jsont = 71 | Jsont.Object.map ~kind:"LineString" make 72 | |> Jsont.Object.mem "arcs" Jsont.(list int32) ~enc:arcs 73 | |> Jsont.Object.finish 74 | end 75 | 76 | module Multi_line_string = struct 77 | type t = { arcs : int32 list list } 78 | let make arcs = { arcs } 79 | let arcs v = v.arcs 80 | let jsont = 81 | Jsont.Object.map ~kind:"MultiLineString" make 82 | |> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs 83 | |> Jsont.Object.finish 84 | end 85 | 86 | module Polygon = struct 87 | type t = { arcs : int32 list list } 88 | let make arcs = { arcs } 89 | let arcs v = v.arcs 90 | let jsont = 91 | Jsont.Object.map ~kind:"Polygon" make 92 | |> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs 93 | |> Jsont.Object.finish 94 | end 95 | 96 | module Multi_polygon = struct 97 | type t = { arcs : int32 list list list } 98 | let make arcs = { arcs } 99 | let arcs v = v.arcs 100 | let jsont = 101 | Jsont.Object.map ~kind:"MultiPolygon" make 102 | |> Jsont.Object.mem "arcs" Jsont.(list (list (list int32))) ~enc:arcs 103 | |> Jsont.Object.finish 104 | end 105 | 106 | module Geometry = struct 107 | type id = [ `Number of float | `String of string ] 108 | let id_jsont = 109 | let number = 110 | let dec = Jsont.Base.dec (fun n -> `Number n) in 111 | let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) in 112 | Jsont.Base.number (Jsont.Base.map ~enc ~dec ()) 113 | in 114 | let string = 115 | let dec = Jsont.Base.dec (fun n -> `String n) in 116 | let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in 117 | Jsont.Base.string (Jsont.Base.map ~enc ~dec ()) 118 | in 119 | let enc = function `Number _ -> number | `String _ -> string in 120 | Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc () 121 | 122 | type t = 123 | { type' : type'; 124 | id : id option; 125 | properties : Jsont.json String_map.t option; 126 | bbox : Bbox.t option; 127 | unknown : Jsont.json } 128 | 129 | and type' = 130 | | Point of Point.t 131 | | Multi_point of Multi_point.t 132 | | Line_string of Line_string.t 133 | | Multi_line_string of Multi_line_string.t 134 | | Polygon of Polygon.t 135 | | Multi_polygon of Multi_polygon.t 136 | | Geometry_collection of t list 137 | 138 | let make type' id properties bbox unknown = 139 | { type'; id; properties; bbox; unknown } 140 | 141 | let type' g = g.type' 142 | let id g = g.id 143 | let properties g = g.properties 144 | let bbox g = g.bbox 145 | let unknown g = g.unknown 146 | 147 | let point v = Point v 148 | let multi_point v = Multi_point v 149 | let line_string v = Line_string v 150 | let multi_linestr v = Multi_line_string v 151 | let polygon v = Polygon v 152 | let multi_polygon v = Multi_polygon v 153 | let collection vs = Geometry_collection vs 154 | 155 | let properties_type = Jsont.Object.as_string_map ~kind:"properties" Jsont.json 156 | 157 | let rec collection_jsont = lazy begin 158 | Jsont.Object.map ~kind:"GeometryCollection" Fun.id 159 | |> Jsont.Object.mem "geometries" (Jsont.list (Jsont.rec' jsont)) ~enc:Fun.id 160 | |> Jsont.Object.finish 161 | end 162 | 163 | and jsont = lazy begin 164 | let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec in 165 | let case_point = case_map Point.jsont point in 166 | let case_multi_point = case_map Multi_point.jsont multi_point in 167 | let case_line_string = case_map Line_string.jsont line_string in 168 | let case_multi_linestr = case_map Multi_line_string.jsont multi_linestr in 169 | let case_polygon = case_map Polygon.jsont polygon in 170 | let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in 171 | let case_coll = case_map (Lazy.force collection_jsont) collection in 172 | let enc_case = function 173 | | Point p -> Jsont.Object.Case.value case_point p 174 | | Multi_point m -> Jsont.Object.Case.value case_multi_point m 175 | | Line_string l -> Jsont.Object.Case.value case_line_string l 176 | | Multi_line_string m -> Jsont.Object.Case.value case_multi_linestr m 177 | | Polygon p -> Jsont.Object.Case.value case_polygon p 178 | | Multi_polygon m -> Jsont.Object.Case.value case_multi_polygon m 179 | | Geometry_collection gs -> Jsont.Object.Case.value case_coll gs 180 | and cases = Jsont.Object.Case.[ 181 | make case_point; make case_multi_point; make case_line_string; 182 | make case_multi_linestr; make case_polygon; make case_multi_polygon; 183 | make case_coll ] 184 | in 185 | Jsont.Object.map ~kind:"Geometry" make 186 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases 187 | ~tag_to_string:Fun.id ~tag_compare:String.compare 188 | |> Jsont.Object.opt_mem "id" id_jsont ~enc:id 189 | |> Jsont.Object.opt_mem "properties" properties_type ~enc:properties 190 | |> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox 191 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 192 | |> Jsont.Object.finish 193 | end 194 | 195 | let jsont = Lazy.force jsont 196 | type objects = t String_map.t 197 | let objects_jsont = Jsont.Object.as_string_map ~kind:"objects map" jsont 198 | end 199 | 200 | module Topology = struct 201 | type t = 202 | { objects : Geometry.objects; 203 | arcs : Arcs.t; 204 | transform : Transform.t option; 205 | bbox : Bbox.t option; 206 | unknown : Jsont.json } 207 | 208 | let make objects arcs transform bbox unknown = 209 | { objects; arcs; transform; bbox; unknown } 210 | 211 | let objects t = t.objects 212 | let arcs t = t.arcs 213 | let transform t = t.transform 214 | let bbox t = t.bbox 215 | let unknown t = t.unknown 216 | let jsont = 217 | let kind = "Topology" in 218 | Jsont.Object.map ~kind (fun () -> make) 219 | |> Jsont.Object.mem "type" (Jsont.enum [kind, ()]) ~enc:(Fun.const ()) 220 | |> Jsont.Object.mem "objects" Geometry.objects_jsont ~enc:objects 221 | |> Jsont.Object.mem "arcs" Arcs.jsont ~enc:arcs 222 | |> Jsont.Object.opt_mem "transform" Transform.jsont ~enc:transform 223 | |> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox 224 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 225 | |> Jsont.Object.finish 226 | end 227 | 228 | (* Command line interface *) 229 | 230 | let ( let* ) = Result.bind 231 | let strf = Printf.sprintf 232 | 233 | let log_if_error ~use = function 234 | | Ok v -> v 235 | | Error e -> 236 | let lines = String.split_on_char '\n' e in 237 | Format.eprintf "@[%a @[%a@]@]@." 238 | Jsont.Error.puterr () (Format.pp_print_list Format.pp_print_string) lines; 239 | use 240 | 241 | let with_infile file f = (* XXX add something to bytesrw. *) 242 | let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with 243 | | Sys_error e -> Error (Format.sprintf "@[%s:@,%s@]" file e) 244 | in 245 | try match file with 246 | | "-" -> process file In_channel.stdin 247 | | file -> In_channel.with_open_bin file (process file) 248 | with Sys_error e -> Error e 249 | 250 | let trip ~file ~format ~locs ~dec_only = 251 | log_if_error ~use:1 @@ 252 | with_infile file @@ fun r -> 253 | log_if_error ~use:1 @@ 254 | let* t = Jsont_bytesrw.decode ~file ~locs Topology.jsont r in 255 | if dec_only then Ok 0 else 256 | let w = Bytesrw.Bytes.Writer.of_out_channel stdout in 257 | let* () = Jsont_bytesrw.encode ~format ~eod:true Topology.jsont t w in 258 | Ok 0 259 | 260 | open Cmdliner 261 | open Cmdliner.Term.Syntax 262 | 263 | let topojson = 264 | Cmd.v (Cmd.info "topojson" ~doc:"round trip TopoJSON") @@ 265 | let+ file = 266 | let doc = "$(docv) is the TopoJSON file. Use $(b,-) for stdin." in 267 | Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE") 268 | and+ locs = 269 | let doc = "Preserve locations (better errors)." in 270 | Arg.(value & flag & info ["l"; "locs"] ~doc) 271 | and+ format = 272 | let fmt = [ "indent", Jsont.Indent; "minify", Jsont.Minify ] in 273 | let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt)in 274 | Arg.(value & opt (enum fmt) Jsont.Minify & 275 | info ["f"; "format"] ~doc ~docv:"FMT") 276 | and+ dec_only = 277 | let doc = "Decode only." in 278 | Arg.(value & flag & info ["d"] ~doc) 279 | in 280 | trip ~file ~format ~locs ~dec_only 281 | 282 | let main () = Cmd.eval' topojson 283 | let () = if !Sys.interactive then () else exit (main ()) 284 | -------------------------------------------------------------------------------- /test/geojson.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* GeoJSON codec https://datatracker.ietf.org/doc/html/rfc7946 7 | 8 | Note: a few length constraints on arrays should be checked, 9 | a combinators should be added for that. 10 | 11 | In contrast to Topojson the structure is a bit more annoying to 12 | model because there is subtyping on the "type" field: GeoJSON 13 | objects can be Feature, FeatureCollection or any Geometry object 14 | and Geometry objects are recursive on themselves (but not on 15 | Feature or Feature collection) and FeatureCollection only have 16 | Feature objects. We handle this by redoing the cases to handle only 17 | the subsets. *) 18 | 19 | type float_array = float array 20 | let float_array_jsont ~kind = Jsont.array ~kind Jsont.number 21 | 22 | type 'a garray = 'a array 23 | let garray = Jsont.array 24 | 25 | module Bbox = struct 26 | type t = float_array 27 | let jsont = float_array_jsont ~kind:"Bbox" 28 | end 29 | 30 | module Position = struct 31 | type t = float_array 32 | let jsont = float_array_jsont ~kind:"Position" 33 | end 34 | 35 | module Geojson_object = struct 36 | type 'a t = 37 | { type' : 'a; 38 | bbox : Bbox.t option; 39 | unknown : Jsont.json } 40 | 41 | let make type' bbox unknown = { type'; bbox; unknown } 42 | let type' o = o.type' 43 | let bbox o = o.bbox 44 | let unknown o = o.unknown 45 | 46 | let finish_jsont map = 47 | map 48 | |> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox 49 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 50 | |> Jsont.Object.finish 51 | 52 | let geometry ~kind coordinates = 53 | Jsont.Object.map ~kind make 54 | |> Jsont.Object.mem "coordinates" coordinates ~enc:type' 55 | |> finish_jsont 56 | end 57 | 58 | module Point = struct 59 | type t = Position.t 60 | let jsont = Geojson_object.geometry ~kind:"Point" Position.jsont 61 | end 62 | 63 | module Multi_point = struct 64 | type t = Position.t garray 65 | let jsont = 66 | Geojson_object.geometry ~kind:"MultiPoint" (garray Position.jsont) 67 | end 68 | 69 | module Line_string = struct 70 | type t = Position.t garray 71 | let jsont = 72 | Geojson_object.geometry ~kind:"LineString" (garray Position.jsont) 73 | end 74 | 75 | module Multi_line_string = struct 76 | type t = Line_string.t garray 77 | let jsont = 78 | Geojson_object.geometry ~kind:"LineString" (garray (garray Position.jsont)) 79 | end 80 | 81 | module Polygon = struct 82 | type t = Line_string.t garray 83 | let jsont = 84 | Geojson_object.geometry ~kind:"Polygon" (garray (garray Position.jsont)) 85 | end 86 | 87 | module Multi_polygon = struct 88 | type t = Polygon.t garray 89 | let jsont = 90 | Geojson_object.geometry ~kind:"MultiPolygon" 91 | (garray (garray (garray Position.jsont))) 92 | end 93 | 94 | module Geojson = struct 95 | type 'a object' = 'a Geojson_object.t 96 | type geometry = 97 | [ `Point of Point.t object' 98 | | `Multi_point of Multi_point.t object' 99 | | `Line_string of Line_string.t object' 100 | | `Multi_line_string of Multi_line_string.t object' 101 | | `Polygon of Polygon.t object' 102 | | `Multi_polygon of Multi_polygon.t object' 103 | | `Geometry_collection of geometry_collection object' ] 104 | and geometry_collection = geometry list 105 | 106 | module Feature = struct 107 | type id = [ `Number of float | `String of string ] 108 | type t = 109 | { id : id option; 110 | geometry : geometry option; 111 | properties : Jsont.json option; } 112 | 113 | let make id geometry properties = { id; geometry; properties } 114 | let make_geojson_object id geometry properties = 115 | Geojson_object.make (make id geometry properties) 116 | 117 | let id f = f.id 118 | let geometry f = f.geometry 119 | let properties f = f.properties 120 | 121 | type collection = t object' list 122 | end 123 | 124 | type t = 125 | [ `Feature of Feature.t object' 126 | | `Feature_collection of Feature.collection object' 127 | | geometry ] 128 | 129 | let point v = `Point v 130 | let multi_point v = `Multi_point v 131 | let line_string v = `Line_string v 132 | let multi_line_string v = `Multi_line_string v 133 | let polygon v = `Polygon v 134 | let multi_polygon v = `Multi_polygon v 135 | let geometry_collection vs = `Geometry_collection vs 136 | let feature v = `Feature v 137 | let feature_collection vs = `Feature_collection vs 138 | 139 | let feature_id_jsont = 140 | let number = 141 | let dec = Jsont.Base.dec (fun n -> `Number n) in 142 | let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) in 143 | Jsont.Base.number (Jsont.Base.map ~enc ~dec ()) 144 | in 145 | let string = 146 | let dec = Jsont.Base.dec (fun n -> `String n) in 147 | let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in 148 | Jsont.Base.string (Jsont.Base.map ~enc ~dec ()) 149 | in 150 | let enc = function `Number _ -> number | `String _ -> string in 151 | Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc () 152 | 153 | (* The first two Json types below handle subtyping by redoing 154 | cases for subsets of types. *) 155 | 156 | let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec 157 | 158 | let rec geometry_jsont = lazy begin 159 | let case_point = case_map Point.jsont point in 160 | let case_multi_point = case_map Multi_point.jsont multi_point in 161 | let case_line_string = case_map Line_string.jsont line_string in 162 | let case_multi_line_string = 163 | case_map Multi_line_string.jsont multi_line_string 164 | in 165 | let case_polygon = case_map Polygon.jsont polygon in 166 | let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in 167 | let case_geometry_collection = 168 | case_map (Lazy.force geometry_collection_jsont) geometry_collection 169 | in 170 | let enc_case = function 171 | | `Point v -> Jsont.Object.Case.value case_point v 172 | | `Multi_point v -> Jsont.Object.Case.value case_multi_point v 173 | | `Line_string v -> Jsont.Object.Case.value case_line_string v 174 | | `Multi_line_string v -> Jsont.Object.Case.value case_multi_line_string v 175 | | `Polygon v -> Jsont.Object.Case.value case_polygon v 176 | | `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v 177 | | `Geometry_collection v -> 178 | Jsont.Object.Case.value case_geometry_collection v 179 | in 180 | let cases = Jsont.Object.Case.[ 181 | make case_point; make case_multi_point; make case_line_string; 182 | make case_multi_line_string; make case_polygon; make case_multi_polygon; 183 | make case_geometry_collection ] 184 | in 185 | Jsont.Object.map ~kind:"Geometry object" Fun.id 186 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 187 | ~tag_to_string:Fun.id ~tag_compare:String.compare 188 | |> Jsont.Object.finish 189 | end 190 | 191 | and feature_jsont : Feature.t object' Jsont.t Lazy.t = lazy begin 192 | let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in 193 | let enc_case v = Jsont.Object.Case.value case_feature v in 194 | let cases = Jsont.Object.Case.[ make case_feature ] in 195 | Jsont.Object.map ~kind:"Feature" Fun.id 196 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 197 | ~tag_to_string:Fun.id ~tag_compare:String.compare 198 | |> Jsont.Object.finish 199 | end 200 | 201 | and case_feature_jsont : Feature.t object' Jsont.t Lazy.t = lazy begin 202 | Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object 203 | |> Jsont.Object.opt_mem "id" feature_id_jsont 204 | ~enc:(fun o -> Feature.id (Geojson_object.type' o)) 205 | |> Jsont.Object.mem "geometry" (Jsont.option (Jsont.rec' geometry_jsont)) 206 | ~enc:(fun o -> Feature.geometry (Geojson_object.type' o)) 207 | |> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object) 208 | ~enc:(fun o -> Feature.properties (Geojson_object.type' o)) 209 | |> Geojson_object.finish_jsont 210 | end 211 | 212 | and geometry_collection_jsont = lazy begin 213 | Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make 214 | |> Jsont.Object.mem "geometries" (Jsont.list (Jsont.rec' geometry_jsont)) 215 | ~enc:Geojson_object.type' 216 | |> Geojson_object.finish_jsont 217 | end 218 | 219 | and feature_collection_json = lazy begin 220 | Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make 221 | |> Jsont.Object.mem "features" Jsont.(list (Jsont.rec' feature_jsont)) 222 | ~enc:Geojson_object.type' 223 | |> Geojson_object.finish_jsont 224 | end 225 | 226 | and jsont : t Jsont.t Lazy.t = lazy begin 227 | let case_point = case_map Point.jsont point in 228 | let case_multi_point = case_map Multi_point.jsont multi_point in 229 | let case_line_string = case_map Line_string.jsont line_string in 230 | let case_multi_line_string = 231 | case_map Multi_line_string.jsont multi_line_string 232 | in 233 | let case_polygon = case_map Polygon.jsont polygon in 234 | let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in 235 | let case_geometry_collection = 236 | case_map (Lazy.force geometry_collection_jsont) geometry_collection 237 | in 238 | let case_feature = case_map (Lazy.force case_feature_jsont) feature in 239 | let case_feature_collection = 240 | case_map (Lazy.force feature_collection_json) feature_collection 241 | in 242 | let enc_case = function 243 | | `Point v -> Jsont.Object.Case.value case_point v 244 | | `Multi_point v -> Jsont.Object.Case.value case_multi_point v 245 | | `Line_string v -> Jsont.Object.Case.value case_line_string v 246 | | `Multi_line_string v -> Jsont.Object.Case.value case_multi_line_string v 247 | | `Polygon v -> Jsont.Object.Case.value case_polygon v 248 | | `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v 249 | | `Geometry_collection v -> 250 | Jsont.Object.Case.value case_geometry_collection v 251 | | `Feature v -> Jsont.Object.Case.value case_feature v 252 | | `Feature_collection v -> Jsont.Object.Case.value case_feature_collection v 253 | in 254 | let cases = Jsont.Object.Case.[ 255 | make case_point; make case_multi_point; make case_line_string; 256 | make case_multi_line_string; make case_polygon; make case_multi_polygon; 257 | make case_geometry_collection; make case_feature; 258 | make case_feature_collection ] 259 | in 260 | Jsont.Object.map ~kind:"GeoJSON" Fun.id 261 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 262 | ~tag_to_string:Fun.id ~tag_compare:String.compare 263 | |> Jsont.Object.finish 264 | end 265 | 266 | let jsont = Lazy.force jsont 267 | end 268 | 269 | (* Command line interface *) 270 | 271 | let ( let* ) = Result.bind 272 | let strf = Printf.sprintf 273 | 274 | let log_if_error ~use = function 275 | | Ok v -> v 276 | | Error e -> 277 | let lines = String.split_on_char '\n' e in 278 | Format.eprintf "@[%a @[%a@]@]" 279 | Jsont.Error.puterr () (Format.pp_print_list Format.pp_print_string) lines; 280 | use 281 | 282 | let with_infile file f = (* XXX add something to bytesrw. *) 283 | let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with 284 | | Sys_error e -> Error (Format.sprintf "@[%s:@,%s@]" file e) 285 | in 286 | try match file with 287 | | "-" -> process file In_channel.stdin 288 | | file -> In_channel.with_open_bin file (process file) 289 | with Sys_error e -> Error e 290 | 291 | let trip ~file ~format ~locs ~dec_only = 292 | log_if_error ~use:1 @@ 293 | with_infile file @@ fun r -> 294 | log_if_error ~use:1 @@ 295 | let* t = Jsont_bytesrw.decode ~file ~locs Geojson.jsont r in 296 | if dec_only then Ok 0 else 297 | let w = Bytesrw.Bytes.Writer.of_out_channel stdout in 298 | let* () = Jsont_bytesrw.encode ~format ~eod:true Geojson.jsont t w in 299 | Ok 0 300 | 301 | open Cmdliner 302 | open Cmdliner.Term.Syntax 303 | 304 | let geojson = 305 | Cmd.v (Cmd.info "geojson" ~doc:"round trip GeoJSON") @@ 306 | let+ file = 307 | let doc = "$(docv) is the GeoJSON file. Use $(b,-) for stdin." in 308 | Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE") 309 | and+ locs = 310 | let doc = "Preserve locations (better errors)." in 311 | Arg.(value & flag & info ["l"; "locs"] ~doc) 312 | and+ format = 313 | let fmt = [ "indent", Jsont.Indent; "minify", Jsont.Minify ] in 314 | let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt)in 315 | Arg.(value & opt (enum fmt) Jsont.Minify & 316 | info ["f"; "format"] ~doc ~docv:"FMT") 317 | and+ dec_only = 318 | let doc = "Decode only." in 319 | Arg.(value & flag & info ["d"] ~doc) 320 | in 321 | trip ~file ~format ~locs ~dec_only 322 | 323 | let main () = Cmd.eval' geojson 324 | let () = if !Sys.interactive then () else exit (main ()) 325 | -------------------------------------------------------------------------------- /src/brr/jsont_brr.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Jsont.Repr 7 | 8 | (* Converting between Jsont.Error.t and Jv.Error.t values *) 9 | 10 | let error_to_jv_error e = Jv.Error.v (Jstr.of_string (Jsont.Error.to_string e)) 11 | let jv_error_to_error e = 12 | let ctx = Jsont.Error.Context.empty and meta = Jsont.Meta.none in 13 | Jsont.Error.make_msg ctx meta (Jstr.to_string (Jv.Error.message e)) 14 | 15 | (* Browser JSON codec *) 16 | 17 | let indent = Jstr.v " " 18 | let json = Jv.get Jv.global "JSON" 19 | let json_parse s = Jv.call json "parse" [|Jv.of_jstr s|] 20 | let json_stringify ~format v = 21 | let args = match format with 22 | | Jsont.Minify -> [| v |] 23 | | Jsont.Indent | Jsont.Layout -> [|v; Jv.null; Jv.of_jstr indent|] 24 | in 25 | Jv.to_jstr (Jv.call json "stringify" args) 26 | 27 | (* Computing the sort of a Jv.t value *) 28 | 29 | let type_bool = Jstr.v "boolean" 30 | let type_object = Jstr.v "object" 31 | let type_number = Jstr.v "number" 32 | let type_string = Jstr.v "string" 33 | let type_array = Jv.get Jv.global "Array" 34 | 35 | let jv_sort jv = 36 | if Jv.is_null jv then Jsont.Sort.Null else 37 | let t = Jv.typeof jv in 38 | if Jstr.equal t type_bool then Jsont.Sort.Bool else 39 | if Jstr.equal t type_number then Jsont.Sort.Number else 40 | if Jstr.equal t type_string then Jsont.Sort.String else 41 | if Jstr.equal t type_object 42 | then (if Jv.is_array jv then Jsont.Sort.Array else Jsont.Sort.Object) else 43 | Jsont.Error.msgf Jsont.Meta.none "Not a JSON value: %s" (Jstr.to_string t) 44 | 45 | (* Getting the members of a Jv.t object in various ways *) 46 | 47 | let jv_mem_names jv = Jv.call (Jv.get Jv.global "Object") "keys" [| jv |] 48 | let jv_mem_name_list jv = Jv.to_list Jv.to_string (jv_mem_names jv) 49 | let jv_mem_name_map : Jv.t -> Jstr.t String_map.t = fun jv -> 50 | (* The map maps OCaml strings their corresponding JavaScript string *) 51 | let rec loop ns i max m = 52 | if i > max then m else 53 | let n = Jv.Jarray.get ns i in 54 | loop ns (i + 1) max (String_map.add (Jv.to_string n) (Jv.to_jstr n) m) 55 | in 56 | let ns = jv_mem_names jv in 57 | loop ns 0 (Jv.Jarray.length ns - 1) String_map.empty 58 | 59 | (* Decoding *) 60 | 61 | let error_push_array map i e = 62 | Jsont.Repr.error_push_array Jsont.Meta.none map (i, Jsont.Meta.none) e 63 | 64 | let error_push_object map n e = 65 | Jsont.Repr.error_push_object Jsont.Meta.none map (n, Jsont.Meta.none) e 66 | 67 | let type_error t ~fnd = 68 | Jsont.Repr.type_error Jsont.Meta.none t ~fnd 69 | 70 | let find_all_unexpected ~mem_decs mems = 71 | let unexpected (n, _jname) = match String_map.find_opt n mem_decs with 72 | | None -> Some (n, Jsont.Meta.none) | Some _ -> None 73 | in 74 | List.filter_map unexpected mems 75 | 76 | let rec decode : type a. a Jsont.Repr.t -> Jv.t -> a = 77 | fun t jv -> match t with 78 | | Null map -> 79 | (match jv_sort jv with 80 | | Null -> map.dec Jsont.Meta.none () 81 | | fnd -> type_error t ~fnd) 82 | | Bool map -> 83 | (match jv_sort jv with 84 | | Bool -> map.dec Jsont.Meta.none (Jv.to_bool jv) 85 | | fnd -> type_error t ~fnd) 86 | | Number map -> 87 | (match jv_sort jv with 88 | | Number -> map.dec Jsont.Meta.none (Jv.to_float jv) 89 | | Null -> map.dec Jsont.Meta.none Float.nan 90 | | fnd -> type_error t ~fnd) 91 | | String map -> 92 | (match jv_sort jv with 93 | | String -> map.dec Jsont.Meta.none (Jv.to_string jv) 94 | | fnd -> type_error t ~fnd) 95 | | Array map -> 96 | (match jv_sort jv with 97 | | Array -> decode_array map jv 98 | | fnd -> type_error t ~fnd) 99 | | Object map -> 100 | (match jv_sort jv with 101 | | Object -> decode_object map jv 102 | | fnd -> type_error t ~fnd) 103 | | Map map -> map.dec (decode map.dom jv) 104 | | Any map -> decode_any t map jv 105 | | Rec t -> decode (Lazy.force t) jv 106 | 107 | and decode_array : 108 | type a e b. (a, e, b) array_map -> Jv.t -> a 109 | = 110 | fun map jv -> 111 | let len = Jv.Jarray.length jv in 112 | let b = ref (map.dec_empty ()) in 113 | for i = 0 to len - 1 do 114 | try 115 | if map.dec_skip i !b then () else 116 | b := map.dec_add i (decode map.elt (Jv.Jarray.get jv i)) !b 117 | with Jsont.Error e -> error_push_array map i e 118 | done; 119 | map.dec_finish Jsont.Meta.none len !b 120 | 121 | and decode_object : type o. (o, o) object_map -> Jv.t -> o = 122 | fun map jv -> 123 | let names = jv_mem_name_map jv in 124 | let umems = Unknown_mems None in 125 | let dict = decode_object_map map umems String_map.empty Dict.empty names jv in 126 | apply_dict map.dec dict 127 | 128 | and decode_object_map : type o. 129 | (o, o) object_map -> unknown_mems_option -> mem_dec String_map.t -> Dict.t -> 130 | Jstr.t String_map.t -> Jv.t -> Dict.t 131 | = 132 | fun map umems mem_decs dict names jv -> 133 | let u _ _ _ = assert false (* They should be disjoint by contruction *) in 134 | let mem_decs = String_map.union u mem_decs map.mem_decs in 135 | match map.shape with 136 | | Object_cases (umems', cases) -> 137 | let umems' = Unknown_mems umems' in 138 | let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in 139 | decode_object_cases map umems cases mem_decs dict names jv 140 | | Object_basic umems' -> 141 | let umems' = Unknown_mems (Some umems') in 142 | let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in 143 | match umems with 144 | | Unknown_mems (Some Unknown_skip | None) -> 145 | let u = Unknown_skip in 146 | decode_object_basic 147 | map u () mem_decs dict (String_map.bindings names) jv 148 | | Unknown_mems (Some (Unknown_error as u)) -> 149 | decode_object_basic 150 | map u () mem_decs dict (String_map.bindings names) jv 151 | | Unknown_mems (Some (Unknown_keep (umap, _) as u)) -> 152 | let umap = umap.dec_empty () and names = String_map.bindings names in 153 | decode_object_basic map u umap mem_decs dict names jv 154 | 155 | and decode_object_basic : type o p m b. 156 | (o, o) object_map -> (p, m, b) unknown_mems -> b -> 157 | mem_dec String_map.t -> Dict.t -> (string * Jstr.t) list -> Jv.t -> Dict.t 158 | = 159 | fun map umems umap mem_decs dict names jv -> match names with 160 | | [] -> 161 | Jsont.Repr.finish_object_decode map Jsont.Meta.none umems umap mem_decs dict 162 | | (n, jname) :: names -> 163 | match String_map.find_opt n mem_decs with 164 | | Some (Mem_dec m) -> 165 | let dict = 166 | try Dict.add m.id (decode m.type' (Jv.get' jv jname)) dict with 167 | | Jsont.Error e -> error_push_object map n e 168 | in 169 | let mem_decs = String_map.remove n mem_decs in 170 | decode_object_basic map umems umap mem_decs dict names jv 171 | | None -> 172 | match umems with 173 | | Unknown_skip -> 174 | decode_object_basic map umems umap mem_decs dict names jv 175 | | Unknown_error -> 176 | let fnd = 177 | (n, Jsont.Meta.none) :: find_all_unexpected ~mem_decs names 178 | in 179 | Jsont.Repr.unexpected_mems_error Jsont.Meta.none map ~fnd 180 | | Unknown_keep (mmap, _) -> 181 | let umap = 182 | let v = try decode mmap.mems_type (Jv.get' jv jname) with 183 | | Jsont.Error e -> error_push_object map n e 184 | in 185 | mmap.dec_add Jsont.Meta.none n v umap 186 | in 187 | decode_object_basic map umems umap mem_decs dict names jv 188 | 189 | and decode_object_cases : type o cs t. 190 | (o, o) object_map -> unknown_mems_option -> (o, cs, t) object_cases -> 191 | mem_dec String_map.t -> Dict.t -> Jstr.t String_map.t -> Jv.t -> Dict.t 192 | = 193 | fun map umems cases mem_decs dict names jv -> 194 | let decode_case_tag tag = 195 | let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 196 | match List.find_opt eq_tag cases.cases with 197 | | None -> 198 | Jsont.Repr.unexpected_case_tag_error Jsont.Meta.none map cases tag 199 | | Some (Case case) -> 200 | let mems = String_map.remove cases.tag.name names in 201 | let dict = 202 | decode_object_map case.object_map umems mem_decs dict mems jv 203 | in 204 | Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict 205 | in 206 | match String_map.find_opt cases.tag.name names with 207 | | Some jname -> 208 | (try decode_case_tag (decode cases.tag.type' (Jv.get' jv jname)) with 209 | | Jsont.Error e -> error_push_object map cases.tag.name e) 210 | | None -> 211 | match cases.tag.dec_absent with 212 | | Some tag -> decode_case_tag tag 213 | | None -> 214 | let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in 215 | let fnd = jv_mem_name_list jv in 216 | Jsont.Repr.missing_mems_error Jsont.Meta.none map ~exp ~fnd 217 | 218 | and decode_any : type a. a t -> a any_map -> Jv.t -> a = 219 | fun t map jv -> 220 | let case t map sort jv = match map with 221 | | Some t -> decode t jv | None -> type_error t ~fnd:sort 222 | in 223 | match jv_sort jv with 224 | | Null as s -> case t map.dec_null s jv 225 | | Bool as s -> case t map.dec_bool s jv 226 | | Number as s -> case t map.dec_number s jv 227 | | String as s -> case t map.dec_string s jv 228 | | Array as s -> case t map.dec_array s jv 229 | | Object as s -> case t map.dec_object s jv 230 | 231 | let decode t jv = decode (Jsont.Repr.of_t t) jv 232 | let decode_jv' t jv = try Ok (decode t jv) with Jsont.Error e -> Error e 233 | let decode_jv t jv = Result.map_error error_to_jv_error (decode_jv' t jv) 234 | let decode' t s = try Ok (decode t (json_parse s)) with 235 | | Jv.Error e -> Error (jv_error_to_error e) | Jsont.Error e -> Error e 236 | 237 | let decode t json = Result.map_error error_to_jv_error (decode' t json) 238 | 239 | (* Encoding *) 240 | 241 | let rec encode : type a. a t -> a -> Jv.t = 242 | fun t v -> match t with 243 | | Null map -> map.enc v; Jv.null 244 | | Bool map -> Jv.of_bool (map.enc v) 245 | | Number map -> Jv.of_float (map.enc v) 246 | | String map -> Jv.of_string (map.enc v) 247 | | Array map -> 248 | let add map a i vi = try Jv.Jarray.set a i (encode map.elt vi); a with 249 | | Jsont.Error e -> error_push_array map i e 250 | in 251 | map.enc (add map) (Jv.Jarray.create 0) v 252 | | Object map -> encode_object map ~do_unknown:true v (Jv.obj [||]) 253 | | Any map -> encode (map.enc v) v 254 | | Map map -> encode map.dom (map.enc v) 255 | | Rec t -> encode (Lazy.force t) v 256 | 257 | and encode_object : 258 | type o. (o, o) Jsont.Repr.object_map -> do_unknown:bool -> o -> Jv.t -> Jv.t 259 | = 260 | fun map ~do_unknown o jv -> 261 | let encode_mem map o jv (Mem_enc mmap) = 262 | try 263 | let v = mmap.enc o in 264 | if mmap.enc_omit v then jv else 265 | (Jv.set' jv (Jstr.of_string mmap.name) (encode mmap.type' v); jv) 266 | with 267 | | Jsont.Error e -> error_push_object map mmap.name e 268 | in 269 | let jv = List.fold_left (encode_mem map o) jv map.mem_encs in 270 | match map.shape with 271 | | Object_basic (Unknown_keep (umap, enc)) when do_unknown -> 272 | encode_unknown_mems map umap (enc o) jv 273 | | Object_basic _ -> jv 274 | | Object_cases (u, cases) -> 275 | let Case_value (case, v) = cases.enc_case (cases.enc o) in 276 | let jv = 277 | try 278 | if cases.tag.enc_omit case.tag then jv else 279 | let tag = encode cases.tag.type' case.tag in 280 | Jv.set' jv (Jstr.of_string cases.tag.name) tag; jv 281 | with 282 | | Jsont.Error e -> error_push_object map cases.tag.name e 283 | in 284 | match u with 285 | | Some (Unknown_keep (umap, enc)) -> 286 | (* Feels nicer to encode unknowns at the end *) 287 | let jv = encode_object case.object_map ~do_unknown:false v jv in 288 | encode_unknown_mems map umap (enc o) jv 289 | | _ -> encode_object case.object_map ~do_unknown v jv 290 | 291 | and encode_unknown_mems : type o mems a builder. 292 | (o, o) object_map -> (mems, a, builder) mems_map -> mems -> Jv.t -> Jv.t = 293 | fun map umap mems jv -> 294 | let encode_mem map meta name v jv = 295 | try Jv.set' jv (Jstr.of_string name) (encode umap.mems_type v); jv with 296 | | Jsont.Error e -> error_push_object map name e 297 | in 298 | umap.enc (encode_mem map) mems jv 299 | 300 | let encode t v = encode (Jsont.Repr.of_t t) v 301 | let encode_jv' t v = try Ok (encode t v) with Jsont.Error e -> Error e 302 | let encode_jv t v = Result.map_error error_to_jv_error (encode_jv' t v) 303 | let encode' ?(format = Jsont.Minify) t v = 304 | try Ok (json_stringify ~format (encode t v)) with 305 | | Jv.Error e -> Error (jv_error_to_error e) 306 | | Jsont.Error e -> Error e 307 | 308 | let encode ?format t v = 309 | Result.map_error error_to_jv_error (encode' ?format t v) 310 | 311 | (* Recode *) 312 | 313 | let recode ?format t s = match decode t s with 314 | | Error _ as e -> e | Ok v -> encode ?format t v 315 | 316 | let recode' ?format t s = match decode' t s with 317 | | Error _ as e -> e | Ok v -> encode' ?format t v 318 | 319 | let recode_jv t jv = match decode_jv t jv with 320 | | Error _ as e -> e | Ok v -> encode_jv t v 321 | 322 | let recode_jv' t s = match decode_jv' t s with 323 | | Error _ as e -> e | Ok v -> encode_jv' t v 324 | -------------------------------------------------------------------------------- /paper/jfp-reject.txt: -------------------------------------------------------------------------------- 1 | Submitted: 2024-06-26 2 | Decision: 2024-08-29 3 | 4 | Dear Mr. Bünzli: 5 | 6 | Manuscript ID JFP-2024-0027 entitled "An alphabet for your data soups" 7 | which you submitted to the Journal of Functional Programming, has been 8 | reviewed. The comments from reviewers are included at the bottom of 9 | this letter. 10 | 11 | In view of the criticisms of the reviewers, I must decline the 12 | manuscript for publication in the Journal of Functional Programming at 13 | this time. However, a *new* manuscript may be submitted which takes 14 | into consideration these comments. 15 | 16 | Please note that resubmitting your manuscript does not guarantee 17 | eventual acceptance, and that your resubmission will be subject to 18 | re-review by the reviewers before a decision is rendered. 19 | 20 | You will be unable to make your revisions on the originally submitted 21 | version of your manuscript. Instead, revise your manuscript and submit 22 | it as a new paper. 23 | 24 | If you decide to resubmit, please state the manuscript number of the 25 | previous submission in your cover letter. 26 | 27 | 28 | Sincerely, 29 | Prof. Functional Pearls 30 | Journal of Functional Programming 31 | prof-pearls@online.de 32 | 33 | Editors' Comments to Author 34 | 35 | Reviewers' Comments to Author: 36 | Referee: 1 37 | 38 | Comments to the Author 39 | 40 | This paper presents an OCaml combinator library for converting between 41 | JSON data and ML typed values. The library may be a joy to use, but 42 | this functional pearl doesn’t show that: Concrete examples of how to 43 | use the library are scant; for instance, Section 3.5 lists three 44 | “patterns found in JSON data schemas that we want to support”, but 45 | only the first pattern is illustrated (“in Section 3”), and the “query 46 | and update” combinators in Section 5 are not shown in use at all. The 47 | library may be intellectually stimulating to build, but this 48 | functional pearl doesn’t show that: Implementation code often appears 49 | whose purpose is unclear (for instance, in Section 3.5.1). 50 | 51 | I suggest the author think long and hard about what is instructive or 52 | nifty or interesting (hereafter “joyful”) about building or using this 53 | library. Then, pare down the library and the writing to only that 54 | part. For instance, if “objects as uniform key-value maps” and 55 | “objects as sums” are not joyful, then get rid of them. If query and 56 | update are not joyful, then get rid of them and remove dec_skip as 57 | well. On the other hand, if query and update are what’s joyful, then 58 | do you really need to decode and encode JSON data in order to share 59 | that joy? Finally, be sure to show what’s good with concrete examples, 60 | early and often. 61 | 62 | Referee: 2 63 | 64 | Comments to the Author 65 | # Summary 66 | 67 | This pearl describes a richly typed eDSL to write bidirectional 68 | maps between JSON with an underlying (unenforced, potentially 69 | dynamic) format and ML values. 70 | The core of the paper is dedicated to describing at length 71 | the effort that goes into defining the GADT used to model 72 | these maps. 73 | A final section develops how one can reuse the machinery to 74 | define query & update combinators operating directly over the 75 | JSON objects. 76 | 77 | # Assessment 78 | 79 | I think this is interesting work however it currently feels 80 | too brutally technical and without clear design / correctness 81 | criteria to read like a pearl: « programs are fun, and they 82 | teach important programming techniques and fundamental design 83 | principle » (Jon Bentley on the definition of a programming 84 | pearl cf. https://www.cs.ox.ac.uk/people/jeremy.gibbons/pearls/) 85 | 86 | I would also like to see more of a discussion of the related work. 87 | 88 | # Main comments 89 | 90 | ## Missing examples 91 | 92 | If the main goal is well motivated by the important goal of 93 | being able to program against a JSON "soup" in a structured 94 | and typed manner, each construct is poorly justified. 95 | 96 | It would be nice for each section to have some small examples 97 | justifying why some of these definitions are so complex. Give 98 | us concrete instances of these structures you are describing! 99 | 100 | p5: Any case 101 | This was really confusing to me at first until I understood 102 | (?) that the idea is that e.g. decoding (Number n) at type 103 | (Any m) amounts to decoding (Number n) at type (m.dec_number). 104 | I think it would be useful to sprinkle some examples here instead 105 | of just relying on "it embeds dynamic typing in our datatype". 106 | I even wonder whether it'd be useful to show the code for 107 | `decode_any` in parallel with the definition of `option`. 108 | 109 | p9: Object shapes. 110 | Again this lacks motivation IMO. Give us plenty of examples 111 | showing why all of this complexity is needed! 112 | 113 | The description of object cases is even more puzzling. 114 | 115 | ## Missing explanations 116 | 117 | p7: dec_fun definition 118 | Please give a one sentence definitition of type ids so that 119 | we don't need to lookup the ocaml docs just to understand what 120 | they are. Looking at the code for `Dict.t`, it seems to be a 121 | unique `int` allowing you to test type equality. 122 | 123 | AFAIU this means all the arguments need to have different 124 | types. Why is that a sensible assumption? 125 | 126 | But looking at obj_mem, `Type.Id.make ()` seems to suggest 127 | it's not in fact a unique ID per type but rather an ID for 128 | something that happens to have this type. 129 | 130 | Again, this would be a lot easier to understand with a 131 | proper explanation from the get go. 132 | 133 | ## Correction of type description 134 | 135 | Given that the typed description induces an encoder and a 136 | decoder, it would be nice to have a correctness theorem. 137 | I suspect there is no hope to get `encode . decode = id` 138 | (multiple possible representations of the same value) but 139 | we definitely want to have `decode . encode = id`. 140 | 141 | Correspondingly, I feel the presentation is missing the 142 | precise characterisation of the invariants we expect the 143 | users to respect. Ideally these could be expressed as 144 | properties testable using something like quickcheck. 145 | 146 | In particular, this means specifying: 147 | 148 | p4: Map case 149 | define "bidirectional map" more precisely: what sort of 150 | properties do you expect? E.g. `dec` being a partial inverse 151 | to `enc` but not the other way around? More than that? Less? 152 | 153 | p5: Array case 154 | Again here it'd be nice to have a property you expect to 155 | hold for the component to be well behaved. I would expect 156 | something along the lines of: 157 | `dec_finish (enc (\ b, elt -> dec_add b ??? elt) dec_empty arr) = arr` 158 | except that `dec_add` takes an index which is not available from 159 | inside the `enc` fold. 160 | 161 | ## Missing related work section 162 | 163 | You cited pickler combinators and alluded to generic programming 164 | but I think it would be interesting to discuss more extensively 165 | the fairly important tradition of writing "invertible parsers", 166 | "bidirectional programs", "partial isomorphisms", etc. to 167 | obtain pairs of a parser and a pretty printer e.g. 168 | 169 | * There and back again: arrows for invertible programming by Alimarine 170 | * Invertible syntax descriptions: unifying parsing and pretty printing by Rendel 171 | * Correct-by-construction pretty-printing by Nils Anders Danielsson 172 | * Generic packet descriptions by Van Geest 173 | * FliPpr: A System for Deriving Parsers from Pretty-Printers by Matsuda 174 | 175 | Some of these (Generic packet descriptions) include types of 176 | formats that your approach cannot handle (cf. next point) 177 | 178 | The query & update section naturally brings up the (unexplored?) 179 | relationship to lenses & prisms. 180 | 181 | 182 | ## Missing discussion of possible extension 183 | 184 | It would be interesting to have a discussion of some 185 | features of common format specifications that are not 186 | tackled by the current work. 187 | 188 | E.g. some formats specify 189 | - *computed* fields e.g. checksums, or 190 | - *constrained* fields e.g. a payload whose length is specified 191 | in another field. 192 | 193 | Could these be accommodated? Or do you need to move to 194 | a more powerful type system like in 'Generic packet 195 | descriptions' by Van Geest mentioned above? 196 | 197 | # Minor issues 198 | 199 | p3: Typed representation 200 | "laziest readers" -> find better wording (or is that meant 201 | to be a pun for readers using a lazy ML?) 202 | 203 | p5: Array case 204 | Given that skip & add take an index, is it worth 205 | adding a type alias `type index = int` to suggest 206 | it's meant to be a non-negative number? 207 | 208 | 209 | Referee: 3 210 | 211 | Comments to the Author 212 | 213 | ---- Summary ---- 214 | 215 | This paper describes a library for working with JSON data. The key idea 216 | is not to describe JSON directly (as in Section 2), but rather to define 217 | a GADT describing the conversion between some OCaml type a and its JSON 218 | representation (Section 3). Given such a description, it is easy to 219 | define the actual encoding/decoding with respect to JSON and functions 220 | to query/update JSON data. 221 | 222 | ---- Review ---- 223 | 224 | Conversion between algebraic datatypes and JSON is a well studied 225 | problem: there are 100+ OCaml packages and 300+ Haskell packages for 226 | interfacing with (some form of) JSON data. It is certainly an 227 | interesting and important problem. 228 | 229 | My main concern with this paper is that it descibes a solution (the GADT 230 | is Section 3), without explicitly introducing the problem and motivating 231 | the underlying design choices that lead to this solution. This is very 232 | important, not only because there is already so much work in this area, 233 | but this distinguishes a research paper from a library documentation. 234 | Especially for a pearl, I am keen to read the _ideas_ that (naturally) 235 | lead to this solution and not just the code that makes things tick. 236 | 237 | Let me illustrate this point with a few examples: 238 | 239 | * the GADT jsont has a separate constructor for 'map' -- essentially 240 | used to map a conversion over another GADT value. This seems rather 241 | arbitrary: was it necessary for important examples? Could there be an 242 | alternative GADT that supports map as a defined operation, rather than 243 | a separate constructor? 244 | 245 | * Similarly, the case for arrays, given by the 'array_map' record, has 246 | several functions to build and convert arrays. Why choose _these_ 247 | functions? Could there be others that are also useful? What 248 | considerations lead to these primitives? 249 | 250 | * The base_map type has conversions between a and b -- can these fail? 251 | What (roundtrip) properties should they satisfy? There is an obvious 252 | relation with lensest that should be mentioned at the very least. 253 | 254 | * The most elaborate case is that for objects. Here the design is 255 | pragmatic -- motivated by several typical use cases for objects (given 256 | at the beginning of section 3.5). Once again, I managed to read along 257 | with the code, but the principles that lead to this solution are left 258 | implicit: why does mem_map have precisely these fields? The key 259 | (heterogeneous) dictionary is in the appendix -- but what purpose does 260 | 'a Type.Id.t serve? The 'apply_dict' function can still fail 261 | dynamically using Option.get -- is this a problem? If the library aims 262 | to provide more (type) safety than working with JSON directly, these 263 | issues and design choices need to be more carefully discussed. 264 | 265 | This last point also shows up in section 5, where the various update and 266 | delete functions can all still throw type errors; similarly, the 267 | handling of the Any type (section 3.4) seems arbitrary and prone to 268 | dynamic failure again. If there are so many places where (type) unsafety 269 | can still sneak in -- what is achieved by the proposed solution? Could 270 | these limitations be addressed by more fancy type features? And what 271 | trade-off lead to this particular design? 272 | 273 | I would strongly recommend Simon Peyton Jones' talk on "How to write 274 | great research paper" -- one of the key points it to try to convey the 275 | main ideas; the implementation should follow naturally. 276 | 277 | The current introduction was not helpful in positioning the paper. Many 278 | of the points made about 'this datatype' don't make much sense on first 279 | reading -- I haven't seen the datatype yet and found it very hard to 280 | appreciate these contributions. It would be very helpful to formulate 281 | the design goals (and limitations!), independently of the actual 282 | implementation. Making these concrete by means of examples would really 283 | help -- phrases such as 'partially modelled data schemas', 'datatype 284 | generic representations' or 'generic representation of the data model' 285 | do not have much meaning without more context. 286 | 287 | A good pearl does not need to exhaustively discuss related work, but 288 | there are plenty of other papers and libraries that tackle similar 289 | issues, including but not limited to the view-update problem (and 290 | lenses), other (generic programming) solutions to JSON 291 | encoding/decoding, and the many other libraries that tackle the same 292 | issue. 293 | 294 | This work and these ideas may yet lead to an interesting pearl, but the 295 | article in its current form is not yet ready for publication. 296 | 297 | ---- Typos / minor suggestions ---- 298 | 299 | * General, there are no line numbers. The JFP style file requires these 300 | for submissions -- they would make giving specific feedback much 301 | easier. 302 | 303 | * page 1 - 'directly on their own type system' -- I believe this is not 304 | a property of dynamic languages in general, but rather the way 305 | Javascript/Python support objects. Try to be more specific here. 306 | 307 | * page 2 - use endashes (--) surrounded by spaces (the JFP default); or 308 | emdashes (---) without spaces, but never mix these style. 309 | 310 | * page 2 - it would be useful to give an example of the Json struct -- 311 | and illustrate why this solution is unsatisfactory to more clearly 312 | motivate the solution presented in the next section. 313 | 314 | * page 3 - I know enough OCaml to get by, but what does ~enc:content 315 | mean? Why is the twiddle necessary here? 316 | 317 | * page 4 - 'mapping unit values with m' sounds like m is a function, 318 | while it isn't! 319 | 320 | * page 4 - 'answer is rather negative' sounds odd, perhaps 'this is not the 321 | case'? And if it isn't the case, 322 | 323 | * page 4 - 'it is not directly evident in our simpler exposition...' - 324 | this feels like a rather weak argument. I can understand the 325 | importance of simplifying code for the sake of presentation -- but 326 | apparently there are other design considerations at play that have not 327 | yet been mentioned. 328 | 329 | * page 6 - sentences like 'the JSON type json which maps any JSON value' 330 | indicate that there may be a need for better terminology here. 331 | 332 | * page 6 ' retaining efficient decodes' grammar - perhaps 'efficient decoding'? 333 | 334 | * page 7 - contructor -> constructor 335 | 336 | * 'must type as defined by the object map otherwise the decode errors' - 337 | grammar -> 'all definitions must be typed in accordance with the 338 | object map otherwise the decoding fails.' 339 | -------------------------------------------------------------------------------- /test/test_common_samples.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | 7 | module String_map = Map.Make (String) 8 | 9 | (* Items to do. *) 10 | 11 | module Status = struct 12 | type t = Todo | Done | Cancelled 13 | let assoc = ["todo", Todo; "done", Done; "cancelled", Cancelled ] 14 | let jsont = Jsont.enum ~kind:"Status" assoc 15 | end 16 | 17 | module Item = struct 18 | type t = { task : string; status : Status.t; tags : string list; } 19 | let make task status tags = { task; status; tags } 20 | let task i = i.task 21 | let status i = i.status 22 | let tags i = i.tags 23 | let jsont = 24 | Jsont.Object.map ~kind:"Item" make 25 | |> Jsont.Object.mem "task" Jsont.string ~enc:task 26 | |> Jsont.Object.mem "status" Status.jsont ~enc:status 27 | |> Jsont.Object.mem "tags" 28 | Jsont.(list string) ~dec_absent:[] ~enc:tags ~enc_omit:(( = ) []) 29 | |> Jsont.Object.finish 30 | 31 | end 32 | 33 | module Item_data = struct 34 | let i0 = Item.{ task = "Hey"; status = Todo; tags = ["huhu";"haha"] } 35 | let i0_json = (* in Jsont.Indent format *) 36 | "{\n\ 37 | \ \"task\": \"Hey\",\n\ 38 | \ \"status\": \"todo\",\n\ 39 | \ \"tags\": [\n\ 40 | \ \"huhu\",\n\ 41 | \ \"haha\"\n\ 42 | \ ]\n\ 43 | }" 44 | 45 | let i1 = Item.{ task = "Ho"; status = Done; tags = [] } 46 | let i1_json = (* in Jsont.Indent format *) 47 | "{\n\ 48 | \ \"task\": \"Ho\",\n\ 49 | \ \"status\": \"done\"\n\ 50 | }" 51 | end 52 | 53 | (* JSON types to excerice the different unknown member behaviours. *) 54 | 55 | module Unknown = struct 56 | type t = { m : bool } 57 | let make m = { m } 58 | let m v = v.m 59 | 60 | let skip_jsont = 61 | Jsont.Object.map ~kind:"unknown-skip" make 62 | |> Jsont.Object.mem "m" Jsont.bool ~enc:m 63 | |> Jsont.Object.skip_unknown 64 | |> Jsont.Object.finish 65 | 66 | let error_jsont = 67 | Jsont.Object.map ~kind:"unknown-skip" make 68 | |> Jsont.Object.mem "m" Jsont.bool ~enc:m 69 | |> Jsont.Object.error_unknown 70 | |> Jsont.Object.finish 71 | 72 | let keep_jsont : (t * int String_map.t) Jsont.t = 73 | let unknown = Jsont.Object.Mems.string_map Jsont.int in 74 | Jsont.Object.map ~kind:"unknown-keep" (fun m imap -> make m, imap) 75 | |> Jsont.Object.mem "m" Jsont.bool ~enc:(fun (v, _) -> m v) 76 | |> Jsont.Object.keep_unknown unknown ~enc:snd 77 | |> Jsont.Object.finish 78 | end 79 | 80 | module Unknown_data = struct 81 | let u0 = {| { "m": true } |} 82 | let u1 = {| { "m": true, "u0": 0, "u1": 1 } |} 83 | let u2 = {| { "u": 0, "m": true } |} 84 | end 85 | 86 | (* Object cases *) 87 | 88 | module Cases = struct 89 | (* There are two ways to encode object cases in OCaml, either as a toplevel 90 | variant or as a record with a field that is a variant. With the design 91 | we have the encoding is mostly the same. This is the JSON we deal with: 92 | 93 | { "type": "author", 94 | "name": "…", 95 | "pseudo": "…", 96 | "book_count": 1 } 97 | 98 | { "type": "editor", 99 | "name": "…", 100 | "publisher": "…" } *) 101 | 102 | module Person_top = struct (* Toplevel variant *) 103 | module Author = struct 104 | type t = { name : string; pseudo : string; book_count : int; } 105 | let make name book_count pseudo = { name; pseudo; book_count } 106 | let name a = a.name 107 | let book_count a = a.book_count 108 | let pseudo a = a.pseudo 109 | let jsont = 110 | Jsont.Object.map ~kind:"Author" make 111 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 112 | |> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count 113 | |> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo 114 | |> Jsont.Object.finish 115 | end 116 | 117 | module Editor = struct 118 | type t = { name : string; publisher : string } 119 | let make name publisher = { name; publisher} 120 | let name e = e.name 121 | let publisher e = e.publisher 122 | let jsont = 123 | Jsont.Object.map ~kind:"Editor" make 124 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 125 | |> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher 126 | |> Jsont.Object.finish 127 | end 128 | 129 | type t = Author of Author.t | Editor of Editor.t 130 | 131 | let author a = Author a 132 | let editor e = Editor e 133 | 134 | let jsont = 135 | let case_a = Jsont.Object.Case.map "author" Author.jsont ~dec:author in 136 | let case_e = Jsont.Object.Case.map "editor" Editor.jsont ~dec:editor in 137 | let cases = Jsont.Object.Case.[make case_a; make case_e] in 138 | let enc_case = function 139 | | Author a -> Jsont.Object.Case.value case_a a 140 | | Editor e -> Jsont.Object.Case.value case_e e 141 | in 142 | Jsont.Object.map ~kind:"Person" Fun.id 143 | |> Jsont.Object.case_mem "type" 144 | Jsont.string ~tag_to_string:Fun.id ~enc:Fun.id ~enc_case cases 145 | |> Jsont.Object.finish 146 | end 147 | 148 | module Person_field = struct (* Variant in a field *) 149 | type author = { pseudo : string; book_count : int } 150 | let make_author pseudo book_count = { pseudo; book_count } 151 | let pseudo a = a.pseudo 152 | let book_count a = a.book_count 153 | let author_jsont = 154 | Jsont.Object.map ~kind:"Author" make_author 155 | |> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo 156 | |> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count 157 | |> Jsont.Object.finish 158 | 159 | type editor = { publisher : string; } 160 | let make_editor publisher = { publisher } 161 | let publisher e = e.publisher 162 | let editor_jsont = 163 | Jsont.Object.map ~kind:"Editor" make_editor 164 | |> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher 165 | |> Jsont.Object.finish 166 | 167 | type type' = Author of author | Editor of editor 168 | let author a = Author a 169 | let editor e = Editor e 170 | 171 | type t = { type' : type'; name : string } 172 | let make type' name = { type'; name } 173 | let type' v = v.type' 174 | let name v = v.name 175 | 176 | let jsont = 177 | let case_a = Jsont.Object.Case.map "author" author_jsont ~dec:author in 178 | let case_e = Jsont.Object.Case.map "editor" editor_jsont ~dec:editor in 179 | let cases = Jsont.Object.Case.[make case_a; make case_e] in 180 | let enc_case = function 181 | | Author a -> Jsont.Object.Case.value case_a a 182 | | Editor e -> Jsont.Object.Case.value case_e e 183 | in 184 | Jsont.Object.map ~kind:"Person" make 185 | |> Jsont.Object.case_mem "type" 186 | ~tag_to_string:Fun.id Jsont.string ~enc:type' ~enc_case cases 187 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 188 | |> Jsont.Object.finish 189 | end 190 | 191 | module Keep_unknown = struct 192 | type a = string String_map.t 193 | let a_jsont = 194 | let unknown = Jsont.Object.Mems.string_map Jsont.string in 195 | Jsont.Object.map ~kind:"A" Fun.id 196 | |> Jsont.Object.keep_unknown unknown ~enc:Fun.id 197 | |> Jsont.Object.finish 198 | 199 | type b = { name : string } 200 | let name b = b.name 201 | let b_jsont = 202 | Jsont.Object.map ~kind:"B" (fun name -> { name }) 203 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 204 | |> Jsont.Object.error_unknown 205 | |> Jsont.Object.finish 206 | 207 | type type' = A of a | B of b 208 | let a a = A a 209 | let b b = B b 210 | type t = { type' : type'; unknown : Jsont.json } 211 | let make type' unknown = { type'; unknown } 212 | let type' v = v.type' 213 | let unknown v = v.unknown 214 | let equal v0 v1 = match v0.type', v1.type' with 215 | | A a0, A a1 -> 216 | String_map.equal String.equal a0 a1 && 217 | Jsont.Json.equal v0.unknown v1.unknown 218 | | B b0, B b1 -> 219 | String.equal b0.name b1.name && 220 | Jsont.Json.equal v0.unknown v1.unknown 221 | | _, _ -> false 222 | 223 | let pp ppf v = B0_std.Fmt.string ppf "" 224 | 225 | let jsont = 226 | let case_a = Jsont.Object.Case.map "A" a_jsont ~dec:a in 227 | let case_b = Jsont.Object.Case.map "B" b_jsont ~dec:b in 228 | let cases = Jsont.Object.Case.[make case_a; make case_b] in 229 | let enc_case = function 230 | | A a -> Jsont.Object.Case.value case_a a 231 | | B b -> Jsont.Object.Case.value case_b b 232 | in 233 | Jsont.Object.map ~kind:"Keep_unknown" make 234 | |> Jsont.Object.case_mem "type" 235 | ~tag_to_string:Fun.id Jsont.string ~enc:type' ~enc_case cases 236 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 237 | |> Jsont.Object.finish 238 | end 239 | 240 | end 241 | 242 | module Cases_data = struct 243 | let author0_top, author0_field = 244 | let name = "Jane" and book_count = 2 and pseudo = "Jude" in 245 | Cases.Person_top.Author { name; book_count; pseudo }, 246 | { Cases.Person_field.type' = Author { book_count; pseudo }; name } 247 | 248 | let invalid_miss = (* Missing type field. *) 249 | {| { "name": "Jane", "tope": "ha", "tape": "ha", 250 | "book_count": 2, "pseudo": "Jude" }|} 251 | 252 | let invalid_case = 253 | {| { "type": "reader", "name": "Jane" }|} 254 | 255 | let author0 = 256 | {| { "type": "author", "name": "Jane", "book_count": 2, "pseudo": "Jude" }|} 257 | 258 | let author0' = (* out of order case field in the middle *) 259 | {| { "name": "Jane", "book_count": 2, "type": "author", "pseudo": "Jude" }|} 260 | 261 | let editor0_top, editor0_field = 262 | let name = "Joe" and publisher = "Red books" in 263 | Cases.Person_top.Editor { name; publisher }, 264 | { Cases.Person_field.type' = Editor { publisher }; name } 265 | 266 | let editor0 = 267 | {| { "type": "editor", "name": "Joe", "publisher": "Red books" } |} 268 | 269 | let editor0' = (* out of order case field at the end *) 270 | {| { "name": "Joe", "publisher": "Red books", "type": "editor" } |} 271 | 272 | let unknown_a = 273 | {| { "m1": "n", "type": "A", "m0": "o" } |} 274 | 275 | let unknown_b = 276 | {| { "type": "B", "m1": "v1", "name": "ha", "m2": 0 } |} 277 | 278 | let unknown_a_value = 279 | let unknown = 280 | Jsont.Json.(object' [mem (name "m0") (string "o"); 281 | mem (name "m1") (string "n")]) 282 | in 283 | Cases.Keep_unknown.make (A String_map.empty) unknown 284 | 285 | let unknown_a_a_value = 286 | String_map.empty 287 | |> String_map.add "m0" "o" 288 | |> String_map.add "m1" "n" 289 | |> String_map.add "type" "A" 290 | 291 | let unknown_a_no_a_unknown = "{\n \"type\": \"A\"\n}" 292 | let unknown_a_no_a_unknown_value = 293 | (* Since the map should be ignored since the case object overides it *) 294 | let unknown = Jsont.Json.object' [] in 295 | Cases.Keep_unknown.make (A String_map.(empty |> add "bli" "bla")) unknown 296 | 297 | let unknown_b_value = 298 | let unknown = 299 | Jsont.Json.(object' [mem (name "m1") (string "v1"); 300 | mem (name "m2") (number 0.0)]) 301 | in 302 | Cases.Keep_unknown.make (B { name = "ha" }) unknown 303 | end 304 | 305 | (* Type recursion *) 306 | 307 | module Tree = struct 308 | type 'a tree = Empty | Node of 'a tree * 'a * 'a tree 309 | 310 | let rec pp pp_v ppf = function 311 | | Empty -> Format.fprintf ppf "Empty" 312 | | Node (l, v, r) -> 313 | Format.fprintf ppf "@[Node @[<1>(%a,@ %a,@ %a)@]@]" 314 | (pp pp_v) l pp_v v (pp pp_v) r 315 | 316 | (* Encoded with null for Empty and nodes with: 317 | 318 | { "left": …, 319 | "value": …, 320 | "right": … } 321 | 322 | and null is used for empty. *) 323 | let jsont_with_null t = 324 | let rec tree = lazy begin 325 | let empty = Jsont.null Empty in 326 | let node = 327 | let not_a_node () = failwith "not a node" in 328 | let value = function Node (_, v, _) -> v | _ -> not_a_node () in 329 | let left = function Node (l, _, _) -> l | _ -> not_a_node () in 330 | let right = function Node (_, _, r) -> r | _ -> not_a_node () in 331 | Jsont.Object.map ~kind:"node" (fun l v r -> Node (l, v, r)) 332 | |> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree) 333 | |> Jsont.Object.mem ~enc:value "value" t 334 | |> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree) 335 | |> Jsont.Object.finish 336 | in 337 | let enc = function Empty -> empty | Node _ -> node in 338 | Jsont.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc () 339 | end 340 | in 341 | Lazy.force tree 342 | 343 | (* Encoded as two cases : 344 | 345 | { "type": "empty" } 346 | 347 | { "type": "node", 348 | "left": …, 349 | "value": …, 350 | "right": … } *) 351 | 352 | let jsont_with_cases t = 353 | let rec tree = lazy begin 354 | let leaf_jsont = Jsont.Object.map Empty |> Jsont.Object.finish in 355 | let node_jsont = 356 | let not_a_node () = failwith "not a node" in 357 | let value = function Node (_, v, _) -> v | _ -> not_a_node () in 358 | let left = function Node (l, _, _) -> l | _ -> not_a_node () in 359 | let right = function Node (_, _, r) -> r | _ -> not_a_node () in 360 | Jsont.Object.map (fun l v r -> Node (l, v, r)) 361 | |> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree) 362 | |> Jsont.Object.mem ~enc:value "value" t 363 | |> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree) 364 | |> Jsont.Object.finish 365 | in 366 | let case_leaf = Jsont.Object.Case.map "empty" leaf_jsont ~dec:Fun.id in 367 | let case_node = Jsont.Object.Case.map "node" node_jsont ~dec:Fun.id in 368 | let enc_case = function 369 | | Empty as v -> Jsont.Object.Case.value case_leaf v 370 | | Node _ as v -> Jsont.Object.Case.value case_node v 371 | in 372 | let cases = Jsont.Object.Case.[ make case_leaf; make case_node ] in 373 | Jsont.Object.map ~kind:"tree" Fun.id 374 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 375 | |> Jsont.Object.finish 376 | end 377 | in 378 | Lazy.force tree 379 | 380 | end 381 | 382 | module Tree_data = struct 383 | let empty = Tree.Empty 384 | let empty_null = {| null |} 385 | let empty_cases = {| { "type": "empty" } |} 386 | 387 | let tree0 = Tree.Node (Node (Node (Empty, 1, Empty), 388 | 2, 389 | Empty), 390 | 3, 391 | Node (Empty, 4, Empty)) 392 | 393 | let tree0_null = 394 | {| { "left": { "left": { "left": null, "value": 1, "right": null }, 395 | "value": 2, 396 | "right": null }, 397 | "value": 3, 398 | "right": { "left": null, "value": 4, "right": null } } |} 399 | 400 | let tree0_cases = (* Case member not in order to check decode delays. *) 401 | {| { "left": { "type": "node", 402 | "left": { "type": "node", 403 | "left": { "type": "empty" }, 404 | "right": { "type": "empty" }, 405 | "value": 1 }, 406 | "value": 2, 407 | "right": { "type" : "empty" }}, 408 | "value": 3, 409 | "type": "node", 410 | "right": { "type": "node", 411 | "left": { "type" : "empty" }, 412 | "value": 4, 413 | "right": { "type" : "empty" }}} |} 414 | end 415 | -------------------------------------------------------------------------------- /test/jsont_tool.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The jsont programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | let ( let* ) = Result.bind 7 | 8 | let strf = Format.asprintf 9 | let log_if_error ~use = function 10 | | Ok v -> v 11 | | Error e -> 12 | let exec = Filename.basename Sys.executable_name in 13 | let lines = String.split_on_char '\n' e in 14 | Format.eprintf "%s: %a @[%a@]@." 15 | exec Jsont.Error.puterr () Format.(pp_print_list pp_print_string) lines; 16 | use 17 | 18 | let exit_err_file = 1 19 | let exit_err_json = 2 20 | let exit_err_diff = 3 21 | 22 | module Os = struct 23 | 24 | (* Emulate B0_std.Os functionality to eschew the dep. 25 | Note: this is only used for the [diff] function. *) 26 | 27 | let read_file file = 28 | try 29 | let ic = if file = "-" then stdin else open_in_bin file in 30 | let finally () = if file = "-" then () else close_in_noerr ic in 31 | Fun.protect ~finally @@ fun () -> Ok (In_channel.input_all ic) 32 | with 33 | | Sys_error err -> Error err 34 | 35 | let write_file file s = 36 | try 37 | let oc = if file = "-" then stdout else open_out_bin file in 38 | let finally () = if file = "-" then () else close_out_noerr oc in 39 | Fun.protect ~finally @@ fun () -> Ok (Out_channel.output_string oc s) 40 | with 41 | | Sys_error err -> Error err 42 | 43 | let with_tmp_dir f = 44 | try 45 | let tmpdir = 46 | let file = Filename.temp_file "cmarkit" "dir" in 47 | (Sys.remove file; Sys.mkdir file 0o700; file) 48 | in 49 | let finally () = try Sys.rmdir tmpdir with Sys_error _ -> () in 50 | Fun.protect ~finally @@ fun () -> Ok (f tmpdir) 51 | with 52 | | Sys_error err -> Error ("Making temporary dir: " ^ err) 53 | 54 | let with_cwd cwd f = 55 | try 56 | let curr = Sys.getcwd () in 57 | let () = Sys.chdir cwd in 58 | let finally () = try Sys.chdir curr with Sys_error _ -> () in 59 | Fun.protect ~finally @@ fun () -> Ok (f ()) 60 | with 61 | | Sys_error err -> Error ("With cwd: " ^ err) 62 | end 63 | 64 | let diff src fmted = 65 | let env = ["GIT_CONFIG_SYSTEM=/dev/null"; "GIT_CONFIG_GLOBAL=/dev/null"; ] in 66 | let set_env = match Sys.win32 with 67 | | true -> String.concat "" (List.map (fun e -> "set " ^ e ^ " && ") env) 68 | | false -> String.concat " " env 69 | in 70 | let diff = "git diff --ws-error-highlight=all --no-index --patience " in 71 | let src_file = "src" and fmted_file = "fmt" in 72 | let cmd = String.concat " " [set_env; diff; src_file; fmted_file] in 73 | Result.join @@ Result.join @@ Os.with_tmp_dir @@ fun dir -> 74 | Os.with_cwd dir @@ fun () -> 75 | let* () = Os.write_file src_file src in 76 | let* () = Os.write_file fmted_file fmted in 77 | Ok (Sys.command cmd) 78 | 79 | let with_infile file f = (* XXX add something to bytesrw. *) 80 | let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with 81 | | Sys_error e -> Error (Format.sprintf "@[%s:@,%s@]" file e) 82 | in 83 | try match file with 84 | | "-" -> process file In_channel.stdin 85 | | file -> In_channel.with_open_bin file (process file) 86 | with Sys_error e -> Error e 87 | 88 | let output ~format ~number_format j = match format with 89 | | `Pretty -> Ok (Format.printf "@[%a@]@." (Jsont.pp_json' ~number_format ()) j) 90 | | `Format format -> 91 | let w = Bytesrw.Bytes.Writer.of_out_channel stdout in 92 | Jsont_bytesrw.encode ~format ~number_format ~eod:true Jsont.json j w 93 | 94 | let output_string ~format ~number_format j = match format with 95 | | `Pretty -> Ok (Format.asprintf "@[%a@]" (Jsont.pp_json' ~number_format ()) j) 96 | | `Format format -> 97 | Jsont_bytesrw.encode_string ~format ~number_format Jsont.json j 98 | 99 | let trip_type 100 | ?(dec_only = false) ~file ~format ~number_format ~diff:do_diff ~locs t 101 | = 102 | log_if_error ~use:exit_err_file @@ 103 | with_infile file @@ fun r -> 104 | log_if_error ~use:exit_err_json @@ 105 | let layout = format = `Format Jsont.Layout in 106 | match do_diff with 107 | | false -> 108 | let* j = Jsont_bytesrw.decode ~file ~layout ~locs t r in 109 | if dec_only then Ok 0 else 110 | let* () = output ~format ~number_format j in 111 | Ok 0 112 | | true -> 113 | let src = Bytesrw.Bytes.Reader.to_string r in 114 | let* j = Jsont_bytesrw.decode_string ~file ~layout ~locs t src in 115 | let* fmted = output_string ~format ~number_format j in 116 | (match diff src fmted with 117 | | Ok exit -> if exit = 0 then Ok 0 else Ok exit_err_diff 118 | | Error e -> Format.eprintf "%s" e; Ok Cmdliner.Cmd.Exit.some_error) 119 | 120 | let delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs = 121 | let del = Jsont.delete_path ~allow_absent path in 122 | trip_type ~file ~format ~number_format ~diff ~locs del 123 | 124 | let fmt ~file ~format ~number_format ~diff ~locs ~dec_only = 125 | trip_type ~file ~format ~number_format ~diff ~locs ~dec_only Jsont.json 126 | 127 | let get ~file ~path ~format ~number_format ~diff ~absent ~locs = 128 | let get = Jsont.path ?absent path Jsont.json in 129 | trip_type ~file ~format ~number_format ~diff ~locs get 130 | 131 | let locs' ~file = 132 | let pf = Format.fprintf in 133 | let pp_code = Jsont.Repr.pp_code in 134 | let pp_locs_outline ppf v = 135 | let indent = 2 in 136 | let loc label ppf m = 137 | pf ppf "@[%s:@,%a@]@," 138 | label Jsont.Textloc.pp_ocaml (Jsont.Meta.textloc m) 139 | in 140 | let rec value ppf = function 141 | | Jsont.Null ((), m) -> 142 | loc (strf "%a" pp_code (strf "%a" Jsont.pp_null ())) ppf m 143 | | Jsont.Bool (b, m) -> 144 | loc (strf "Bool %a" pp_code (strf "%a" Jsont.pp_bool b)) ppf m 145 | | Jsont.Number (n, m) -> 146 | loc (strf "Number %a" pp_code (strf "%a" Jsont.pp_number n)) ppf m 147 | | Jsont.String (s, m) -> 148 | loc (strf "String %a" pp_code (strf "%a" Jsont.pp_string s)) ppf m 149 | | Jsont.Array (l, m) -> 150 | Format.pp_open_vbox ppf indent; 151 | loc "Array" ppf m; (Format.pp_print_list value) ppf l; 152 | Format.pp_close_box ppf () 153 | | Jsont.Object (o, m) -> 154 | let mem ppf ((name, m), v) = 155 | let l = strf "Member %a" pp_code (strf "%a" Jsont.pp_string name) in 156 | loc l ppf m; value ppf v; 157 | in 158 | Format.pp_open_vbox ppf indent; 159 | loc "Object" ppf m; (Format.pp_print_list mem) ppf o; 160 | Format.pp_close_box ppf () 161 | in 162 | value ppf v 163 | in 164 | log_if_error ~use:exit_err_file @@ 165 | with_infile file @@ fun reader -> 166 | log_if_error ~use:exit_err_json @@ 167 | let* j = Jsont_bytesrw.decode ~file ~locs:true Jsont.json reader in 168 | pp_locs_outline Format.std_formatter j; 169 | Ok 0 170 | 171 | let set 172 | ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json:j ~locs 173 | = 174 | let set = Jsont.set_path ?stub ~allow_absent Jsont.json path j in 175 | trip_type ~file ~format ~number_format ~diff ~locs set 176 | 177 | (* Command line interface *) 178 | 179 | open Cmdliner 180 | open Cmdliner.Term.Syntax 181 | 182 | let exits = 183 | Cmd.Exit.info exit_err_file ~doc:"on file read errors." :: 184 | Cmd.Exit.info exit_err_json ~doc:"on JSON parse or path errors." :: 185 | Cmd.Exit.info exit_err_diff ~doc:"on JSON output differences." :: 186 | Cmd.Exit.defaults 187 | 188 | let path_arg = Arg.conv' ~docv:"JSON_PATH" Jsont.Path.(of_string, pp) 189 | let json_arg = 190 | let of_string s = 191 | Jsont_bytesrw.decode_string ~locs:true ~layout:true Jsont.json s 192 | in 193 | let pp = Jsont.pp_json in 194 | Arg.conv' ~docv:"JSON" (of_string, pp) 195 | 196 | let format_opt ~default = 197 | let fmt = 198 | [ "indent", `Format Jsont.Indent; 199 | "minify", `Format Jsont.Minify; 200 | "preserve", `Format Jsont.Layout; 201 | "pretty", `Pretty ] 202 | in 203 | let doc = 204 | strf "Output style. Must be %s. $(b,minify) guarantess there is \ 205 | no CR (U+000D) or LF (U+000A) in the output. $(b,pretty) is \ 206 | similar to $(b,indent) but may yield more compact outputs." 207 | (Arg.doc_alts_enum fmt) 208 | in 209 | Arg.(value & opt (enum fmt) default & info ["f"; "format"] ~doc ~docv:"FMT") 210 | 211 | let format_opt_default_pretty = format_opt ~default:`Pretty 212 | let format_opt_default_preserve = format_opt ~default:(`Format Jsont.Layout) 213 | 214 | let allow_absent_opt = 215 | let doc = "Do not error if $(i,JSON_PATH) does not exist." in 216 | Arg.(value & flag & info ["a"; "allow-absent"] ~doc) 217 | 218 | let locs_default_false = 219 | let doc = "Keep track of source locations (improves error messages)." in 220 | Arg.(value & flag & info ["locs"] ~doc) 221 | 222 | let locs_default_true = 223 | let doc = "Do not keep track of source locations." in 224 | Term.(const ( not ) $ Arg.(value & flag & info ["no-locs"] ~doc)) 225 | 226 | let number_format_opt = 227 | let doc = "Use C float format string $(docv) to format JSON numbers." in 228 | let number_format : Jsont.number_format Arg.conv = 229 | let parse s = 230 | try Ok (Scanf.format_from_string s Jsont.default_number_format) with 231 | | Scanf.Scan_failure _ -> 232 | Error (strf "Cannot format a float with %S" s) 233 | in 234 | let pp ppf fmt = Format.pp_print_string ppf (string_of_format fmt) in 235 | Arg.conv' (parse, pp) 236 | in 237 | Arg.(value & opt number_format Jsont.default_number_format & 238 | info ["n"; "number-format"] ~doc ~docv:"FMT") 239 | 240 | let diff_flag = 241 | let doc = 242 | "Output diff between input and output (needs $(b,git) in \ 243 | your $(b,PATH)). Exits with 0 only there are no differences." 244 | in 245 | Arg.(value & flag & info ["diff"] ~doc) 246 | 247 | let dec_only = 248 | let doc = "Decode only, no output." in 249 | Arg.(value & flag & info ["d"; "decode-only"] ~doc) 250 | 251 | let file_pos ~pos:p = 252 | let doc = "$(docv) is the JSON file. Use $(b,-) for stdin." in 253 | Arg.(value & pos p string "-" & info [] ~doc ~docv:"FILE") 254 | 255 | let file_pos0 = file_pos ~pos:0 256 | let file_pos1 = file_pos ~pos:1 257 | let file_pos2 = file_pos ~pos:2 258 | 259 | let common_man = 260 | [ `S Manpage.s_bugs; 261 | `P "This program is distributed with the jsont OCaml library. \ 262 | See $(i,https://erratique.ch/software/jsont) for contact \ 263 | information."; ] 264 | 265 | let delete_cmd = 266 | let doc = "Delete the value indexed by a JSON path" in 267 | let sdocs = Manpage.s_common_options in 268 | let man = [ 269 | `S Manpage.s_description; 270 | `P "$(iname) deletes the value indexed by a JSON path. Outputs $(b,null) \ 271 | on the root path $(b,'.'). Examples:"; 272 | `Pre "$(iname) $(b,keywords.[0] package.json)"; `Noblank; 273 | `Pre "$(iname) $(b,-a keywords.[0] package.json)"; 274 | `Blocks common_man; ] 275 | in 276 | let path_opt = 277 | let doc = "Delete JSON path $(docv)." and docv = "JSON_PATH" in 278 | Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv) 279 | in 280 | Cmd.v (Cmd.info "delete" ~doc ~sdocs ~exits ~man) @@ 281 | let+ file = file_pos1 282 | and+ path = path_opt 283 | and+ format = format_opt_default_preserve 284 | and+ number_format = number_format_opt 285 | and+ diff = diff_flag 286 | and+ allow_absent = allow_absent_opt 287 | and+ locs = locs_default_true in 288 | delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs 289 | 290 | let fmt_cmd = 291 | let doc = "Format JSON" in 292 | let sdocs = Manpage.s_common_options in 293 | let man = [ 294 | `S Manpage.s_description; 295 | `P "$(iname) formats JSON. Examples:"; 296 | `Pre "$(iname) $(b,package.json)"; `Noblank; 297 | `Pre "$(iname) $(b,-f minify package.json)"; 298 | `Blocks common_man; ] 299 | in 300 | Cmd.v (Cmd.info "fmt" ~doc ~sdocs ~exits ~man) @@ 301 | let+ file = file_pos0 302 | and+ format = format_opt_default_pretty 303 | and+ number_format = number_format_opt 304 | and+ diff = diff_flag 305 | and+ locs = locs_default_false 306 | and+ dec_only = dec_only in 307 | fmt ~file ~format ~number_format ~diff ~locs ~dec_only 308 | 309 | let get_cmd = 310 | let doc = "Extract the value indexed by a JSON path" in 311 | let sdocs = Manpage.s_common_options in 312 | let man = [ 313 | `S Manpage.s_description; 314 | `P "$(iname) outputs the value indexed by a JSON path. Examples:"; 315 | `Pre "$(iname) $(b,'keywords.[0]' package.json)"; `Noblank; 316 | `Pre "$(iname) $(b,-a 'null' 'keywords.[0]' package.json)"; `Noblank; 317 | `Pre "$(iname) $(b,-a '[]' 'keywords' package.json)"; `Noblank; 318 | `Pre "$(iname) $(b,'.' package.json)"; 319 | `Blocks common_man; ] 320 | in 321 | let path_pos = 322 | let doc = "Extract the value indexed by JSON path $(docv)." in 323 | Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH") 324 | in 325 | let absent_opt = 326 | let doc = "Do not error if $(i,JSON_PATH) does not exist, output $(docv) \ 327 | instead." 328 | in 329 | Arg.(value & opt (some json_arg) None & 330 | info ["a"; "absent"] ~doc ~docv:"JSON") 331 | in 332 | Cmd.v (Cmd.info "get" ~doc ~sdocs ~exits ~man) @@ 333 | let+ file = file_pos1 334 | and+ path = path_pos 335 | and+ format = format_opt_default_pretty 336 | and+ number_format = number_format_opt 337 | and+ diff = diff_flag 338 | and+ absent = absent_opt 339 | and+ locs = locs_default_true in 340 | get ~file ~path ~format ~number_format ~diff ~absent ~locs 341 | 342 | let set_cmd = 343 | let doc = "Set the value indexed by a JSON path" in 344 | let sdocs = Manpage.s_common_options in 345 | let man = [ 346 | `S Manpage.s_description; 347 | `P "$(iname) sets the value indexed by a JSON path. Examples:"; 348 | `Pre "$(iname) $(b,keywords '[\"codec\"]' package.json)"; `Noblank; 349 | `Pre "$(iname) $(b,keywords.[0] '\"codec\"' package.json)"; `Noblank; 350 | `Pre "$(iname) $(b,-a keywords.[4] '\"codec\"' package.json)"; `Noblank; 351 | `Pre "$(iname) $(b,-s null -a keywords.[4] '\"codec\"' package.json)"; 352 | `Blocks common_man; ] 353 | in 354 | let path_pos = 355 | let doc = "Set the value indexed by JSON path $(docv)." in 356 | Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH") 357 | in 358 | let json_pos = 359 | let doc = "Set value to $(docv)." in 360 | Arg.(required & pos 1 (some json_arg) None & info [] ~doc ~docv:"JSON") 361 | in 362 | let stub = 363 | let doc = 364 | "Use $(b,docv) as a stub value to use if an array needs to be extended \ 365 | when $(b,-a) is used. By default uses the natural zero of the \ 366 | set data: null for null, false for booleans, 0 for numbers, empty 367 | string for strings, empty array for array, empty object for object." 368 | in 369 | Arg.(value & opt (some json_arg) None & info ["s"; "stub"] ~doc 370 | ~docv:"JSON") 371 | in 372 | Cmd.v (Cmd.info "set" ~doc ~sdocs ~exits ~man) @@ 373 | let+ file = file_pos2 374 | and+ path = path_pos 375 | and+ json = json_pos 376 | and+ stub = stub 377 | and+ format = format_opt_default_preserve 378 | and+ number_format = number_format_opt 379 | and+ diff = diff_flag 380 | and+ allow_absent = allow_absent_opt 381 | and+ locs = locs_default_true in 382 | set ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json ~locs 383 | 384 | let locs_cmd = 385 | let doc = "Show JSON parse locations" in 386 | let sdocs = Manpage.s_common_options in 387 | let man = [ 388 | `S Manpage.s_description; 389 | `P "$(tname) outputs JSON parse locations. Example:"; 390 | `Pre "$(iname) $(b,package.json)"; 391 | `Blocks common_man; ] 392 | in 393 | Cmd.v (Cmd.info "locs" ~doc ~sdocs ~exits ~man) @@ 394 | let+ file = file_pos0 in 395 | locs' ~file 396 | 397 | let jsont = 398 | let doc = "Process JSON data" in 399 | let sdocs = Manpage.s_common_options in 400 | let man = [ 401 | `S Manpage.s_description; 402 | `P "$(mname) processes JSON data in various ways."; 403 | `Pre "$(b,curl -L URL) | $(mname) $(b,fmt)"; `Noblank; 404 | `Pre "$(mname) $(b,fmt package.json)"; `Noblank; 405 | `Pre "$(mname) $(b,get 'keywords.[0]' package.json)"; `Noblank; 406 | `Pre "$(mname) $(b,set 'keywords.[0]' '\"codec\"' package.json)"; `Noblank; 407 | `Pre "$(mname) $(b,delete 'keywords.[0]' package.json)"; 408 | `P "More information about $(b,jsont)'s JSON paths is in the section \ 409 | JSON PATHS below."; 410 | `S Manpage.s_commands; 411 | `S Manpage.s_common_options; 412 | `S "JSON PATHS"; 413 | `P "For $(mname) a JSON path is a dot separated sequence of \ 414 | indexing operations. For example $(b,books.[1].authors.[0]) indexes \ 415 | an object on the $(b,books) member, then on the second element of \ 416 | an array, then the $(b,authors) member of an object and finally \ 417 | the first element of that array. The root path is $(b,.), it can 418 | be omitted if there are indexing operations."; 419 | `P "In general because of your shell's special characters it's better \ 420 | to single quote your JSON paths."; 421 | `P "Note that $(mname)'s JSON PATH are unrelated to the JSONPath \ 422 | query language (RFC 9535)."; 423 | `Blocks common_man; ] 424 | in 425 | Cmd.group (Cmd.info "jsont" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man) @@ 426 | [get_cmd; delete_cmd; fmt_cmd; locs_cmd; set_cmd;] 427 | 428 | let main () = Cmd.eval' jsont 429 | let () = if !Sys.interactive then () else exit (main ()) 430 | -------------------------------------------------------------------------------- /paper/soup.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 Daniel C. Bünzli. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Definitions from the soup.tex paper *) 7 | 8 | module Type = struct (* Can be deleted with OCaml >= 5.1 *) 9 | type (_, _) eq = Equal : ('a, 'a) eq 10 | module Id = struct 11 | type _ id = .. 12 | module type ID = sig type t type _ id += Id : t id end 13 | type 'a t = (module ID with type t = 'a) 14 | 15 | let make (type a) () : a t = 16 | (module struct type t = a type _ id += Id : t id end) 17 | 18 | let provably_equal 19 | (type a b) ((module A) : a t) ((module B) : b t) : (a, b) eq option 20 | = 21 | match A.Id with B.Id -> Some Equal | _ -> None 22 | 23 | let uid (type a) ((module A) : a t) = 24 | Obj.Extension_constructor.id (Obj.Extension_constructor.of_val A.Id) 25 | end 26 | end 27 | 28 | module String_map = Map.Make (String) 29 | 30 | (* Generic representation *) 31 | 32 | module Json = struct 33 | type t = 34 | | Null of unit | Bool of bool | Number of float | String of string 35 | | Array of t list | Obj of obj and obj = mem list and mem = string * t 36 | end 37 | 38 | (* The finally tagged datatype *) 39 | 40 | type ('ret, 'f) dec_fun = 41 | | Dec_fun : 'f -> ('ret, 'f) dec_fun 42 | | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 43 | 44 | type ('a, 'b) base_map = { dec : 'a -> 'b; enc : 'b -> 'a; } 45 | 46 | type _ jsont = 47 | | Null : (unit, 'b) base_map -> 'b jsont 48 | | Bool : (bool, 'b) base_map -> 'b jsont 49 | | Number : (float, 'b) base_map -> 'b jsont 50 | | String : (string, 'b) base_map -> 'b jsont 51 | | Array : ('a, 'elt, 'builder) array_map -> 'a jsont 52 | | Obj : ('o, 'o) obj_map -> 'o jsont 53 | | Any : 'a any_map -> 'a jsont 54 | | Map : ('a, 'b) map -> 'b jsont 55 | | Rec : 'a jsont Lazy.t -> 'a jsont 56 | 57 | and ('array, 'elt, 'builder) array_map = 58 | { elt : 'elt jsont; 59 | dec_empty : 'builder; 60 | dec_skip : 'builder -> int -> bool; 61 | dec_add : 'builder -> int -> 'elt -> 'builder; 62 | dec_finish : 'builder -> 'array; 63 | enc : 'acc. ('acc -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; } 64 | 65 | and ('o, 'dec) obj_map = 66 | { dec : ('o, 'dec) dec_fun; 67 | mem_decs : mem_dec String_map.t; 68 | mem_encs : 'o mem_enc list; 69 | shape : 'o obj_shape; } 70 | 71 | and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec 72 | and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 73 | and ('o, 'a) mem_map = 74 | { name : string; 75 | type' : 'a jsont; 76 | id : 'a Type.Id.t; 77 | dec_absent : 'a option; 78 | enc : 'o -> 'a; 79 | enc_omit : 'a -> bool; } 80 | 81 | and 'o obj_shape = 82 | | Obj_basic : ('o, 'mems, 'builder) unknown_mems -> 'o obj_shape 83 | | Obj_cases : ('o, 'cases, 'tag) obj_cases -> 'o obj_shape 84 | 85 | and ('o, 'mems, 'builder) unknown_mems = 86 | | Unknown_skip : ('o, unit, unit) unknown_mems 87 | | Unknown_error : ('o, unit, unit) unknown_mems 88 | | Unknown_keep : 89 | ('mems, 'a, 'builder) mems_map * ('o -> 'mems) -> 90 | ('o, 'mems, 'builder) unknown_mems 91 | 92 | and ('mems, 'a, 'builder) mems_map = 93 | { mems_type : 'a jsont; 94 | id : 'mems Type.Id.t; 95 | dec_empty : 'builder; 96 | dec_add : string -> 'a -> 'builder -> 'builder; 97 | dec_finish : 'builder -> 'mems; 98 | enc : 'acc. (string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc } 99 | 100 | and ('o, 'cases, 'tag) obj_cases = 101 | { tag : ('o, 'tag) mem_map; (* 'o is irrelevant, 'tag is not stored *) 102 | tag_compare : 'tag -> 'tag -> int; 103 | id : 'cases Type.Id.t; 104 | cases : ('cases, 'tag) case list; 105 | enc : 'o -> 'cases; 106 | enc_case : 'cases -> ('cases, 'tag) case_value; } 107 | 108 | and ('cases, 'tag) case = 109 | | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 110 | 111 | and ('cases, 'case, 'tag) case_map = 112 | { tag : 'tag; 113 | obj_map : ('case, 'case) obj_map; 114 | dec : 'case -> 'cases; } 115 | 116 | and ('cases, 'tag) case_value = 117 | | Case_value : 118 | ('cases, 'case, 'tag) case_map * 'case -> ('cases, 'tag) case_value 119 | 120 | and 'a any_map = 121 | { dec_null : 'a jsont option; 122 | dec_bool : 'a jsont option; 123 | dec_number : 'a jsont option; 124 | dec_string : 'a jsont option; 125 | dec_array : 'a jsont option; 126 | dec_obj : 'a jsont option; 127 | enc : 'a -> 'a jsont; } 128 | 129 | and ('a, 'b) map = 130 | { dom : 'a jsont; 131 | map : ('a, 'b) base_map } 132 | 133 | (* Errors *) 134 | 135 | let type_error () = failwith "type error" 136 | let unexpected_member n = failwith ("Unexpected member " ^ n) 137 | let missing_member n = failwith ("Missing member " ^ n) 138 | let unknown_case_tag () = failwith "Unknown case tag" 139 | 140 | (* Any examples *) 141 | 142 | let option : 'a jsont -> 'a option jsont = fun t -> 143 | let none = Null { dec = Fun.const None; enc = Fun.const () } in 144 | let some = Map { dom = t; map = {dec = Option.some; enc = Option.get}}in 145 | let enc = function None -> none | Some _ -> some in 146 | let none = Some none and some = Some some in 147 | Any { dec_null = none; dec_bool = some; dec_number = some; 148 | dec_string = some; dec_array = some; dec_obj = some; enc; } 149 | 150 | let json : Json.t jsont = (* left as an exercise in the paper *) 151 | let null = 152 | Null { dec = (fun () -> Json.Null ()); 153 | enc = (function Json.Null () -> () | j -> type_error ()) } 154 | in 155 | let bool = 156 | Bool { dec = (fun b -> Json.Bool b); 157 | enc = (function Json.Bool b -> b | j -> type_error ()) } 158 | in 159 | let number = 160 | Number { dec = (fun n -> Json.Number n); 161 | enc = (function Json.Number n -> n | j -> type_error ()) } 162 | in 163 | let string = 164 | String { dec = (fun s -> Json.String s); 165 | enc = (function Json.String s -> s | j -> type_error ()) } 166 | in 167 | let rec array = 168 | let dec_empty = [] and dec_add a _i v = v :: a in 169 | let dec_finish elts = Json.Array (List.rev elts) in 170 | let dec_skip _ _ = false in 171 | let enc f acc = function 172 | | Json.Array vs -> List.fold_left f acc vs | _ -> type_error () 173 | in 174 | Array { elt = Rec json; dec_empty; dec_add; dec_skip; dec_finish; enc } 175 | and obj = 176 | let mems_id = Type.Id.make () in 177 | let mems = 178 | let dec_empty = [] in 179 | let dec_add n v ms = (n, v) :: ms in 180 | let dec_finish ms = Json.Obj (List.rev ms) in 181 | let enc f j acc = match j with 182 | | Json.Obj ms -> List.fold_left (fun acc (n, v) -> f n v acc) acc ms 183 | | _ -> type_error () 184 | in 185 | { mems_type = Rec json; id = mems_id; dec_empty; dec_add; dec_finish; enc} 186 | in 187 | Obj { dec = Dec_app (Dec_fun Fun.id, mems_id); 188 | mem_decs = String_map.empty; mem_encs = []; 189 | shape = Obj_basic (Unknown_keep (mems, Fun.id)) } 190 | and json = 191 | let enc = function 192 | | Json.Null _ -> null | Json.Bool _ -> bool | Json.Number _ -> number 193 | | Json.String _ -> string | Json.Array _ -> array | Json.Obj _ -> obj 194 | in 195 | lazy (Any { dec_null = Some null; dec_bool = Some bool; 196 | dec_number = Some number; dec_string = Some string; 197 | dec_array = Some array; dec_obj = Some obj; enc }) 198 | in 199 | Lazy.force json 200 | 201 | (* Heterogeneous key-value maps *) 202 | 203 | module Dict = struct 204 | module M = Map.Make (Int) 205 | type binding = B : 'a Type.Id.t * 'a -> binding 206 | type t = binding M.t 207 | let empty = M.empty 208 | let add k v m = M.add (Type.Id.uid k) (B (k, v)) m 209 | let find : type a. a Type.Id.t -> t -> a option = 210 | fun k m -> match M.find_opt (Type.Id.uid k) m with 211 | | None -> None 212 | | Some B (k', v) -> 213 | match Type.Id.provably_equal k k' with 214 | | Some Type.Equal -> Some v | None -> assert false 215 | end 216 | 217 | type ('ret, 'f) app = 218 | | Fun : 'f -> ('ret, 'f) app 219 | | App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app 220 | 221 | let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f = 222 | fun dec dict -> match dec with 223 | | Dec_fun f -> f 224 | | Dec_app (f,arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict)) 225 | 226 | (* Decode *) 227 | 228 | let rec decode : type a. a jsont -> Json.t -> a = 229 | fun t j -> match t with 230 | | Null map -> (match j with Json.Null v -> map.dec v | _ -> type_error ()) 231 | | Bool map -> (match j with Json.Bool b -> map.dec b | _ -> type_error ()) 232 | | Number map -> 233 | (match j with 234 | | Json.Number n -> map.dec n | Json.Null _ -> map.dec Float.nan 235 | | _ -> type_error ()) 236 | | String map -> (match j with Json.String s -> map.dec s | _ -> type_error ()) 237 | | Array map -> 238 | (match j with Json.Array vs -> decode_array map vs | j -> type_error ()) 239 | | Obj map -> 240 | (match j with Json.Obj mems -> decode_obj map mems | j -> type_error ()) 241 | | Map map -> map.map.dec (decode map.dom j) 242 | | Any map -> decode_any t map j 243 | | Rec t -> decode (Lazy.force t) j 244 | 245 | and decode_array : type a e b. (a, e, b) array_map -> Json.t list -> a = 246 | fun map vs -> 247 | let add (i, a) v = 248 | i + 1, (if map.dec_skip a i then a else map.dec_add a i (decode map.elt v)) 249 | in 250 | map.dec_finish (snd (List.fold_left add (0, map.dec_empty) vs)) 251 | 252 | and decode_obj : type o. (o, o) obj_map -> Json.obj -> o = 253 | fun map mems -> 254 | apply_dict map.dec @@ 255 | decode_obj_map map String_map.empty String_map.empty Dict.empty mems 256 | 257 | and decode_obj_map : type o. 258 | (o, o) obj_map -> mem_dec String_map.t -> mem_dec String_map.t -> Dict.t -> 259 | Json.obj -> Dict.t 260 | = 261 | fun map mem_miss mem_decs dict mems -> 262 | let u n _ _ = invalid_arg (n ^ "member defined twice") in 263 | let mem_miss = String_map.union u mem_miss map.mem_decs in 264 | let mem_decs = String_map.union u mem_decs map.mem_decs in 265 | match map.shape with 266 | | Obj_cases cases -> decode_obj_case cases mem_miss mem_decs dict [] mems 267 | | Obj_basic u -> 268 | match u with 269 | | Unknown_skip -> decode_obj_basic u () mem_miss mem_decs dict mems 270 | | Unknown_error -> decode_obj_basic u () mem_miss mem_decs dict mems 271 | | Unknown_keep (map, _) -> 272 | decode_obj_basic u map.dec_empty mem_miss mem_decs dict mems 273 | 274 | and decode_obj_basic : type o map builder. 275 | (o, map, builder) unknown_mems -> builder -> mem_dec String_map.t -> 276 | mem_dec String_map.t -> Dict.t -> Json.obj -> Dict.t 277 | = 278 | fun u umap mem_miss mem_decs dict -> function 279 | | [] -> 280 | let dict = match u with 281 | | Unknown_skip | Unknown_error -> dict 282 | | Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish umap) dict 283 | in 284 | let add_default _ (Mem_dec m) dict = match m.dec_absent with 285 | | Some v -> Dict.add m.id v dict | None -> missing_member m.name 286 | in 287 | String_map.fold add_default mem_miss dict 288 | | (n, v) :: mems -> 289 | match String_map.find_opt n mem_decs with 290 | | Some (Mem_dec m) -> 291 | let dict = Dict.add m.id (decode m.type' v) dict in 292 | let mem_miss = String_map.remove n mem_miss in 293 | decode_obj_basic u umap mem_miss mem_decs dict mems 294 | | None -> 295 | match u with 296 | | Unknown_skip -> decode_obj_basic u umap mem_miss mem_decs dict mems 297 | | Unknown_error -> unexpected_member n 298 | | Unknown_keep (map, _) -> 299 | let umap = map.dec_add n (decode map.mems_type v) umap in 300 | decode_obj_basic u umap mem_miss mem_decs dict mems 301 | 302 | and decode_obj_case : type o cases tag. 303 | (o, cases, tag) obj_cases -> mem_dec String_map.t -> mem_dec String_map.t -> 304 | Dict.t -> Json.obj -> Json.obj -> Dict.t 305 | = 306 | fun cases mem_miss mem_decs dict delay mems -> 307 | let decode_case_tag tag = 308 | let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 309 | match List.find_opt eq_tag cases.cases with 310 | | None -> unknown_case_tag () 311 | | Some (Case case) -> 312 | let mems = List.rev_append delay mems in 313 | let dict = decode_obj_map case.obj_map mem_miss mem_decs dict mems in 314 | Dict.add cases.id (case.dec (apply_dict case.obj_map.dec dict)) dict 315 | in 316 | match mems with 317 | | [] -> 318 | (match cases.tag.dec_absent with 319 | | Some t -> decode_case_tag t | None -> missing_member cases.tag.name) 320 | | (n, v as mem) :: mems -> 321 | if n = cases.tag.name then decode_case_tag (decode cases.tag.type' v) else 322 | match String_map.find_opt n mem_decs with 323 | | None -> decode_obj_case cases mem_miss mem_decs dict (mem :: delay) mems 324 | | Some (Mem_dec m) -> 325 | let dict = Dict.add m.id (decode m.type' v) dict in 326 | let mem_miss = String_map.remove n mem_miss in 327 | decode_obj_case cases mem_miss mem_decs dict delay mems 328 | 329 | and decode_any : type a. a jsont -> a any_map -> Json.t -> a = 330 | fun t map j -> 331 | let dec t m j = match m with Some t -> decode t j | None -> type_error () in 332 | match j with 333 | | Json.Null _ -> dec t map.dec_null j 334 | | Json.Bool _ -> dec t map.dec_bool j 335 | | Json.Number _ -> dec t map.dec_number j 336 | | Json.String _ -> dec t map.dec_string j 337 | | Json.Array _ -> dec t map.dec_array j 338 | | Json.Obj _ -> dec t map.dec_obj j 339 | 340 | (* Encode *) 341 | 342 | let rec encode : type a. a jsont -> a -> Json.t = 343 | fun t v -> match t with 344 | | Null map -> Json.Null (map.enc v) 345 | | Bool map -> Json.Bool (map.enc v) 346 | | Number map -> Json.Number (map.enc v) 347 | | String map -> Json.String (map.enc v) 348 | | Array map -> 349 | let encode_elt a elt = (encode map.elt elt) :: a in 350 | Json.Array (List.rev (map.enc encode_elt [] v)) 351 | | Obj map -> Json.Obj (List.rev (encode_obj map v [])) 352 | | Any map -> encode (map.enc v) v 353 | | Map map -> encode map.dom (map.map.enc v) 354 | | Rec t -> encode (Lazy.force t) v 355 | 356 | and encode_obj : type o. (o, o) obj_map -> o -> Json.obj -> Json.obj = 357 | fun map o obj -> 358 | let encode_mem obj (Mem_enc map) = 359 | let v = map.enc o in 360 | if map.enc_omit v then obj else (map.name, encode map.type' v) :: obj 361 | in 362 | let obj = List.fold_left encode_mem obj map.mem_encs in 363 | match map.shape with 364 | | Obj_basic (Unknown_keep (map, enc)) -> 365 | let encode_mem n v obj = (n, encode map.mems_type v) :: obj in 366 | map.enc encode_mem (enc o) obj 367 | | Obj_basic _ -> obj 368 | | Obj_cases cases -> 369 | let Case_value (case, c) = cases.enc_case (cases.enc o) in 370 | let obj = 371 | if cases.tag.enc_omit case.tag then obj else 372 | (cases.tag.name, encode cases.tag.type' case.tag) :: obj 373 | in 374 | encode_obj case.obj_map c obj 375 | 376 | (* Object construction *) 377 | 378 | let obj_mem : 379 | string -> 'a jsont -> enc:('o -> 'a) -> 380 | ('o, 'a -> 'b) obj_map -> ('o, 'b) obj_map 381 | = 382 | fun name type' ~enc obj_map -> 383 | let id = Type.Id.make () in 384 | let dec_absent = None and enc_omit = Fun.const false in 385 | let mm = { name; type'; id; dec_absent; enc; enc_omit } in 386 | let dec = Dec_app (obj_map.dec, mm.id) in 387 | let mem_decs = String_map.add mm.name (Mem_dec mm) obj_map.mem_decs in 388 | let mem_encs = Mem_enc mm :: obj_map.mem_encs in 389 | { obj_map with dec; mem_decs; mem_encs; } 390 | 391 | let bool = Bool { dec = Fun.id; enc = Fun.id } 392 | let string = String { dec = Fun.id; enc = Fun.id } 393 | let obj_finish o = Obj { o with mem_encs = List.rev o.mem_encs } 394 | let obj_map : 'dec -> ('o, 'dec) obj_map = fun make -> 395 | let dec = Dec_fun make and shape = Obj_basic Unknown_skip in 396 | { dec; mem_decs = String_map.empty; mem_encs = []; shape } 397 | 398 | module Message = struct 399 | type t = { content : string; public : bool } 400 | let make content public = { content; public } 401 | let content msg = msg.content 402 | let public msg = msg.public 403 | let jsont : t jsont = 404 | obj_map make 405 | |> obj_mem "content" string ~enc:content 406 | |> obj_mem "public" bool ~enc:public 407 | |> obj_finish 408 | end 409 | 410 | (* Queries and updates *) 411 | 412 | type 'a query = 'a jsont 413 | let query : 'a query -> Json.t -> 'a = decode 414 | 415 | let get_mem : string -> 'a query -> 'a query = fun name q -> 416 | obj_map Fun.id |> obj_mem name q ~enc:Fun.id |> obj_finish 417 | 418 | let get_nth : int -> 'a query -> 'a query = fun nth q -> 419 | let dec_empty = None and dec_add _ _ v = Some v in 420 | let dec_skip _ k = nth <> k in 421 | let dec_finish = function None -> failwith "too short" | Some v -> v in 422 | let enc f acc v = f acc v (* Singleton array with the query result *) in 423 | Array { elt = q; dec_empty; dec_add; dec_skip; dec_finish; enc } 424 | 425 | let update_mem : string -> 'a jsont -> Json.t jsont = fun name q -> 426 | let dec = function 427 | | Json.Obj ms -> 428 | let update (n, v as m) = 429 | if n = name then (n, encode q (decode q v)) else m 430 | in 431 | Json.Obj (List.map update ms) 432 | | _ -> failwith "type error" 433 | in 434 | Map { dom = json; map = { dec; enc = Fun.id } } 435 | 436 | let delete_mem : string -> Json.t query = fun name -> 437 | let dec = function 438 | | Json.Obj ms -> Json.Obj (List.filter (fun (n, _) -> n <> name) ms) 439 | | _ -> type_error () 440 | in 441 | Map { dom = json; map = { dec; enc = Fun.id } } 442 | 443 | let const : 'a jsont -> 'a -> 'a jsont = fun t v -> 444 | let dec _ = v and enc _ = encode t v in 445 | Map { dom = json; map = { dec; enc } } 446 | 447 | (* Implementations not in the paper *) 448 | 449 | let map : ('a -> 'b) -> ('b -> 'a) -> 'a jsont -> 'b jsont = 450 | fun f g t -> Map { dom = t; map = { dec = f; enc = g }} 451 | 452 | let update_nth : int -> 'a jsont -> Json.t jsont = fun nth q -> 453 | let dec = function 454 | | Json.Array vs -> 455 | let update i v = if i = nth then encode q (decode q v) else v in 456 | Json.Array (List.mapi update vs) 457 | | _ -> failwith "type error" 458 | in 459 | Map { dom = json; map = { dec; enc = Fun.id } } 460 | 461 | let delete_nth : int -> Json.t query = fun nth -> 462 | let dec = function 463 | | Json.Array vs -> 464 | let add (i, acc) v = i + 1, (if i = nth then acc else v :: acc) in 465 | Json.Array (List.rev (snd (List.fold_left add (0, []) vs))) 466 | | _ -> type_error () 467 | in 468 | Map { dom = json; map = { dec; enc = Fun. id }} 469 | -------------------------------------------------------------------------------- /doc/cookbook.mld: -------------------------------------------------------------------------------- 1 | {0 [Jsont] cookbook} 2 | 3 | A few conventions and recipes to describe JSON data with 4 | {!Jsont}. 5 | 6 | {1:conventions Conventions} 7 | 8 | {2:naming Naming {!Jsont.t} values} 9 | 10 | Given an OCaml type [t] its JSON type value should be called 11 | [t_jsont]. If your type follows the [M.t] module convention use 12 | [M.jsont]. 13 | 14 | {1:tips General tips} 15 | 16 | Note that constructing {!Jsont.t} values has a cost. In particular 17 | when object descriptions are {!Jsont.Object.finish}ed a few checks are 18 | performed on the definition. Hence it's better to construct them as 19 | toplevel values or at least make sure you are not repeatedly 20 | constructing them dynamically in a tight loop. 21 | 22 | {2:general_erroring Erroring} 23 | 24 | Jsont types are full of your functions that you specify to implement 25 | the decoding and encoding process (e.g. base map decoding and encoding 26 | functions, object map constructors, object map member projectors, 27 | etc.). In general in any of these functions it is always safe to error 28 | by raising the {!Jsont.exception-Error} exception if you need to. 29 | 30 | Use the functions in the {!Jsont.module-Error} to format error 31 | messages. They usually require to specify a {!Jsont.Meta.t} value to 32 | precisely locate the error. If you have none to provide simply use 33 | {!Jsont.Meta.none}. 34 | 35 | {1:dealing_with_null Dealing with [null] values} 36 | 37 | Nullable JSON values are naturally mapped to ocaml [option] types. The 38 | {!Jsont.val-option} combinator does exactly that. 39 | 40 | It is also possible to map JSON [null]s to a default value with 41 | {!Jsont.null}. This can then be combined with {!Jsont.val-any} to compose 42 | with other JSON types. 43 | 44 | For example the following maps JSON [null]s to [""] and JSON strings 45 | to [string] on decoding. On encoding we unconditionally map back [""] 46 | to [null]: 47 | 48 | {[ 49 | let string_null_is_empty = 50 | let null = Jsont.null "" in 51 | let enc = function "" -> null | _ -> Jsont.string in 52 | Jsont.any ~dec_null:null ~dec_string:Jsont.string ~enc () 53 | ]} 54 | 55 | See also {!non_finite_numbers} and the tangentially related topic of 56 | {!optional_members}. 57 | 58 | {1:dealing_with_numbers Dealing with numbers} 59 | 60 | JSON is utterly broken to interchange numbers reliably as the standard 61 | provides no constraints on their representation. Generally interopable 62 | implementations, in particular the most widely deployed and formally 63 | specified ECMAScript implementation, use IEEE 754 [binary64] values to 64 | represent finite JSON numbers and [null] values to represent 65 | non-finite one. This has the following consequences. 66 | 67 | {2:integer_numbers Integer numbers} 68 | 69 | For representing integers by JSON numbers one is limited to the range 70 | \[-2{^53};2{^53}\] which are the only integers represented 71 | precisely in IEEE 754 [binary64]. If you want to serialize numbers 72 | beyond this range you need to represent them by a JSON string. These 73 | scheme can be seen in the wild: 74 | {ul 75 | {- Integers are unconditionally represented by strings. In this case 76 | {!Jsont.int_as_string} or {!Jsont.int64_as_string} can be used.} 77 | {- Integers are represented by numbers or strings depending on their 78 | magnitude. In this case {!Jsont.int} or {!Jsont.int64} 79 | can be used.} 80 | {- The integer range of interest can be fully represented in a JSON number. 81 | In this case {!Jsont.int8}, {!Jsont.uint8}, {!Jsont.int16}, etc. can be 82 | used.}} 83 | 84 | {2:non_finite_numbers Non-finite numbers} 85 | 86 | JSON numbers cannot represent IEEE 754 [binary64] numbers: infinities 87 | and NaNs cannot be represented. The formally defined 88 | {{:https://tc39.es/ecma262/multipage/structured-data.html#sec-serializejsonproperty}ECMAScript's 89 | [JSON.stringify]} function replaces these values by [null]. 90 | 91 | For this reason in [Jsont] the domain of {!Jsont.Base.number} maps is 92 | JSON numbers {e or JSON null}. In the decoding direction a null is 93 | mapped to {!Float.nan} and in the encoding direction any float not 94 | satisfying {!Float.is_finite} is mapped to a JSON null. 95 | 96 | If you can agree with a third party on a better encoding, the 97 | {!Jsont.any_float} or {!Jsont.float_as_hex_string} provide 98 | lossless representations of IEEE 754 [binary64] values in JSON. 99 | 100 | {1:base_types Transforming base types} 101 | 102 | The {!Jsont.map} combinator is a general map over {!Jsont.t} types. 103 | It should rather be used to alter the representation of existing 104 | {!Jsont.t} values. For transforming base types it is better to use the 105 | base maps of {!Jsont.Base} as more context is made available to the 106 | functions, notably when erroring. 107 | 108 | {2:transform_strings Transforming strings} 109 | 110 | A few simple JSON string transformers like {!Jsont.enum} or 111 | {!Jsont.binary_string} are provided. 112 | 113 | If you need to devise your own maps from your own [M.{of,to}_string] 114 | functions that return [result] or raise [Faiulre _] you can adapt them 115 | with {{!Jsont.Base.decenc}these functions}. For example: 116 | {[ 117 | let m_jsont = 118 | let dec = Jsont.Base.dec_result M.result_of_string in 119 | let enc = Jsont.Base.enc M.to_string in 120 | Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ()) 121 | 122 | let m_jsont' = 123 | let dec = Jsont.Base.dec_failure M.of_string_or_failure in 124 | let enc = Jsont.Base.enc M.to_string in 125 | Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ()) 126 | ]} 127 | 128 | If you are dealing with result decoders you can also simply 129 | use {!Jsont.of_of_string}: 130 | 131 | {[ 132 | let m_jsont'' = 133 | Jsont.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string 134 | ]} 135 | 136 | which is a shortcut for the [m_jsont] written above. 137 | 138 | {1:dealing_with_arrays Dealing with arrays} 139 | 140 | JSON arrays can be directly mapped to OCaml {{!Jsont.list}lists}, 141 | {{!Jsont.array}arrays}, {{!Jsont.bigarray}bigarray} or bespoke 142 | low-dimensional {{!Jsont.t2}tuples}. If your JSON is an array of 143 | objects keyed by some identifier you may find 144 | {!Jsont.array_as_string_map} handy. 145 | 146 | If none of that fits you can always devise your own {!Jsont.Array.val-map}. 147 | 148 | {1:dealing_with_objects Dealing with objects} 149 | 150 | {2:objects_as_records Objects as records} 151 | 152 | Suppose our JSON object is: 153 | 154 | {@json[ 155 | { "name": "Jane Doe" 156 | "age": 56 } 157 | ]} 158 | 159 | We represent it with an OCaml record as follows: 160 | 161 | {[ 162 | module Person = struct 163 | type t = { name : string; age : int } 164 | let make name age = { name; age } 165 | let name p = p.name 166 | let age p = p.age 167 | let jsont = 168 | Jsont.Object.map ~kind:"Person" make 169 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 170 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 171 | |> Jsont.Object.finish 172 | end 173 | ]} 174 | 175 | {2:objects_as_maps Objects as key-value maps} 176 | 177 | JSON objects can be used as maps from strings to a single type 178 | of value ({{:https://github.com/topojson/topojson-specification/blob/7939fe0834f36af8b935ec1827cb0abdd1e34d36/README.md#215-objects}example}). 179 | Such maps can be easily converted to OCaml as follows: 180 | 181 | {[ 182 | module String_map = Map.Make (String) 183 | 184 | let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t = 185 | fun ?kind t -> 186 | Jsont.Object.map ?kind Fun.id 187 | |> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id 188 | |> Jsont.Object.finish 189 | ]} 190 | 191 | Since the pattern is common this is directly exposed as 192 | {!Jsont.Object.as_string_map}. 193 | 194 | {2:optional_members Optional members} 195 | 196 | By default members specified via {!Jsont.Object.mem} are mandatory and 197 | decoding errors if the member is absent. 198 | 199 | For those cases where the member is optional a default [dec_absent] value must 200 | be specified to use on decoding when absent. For encoding an 201 | [enc_omit] function can be specified to determine whether the member 202 | should be omitted on encoding. 203 | 204 | In the following example we use an option type to denote the potential 205 | absence of the [age] member: 206 | 207 | {[ 208 | module Person_opt_age = struct 209 | type t = { name : string; age : int option } 210 | let make name age = { name; age } 211 | let name p = p.name 212 | let age p = p.age 213 | let jsont = 214 | Jsont.Object.map ~kind:"Person" make 215 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 216 | |> Jsont.Object.mem "age" Jsont.(some int) 217 | ~dec_absent:None ~enc_omit:Option.is_none ~enc:age 218 | |> Jsont.Object.finish 219 | end 220 | ]} 221 | 222 | When absence is represented by [None] like here the 223 | {!Jsont.Object.opt_mem} function can be used. It's stricly equivalent to 224 | the above but more concise. 225 | 226 | {2:unknown_members Unknown object members} 227 | 228 | In JSON objects maps, there are three different ways to handle 229 | object members that have not been declared by a {!Jsont.Object.mem} 230 | or {!Jsont.Object.opt_mem}. 231 | 232 | {3:skipping Skipping} 233 | 234 | By default {!Jsont.Object.val-map} skips unknown object members. 235 | 236 | {3:erroring Erroring} 237 | 238 | To error on unknown members use {!Jsont.Object.val-error_unknown}: 239 | {[ 240 | module Person_strict = struct 241 | type t = { name : string; age : int; } 242 | let make name age = { name; age } 243 | let name p = p.name 244 | let age p = p.age 245 | let jsont = 246 | Jsont.Object.map ~kind:"Person" make 247 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 248 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 249 | |> Jsont.Object.error_unknown 250 | |> Jsont.Object.finish 251 | end 252 | ]} 253 | 254 | {3:keeping Keeping} 255 | 256 | If a JSON data schema allows foreign members or to partially model an 257 | object, unknown members can be collected into a generic 258 | {!Jsont.Json.t} object and stored in an OCaml field by using 259 | {!Jsont.Object.keep_unknown} and {!Jsont.json_mems}: 260 | 261 | {[ 262 | module Person_keep = struct 263 | type t = { name : string; age : int; unknown : Jsont.json ; } 264 | let make name age unknown = { name; age; unknown } 265 | let name p = p.name 266 | let age p = p.age 267 | let unknown v = v.unknown 268 | let jsont = 269 | Jsont.Object.map ~kind:"Person" make 270 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 271 | |> Jsont.Object.mem "age" Jsont.int ~enc:age 272 | |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 273 | |> Jsont.Object.finish 274 | end 275 | ]} 276 | 277 | The value of the [unknown] field can be further queried with other 278 | JSON types and {!Jsont.Json.val-decode}. It is also possible to define 279 | your own data structure to keep unknown members, see 280 | {!Jsont.Object.Mems}. See also {!objects_as_maps}. 281 | 282 | {2:cases Object types or classes} 283 | 284 | Sometimes JSON objects have a distinguished case member, called 285 | ["type"], ["class"] or ["version"] whose value define the rest of the 286 | object. 287 | 288 | The {!Jsont.Object.Case} module handles this pattern. Each case is 289 | described by a {!Jsont.Object.type-map} object description and the 290 | {!Jsont.Object.case_mem} allows to chose between them according to the 291 | value of the case member. 292 | 293 | In OCaml there are two main ways to represent these case objects. 294 | Either by an enclosing variant type with one case for each object kind: 295 | {[ 296 | type t = C1 of C1.t | C2 of C2.t | … 297 | ]} 298 | or with a record which holds common fields an a field that holds the cases: 299 | {[ 300 | type type' = C1 of C1.t | C2 of C2.t | … 301 | type t = { type' : type'; … (* other common fields *) } 302 | ]} 303 | From {!Jsont}'s perspective there is not much difference. 304 | 305 | We show both modellings on a hypothetic [Geometry] object which has a 306 | ["name"] member and a ["type"] string case member indicating whether 307 | the object is a ["Circle"] or a ["Rect"]. Except for the position of 308 | the [name] field, not much changes in each modelling. 309 | 310 | Using an enclosing variant type: 311 | 312 | {[ 313 | module Geometry_variant = struct 314 | module Circle = struct 315 | type t = { name : string; radius : float; } 316 | let make name radius = { name; radius } 317 | let name c = c.name 318 | let radius c = c.radius 319 | let jsont = 320 | Jsont.Object.map ~kind:"Circle" make 321 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 322 | |> Jsont.Object.mem "radius" Jsont.number ~enc:radius 323 | |> Jsont.Object.finish 324 | end 325 | 326 | module Rect = struct 327 | type t = { name : string; width : float; height : float } 328 | let make name width height = { name; width; height } 329 | let name r = r.name 330 | let width r = r.width 331 | let height r = r.height 332 | let jsont = 333 | Jsont.Object.map ~kind:"Rect" make 334 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 335 | |> Jsont.Object.mem "width" Jsont.number ~enc:width 336 | |> Jsont.Object.mem "height" Jsont.number ~enc:height 337 | |> Jsont.Object.finish 338 | end 339 | 340 | type t = Circle of Circle.t | Rect of Rect.t 341 | let circle c = Circle c 342 | let rect r = Rect r 343 | let jsont = 344 | let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in 345 | let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in 346 | let enc_case = function 347 | | Circle c -> Jsont.Object.Case.value circle c 348 | | Rect r -> Jsont.Object.Case.value rect r 349 | in 350 | let cases = Jsont.Object.Case.[make circle; make rect] in 351 | Jsont.Object.map ~kind:"Geometry" Fun.id 352 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 353 | |> Jsont.Object.finish 354 | end 355 | ]} 356 | 357 | Using a record with a [type'] field: 358 | 359 | {[ 360 | module Geometry_record = struct 361 | module Circle = struct 362 | type t = { radius : float; } 363 | let make radius = { radius } 364 | let radius c = c.radius 365 | let jsont = 366 | Jsont.Object.map ~kind:"Circle" make 367 | |> Jsont.Object.mem "radius" Jsont.number ~enc:radius 368 | |> Jsont.Object.finish 369 | end 370 | 371 | module Rect = struct 372 | type t = { width : float; height : float } 373 | let make width height = { width; height } 374 | let width r = r.width 375 | let height r = r.height 376 | let jsont = 377 | Jsont.Object.map ~kind:"Rect" make 378 | |> Jsont.Object.mem "width" Jsont.number ~enc:width 379 | |> Jsont.Object.mem "height" Jsont.number ~enc:height 380 | |> Jsont.Object.finish 381 | end 382 | 383 | type type' = Circle of Circle.t | Rect of Rect.t 384 | let circle c = Circle c 385 | let rect r = Rect r 386 | 387 | type t = { name : string; type' : type' } 388 | let make name type' = { name; type' } 389 | let name g = g.name 390 | let type' g = g.type' 391 | 392 | let jsont = 393 | let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in 394 | let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in 395 | let enc_case = function 396 | | Circle c -> Jsont.Object.Case.value circle c 397 | | Rect r -> Jsont.Object.Case.value rect r 398 | in 399 | let cases = Jsont.Object.Case.[make circle; make rect] in 400 | Jsont.Object.map ~kind:"Geometry" make 401 | |> Jsont.Object.mem "name" Jsont.string ~enc:name 402 | |> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases 403 | |> Jsont.Object.finish 404 | end 405 | ]} 406 | 407 | {2:cases_untagged Untagged object types} 408 | 409 | Sometimes objects types are not determined by a specific {{!cases}case 410 | member} but rather by the presence or absence of certain members. In 411 | this case the easiest is to make object members optional with 412 | {!Jsont.Object.opt_mem} and sort out their presence and absence 413 | manually in the decoding function given to {!Jsont.Object.val-map}. 414 | 415 | For example a response message that has always an [id] member and a 416 | [result] member in case of success and an mutually exclusive [error] 417 | member in case of error can be modelled as follows: 418 | {[ 419 | module Response = struct 420 | type t = 421 | { id : int; 422 | value : (Jsont.json, string) result } 423 | 424 | let make id result error = 425 | let pp_mem = Jsont.Repr.pp_code in 426 | match result, error with 427 | | Some result, None -> { id; value = Ok result } 428 | | None, Some error -> { id; value = Error error } 429 | | Some _ , Some _ -> 430 | Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined" 431 | pp_mem "result" pp_mem "error" 432 | | None, None -> 433 | Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" 434 | pp_mem "result" pp_mem "error" 435 | 436 | let result r = match r.value with Ok v -> Some v | Error _ -> None 437 | let error r = match r.value with Ok _ -> None | Error e -> Some e 438 | 439 | let jsont = 440 | Jsont.Object.map make 441 | |> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id) 442 | |> Jsont.Object.opt_mem "result" Jsont.json ~enc:result 443 | |> Jsont.Object.opt_mem "error" Jsont.string ~enc:error 444 | |> Jsont.Object.finish 445 | end 446 | ]} 447 | 448 | A {{:https://www.jsonrpc.org/specification#response_object}JSON-RPC 449 | response object} has such a structure. A full modelling of the data 450 | JSON-RPC data format with [Jsont] can be found 451 | {{:https://erratique.ch/repos/jsont/tree/test/json_rpc.ml}here}. 452 | 453 | {2:flattening Flattening nested objects} 454 | 455 | If you are only interested in extracting data it may be useful to 456 | flatten some objects whose members are too nested for your needs. 457 | 458 | For that just remember that nothing says that JSON objects 459 | cannot be mapped to OCaml functions. For examples to gather this kind 460 | of data for a group of person into a single record: 461 | 462 | {@json[ 463 | { 464 | "info" : { "id" : 1, "name": "untitled" } 465 | "persons" : [ … ] 466 | } 467 | ]} 468 | 469 | You can use the following structure: 470 | 471 | {[ 472 | module Group = struct 473 | type t = { id : int; name : string; persons : Person.t list } 474 | let make id name persons = { id; name; persons } 475 | 476 | let info_jsont = 477 | Jsont.Object.map make 478 | |> Jsont.Object.mem "id" Jsont.int 479 | |> Jsont.Object.mem "name" Jsont.string 480 | |> Jsont.Object.finish 481 | 482 | let jsont = 483 | Jsont.Object.map (fun k persons -> k persons) 484 | |> Jsont.Object.mem "info" info_jsont 485 | |> Jsont.Object.mem "persons" (Jsont.list Person.jsont) 486 | |> Jsont.Object.finish 487 | end 488 | ]} 489 | 490 | This however will not allow you to use [jsont] to encode. If you wish 491 | to do so it's likely better to follow the JSON structure and hide the 492 | annoying access structure under an abstract type behind a nice API. 493 | 494 | {1:recursion Dealing with recursive JSON} 495 | 496 | To describe recursive JSON values you need to define your description 497 | in a [lazy] expression and use {!Jsont.rec'} to refer to the value 498 | you are defining. This results in the following structure: 499 | 500 | {[ 501 | let jsont : t Jsont.t = 502 | let rec t = lazy ( … Jsont.rec' t … ) in 503 | Lazy.force t 504 | ]} 505 | 506 | For example a tree encoded as a JSON object with: 507 | {@json[ 508 | { "value": …, 509 | "children": […] } 510 | ]} 511 | 512 | Is modelled by: 513 | 514 | {[ 515 | module Tree = struct 516 | type 'a t = Node of 'a * 'a t list 517 | let make v children = Node (v, children) 518 | let value (Node (v, _)) = v 519 | let children (Node (_, children)) = children 520 | let jsont value_type = 521 | let rec t = lazy 522 | (Jsont.Object.map ~kind:"Tree" make 523 | |> Jsont.Object.mem "value" value_type ~enc:value 524 | |> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children 525 | |> Jsont.Object.finish) 526 | in 527 | Lazy.force t 528 | end 529 | ]} 530 | 531 | The 532 | {{:https://erratique.ch/repos/jsont/tree/test/topojson.ml}[topojson.ml]} 533 | and 534 | {{:https://erratique.ch/repos/jsont/tree/test/geojson.ml}[geojson.ml]} 535 | examples in the source repository provide more extensive examples of 536 | recursive definition. --------------------------------------------------------------------------------