├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── ocplib-json-typed-browser.opam ├── ocplib-json-typed-bson.opam ├── ocplib-json-typed.opam └── src ├── dune ├── json_encoding.ml ├── json_encoding.mli ├── json_query.ml ├── json_query.mli ├── json_repr.ml ├── json_repr.mli ├── json_repr_browser.ml ├── json_repr_browser.mli ├── json_repr_bson.ml ├── json_repr_bson.mli ├── json_schema.ml └── json_schema.mli /.gitignore: -------------------------------------------------------------------------------- 1 | # jbuilder working directory 2 | _build/ 3 | 4 | **.merlin 5 | *.install 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - PACKAGE="ocplib-json-typed" OCAML_VERSION="4.03" DEPOPTS="js_of_ocaml ocplib-endian" 7 | - PACKAGE="ocplib-json-typed" OCAML_VERSION="4.04" DEPOPTS="js_of_ocaml ocplib-endian" 8 | - PACKAGE="ocplib-json-typed" OCAML_VERSION="4.06" DEPOPTS="js_of_ocaml ocplib-endian" 9 | - PACKAGE="ocplib-json-typed" OCAML_VERSION="4.07" DEPOPTS="js_of_ocaml ocplib-endian" 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | As a special exception to the GNU Lesser General Public License, you 2 | may link, statically or dynamically, a "work that uses the Library" 3 | with a publicly distributed version of the Library to produce an 4 | executable file containing portions of the Library, and distribute 5 | that executable file under terms of your choice, without any of the 6 | additional requirements listed in clause 6 of the GNU Library General 7 | Public License. By "a publicly distributed version of the Library", 8 | we mean either the unmodified Library as distributed by the copyright 9 | holder, or a modified version of the Library that is distributed under 10 | the conditions defined in clause 3 of the GNU Library General Public 11 | License. This exception does not however invalidate any other reasons 12 | why the executable file might be covered by the GNU Lesser General 13 | Public License. 14 | 15 | 16 | GNU LESSER GENERAL PUBLIC LICENSE 17 | Version 3, 29 June 2007 18 | 19 | Copyright (C) 2007 Free Software Foundation, Inc. 20 | Everyone is permitted to copy and distribute verbatim copies 21 | of this license document, but changing it is not allowed. 22 | 23 | 24 | This version of the GNU Lesser General Public License incorporates 25 | the terms and conditions of version 3 of the GNU General Public 26 | License, supplemented by the additional permissions listed below. 27 | 28 | 0. Additional Definitions. 29 | 30 | As used herein, "this License" refers to version 3 of the GNU Lesser 31 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 32 | General Public License. 33 | 34 | "The Library" refers to a covered work governed by this License, 35 | other than an Application or a Combined Work as defined below. 36 | 37 | An "Application" is any work that makes use of an interface provided 38 | by the Library, but which is not otherwise based on the Library. 39 | Defining a subclass of a class defined by the Library is deemed a mode 40 | of using an interface provided by the Library. 41 | 42 | A "Combined Work" is a work produced by combining or linking an 43 | Application with the Library. The particular version of the Library 44 | with which the Combined Work was made is also called the "Linked 45 | Version". 46 | 47 | The "Minimal Corresponding Source" for a Combined Work means the 48 | Corresponding Source for the Combined Work, excluding any source code 49 | for portions of the Combined Work that, considered in isolation, are 50 | based on the Application, and not on the Linked Version. 51 | 52 | The "Corresponding Application Code" for a Combined Work means the 53 | object code and/or source code for the Application, including any data 54 | and utility programs needed for reproducing the Combined Work from the 55 | Application, but excluding the System Libraries of the Combined Work. 56 | 57 | 1. Exception to Section 3 of the GNU GPL. 58 | 59 | You may convey a covered work under sections 3 and 4 of this License 60 | without being bound by section 3 of the GNU GPL. 61 | 62 | 2. Conveying Modified Versions. 63 | 64 | If you modify a copy of the Library, and, in your modifications, a 65 | facility refers to a function or data to be supplied by an Application 66 | that uses the facility (other than as an argument passed when the 67 | facility is invoked), then you may convey a copy of the modified 68 | version: 69 | 70 | a) under this License, provided that you make a good faith effort to 71 | ensure that, in the event an Application does not supply the 72 | function or data, the facility still operates, and performs 73 | whatever part of its purpose remains meaningful, or 74 | 75 | b) under the GNU GPL, with none of the additional permissions of 76 | this License applicable to that copy. 77 | 78 | 3. Object Code Incorporating Material from Library Header Files. 79 | 80 | The object code form of an Application may incorporate material from 81 | a header file that is part of the Library. You may convey such object 82 | code under terms of your choice, provided that, if the incorporated 83 | material is not limited to numerical parameters, data structure 84 | layouts and accessors, or small macros, inline functions and templates 85 | (ten or fewer lines in length), you do both of the following: 86 | 87 | a) Give prominent notice with each copy of the object code that the 88 | Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the object code with a copy of the GNU GPL and this license 92 | document. 93 | 94 | 4. Combined Works. 95 | 96 | You may convey a Combined Work under terms of your choice that, 97 | taken together, effectively do not restrict modification of the 98 | portions of the Library contained in the Combined Work and reverse 99 | engineering for debugging such modifications, if you also do each of 100 | the following: 101 | 102 | a) Give prominent notice with each copy of the Combined Work that 103 | the Library is used in it and that the Library and its use are 104 | covered by this License. 105 | 106 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 107 | document. 108 | 109 | c) For a Combined Work that displays copyright notices during 110 | execution, include the copyright notice for the Library among 111 | these notices, as well as a reference directing the user to the 112 | copies of the GNU GPL and this license document. 113 | 114 | d) Do one of the following: 115 | 116 | 0) Convey the Minimal Corresponding Source under the terms of this 117 | License, and the Corresponding Application Code in a form 118 | suitable for, and under terms that permit, the user to 119 | recombine or relink the Application with a modified version of 120 | the Linked Version to produce a modified Combined Work, in the 121 | manner specified by section 6 of the GNU GPL for conveying 122 | Corresponding Source. 123 | 124 | 1) Use a suitable shared library mechanism for linking with the 125 | Library. A suitable mechanism is one that (a) uses at run time 126 | a copy of the Library already present on the user's computer 127 | system, and (b) will operate properly with a modified version 128 | of the Library that is interface-compatible with the Linked 129 | Version. 130 | 131 | e) Provide Installation Information, but only if you would otherwise 132 | be required to provide such information under section 6 of the 133 | GNU GPL, and only to the extent that such information is 134 | necessary to install and execute a modified version of the 135 | Combined Work produced by recombining or relinking the 136 | Application with a modified version of the Linked Version. (If 137 | you use option 4d0, the Installation Information must accompany 138 | the Minimal Corresponding Source and Corresponding Application 139 | Code. If you use option 4d1, you must provide the Installation 140 | Information in the manner specified by section 6 of the GNU GPL 141 | for conveying Corresponding Source.) 142 | 143 | 5. Combined Libraries. 144 | 145 | You may place library facilities that are a work based on the 146 | Library side by side in a single library together with other library 147 | facilities that are not Applications and are not covered by this 148 | License, and convey such a combined library under terms of your 149 | choice, if you do both of the following: 150 | 151 | a) Accompany the combined library with a copy of the same work based 152 | on the Library, uncombined with any other library facilities, 153 | conveyed under the terms of this License. 154 | 155 | b) Give prominent notice with the combined library that part of it 156 | is a work based on the Library, and explaining where to find the 157 | accompanying uncombined form of the same work. 158 | 159 | 6. Revised Versions of the GNU Lesser General Public License. 160 | 161 | The Free Software Foundation may publish revised and/or new versions 162 | of the GNU Lesser General Public License from time to time. Such new 163 | versions will be similar in spirit to the present version, but may 164 | differ in detail to address new problems or concerns. 165 | 166 | Each version is given a distinguishing version number. If the 167 | Library as you received it specifies that a certain numbered version 168 | of the GNU Lesser General Public License "or any later version" 169 | applies to it, you have the option of following the terms and 170 | conditions either of that published version or of any later version 171 | published by the Free Software Foundation. If the Library as you 172 | received it does not specify a version number of the GNU Lesser 173 | General Public License, you may choose any version of the GNU Lesser 174 | General Public License ever published by the Free Software Foundation. 175 | 176 | If the Library as you received it specifies that a proxy can decide 177 | whether future versions of the GNU Lesser General Public License shall 178 | apply, that proxy's public statement of acceptance of any version is 179 | permanent authorization for you to choose that version for the 180 | Library. 181 | 182 | 183 | ------------------------------------------------------------------------ 184 | 185 | 186 | GNU GENERAL PUBLIC LICENSE 187 | Version 3, 29 June 2007 188 | 189 | Copyright (C) 2007 Free Software Foundation, Inc. 190 | Everyone is permitted to copy and distribute verbatim copies 191 | of this license document, but changing it is not allowed. 192 | 193 | Preamble 194 | 195 | The GNU General Public License is a free, copyleft license for 196 | software and other kinds of works. 197 | 198 | The licenses for most software and other practical works are designed 199 | to take away your freedom to share and change the works. By contrast, 200 | the GNU General Public License is intended to guarantee your freedom to 201 | share and change all versions of a program--to make sure it remains free 202 | software for all its users. We, the Free Software Foundation, use the 203 | GNU General Public License for most of our software; it applies also to 204 | any other work released this way by its authors. You can apply it to 205 | your programs, too. 206 | 207 | When we speak of free software, we are referring to freedom, not 208 | price. Our General Public Licenses are designed to make sure that you 209 | have the freedom to distribute copies of free software (and charge for 210 | them if you wish), that you receive source code or can get it if you 211 | want it, that you can change the software or use pieces of it in new 212 | free programs, and that you know you can do these things. 213 | 214 | To protect your rights, we need to prevent others from denying you 215 | these rights or asking you to surrender the rights. Therefore, you have 216 | certain responsibilities if you distribute copies of the software, or if 217 | you modify it: responsibilities to respect the freedom of others. 218 | 219 | For example, if you distribute copies of such a program, whether 220 | gratis or for a fee, you must pass on to the recipients the same 221 | freedoms that you received. You must make sure that they, too, receive 222 | or can get the source code. And you must show them these terms so they 223 | know their rights. 224 | 225 | Developers that use the GNU GPL protect your rights with two steps: 226 | (1) assert copyright on the software, and (2) offer you this License 227 | giving you legal permission to copy, distribute and/or modify it. 228 | 229 | For the developers' and authors' protection, the GPL clearly explains 230 | that there is no warranty for this free software. For both users' and 231 | authors' sake, the GPL requires that modified versions be marked as 232 | changed, so that their problems will not be attributed erroneously to 233 | authors of previous versions. 234 | 235 | Some devices are designed to deny users access to install or run 236 | modified versions of the software inside them, although the manufacturer 237 | can do so. This is fundamentally incompatible with the aim of 238 | protecting users' freedom to change the software. The systematic 239 | pattern of such abuse occurs in the area of products for individuals to 240 | use, which is precisely where it is most unacceptable. Therefore, we 241 | have designed this version of the GPL to prohibit the practice for those 242 | products. If such problems arise substantially in other domains, we 243 | stand ready to extend this provision to those domains in future versions 244 | of the GPL, as needed to protect the freedom of users. 245 | 246 | Finally, every program is threatened constantly by software patents. 247 | States should not allow patents to restrict development and use of 248 | software on general-purpose computers, but in those that do, we wish to 249 | avoid the special danger that patents applied to a free program could 250 | make it effectively proprietary. To prevent this, the GPL assures that 251 | patents cannot be used to render the program non-free. 252 | 253 | The precise terms and conditions for copying, distribution and 254 | modification follow. 255 | 256 | TERMS AND CONDITIONS 257 | 258 | 0. Definitions. 259 | 260 | "This License" refers to version 3 of the GNU General Public License. 261 | 262 | "Copyright" also means copyright-like laws that apply to other kinds of 263 | works, such as semiconductor masks. 264 | 265 | "The Program" refers to any copyrightable work licensed under this 266 | License. Each licensee is addressed as "you". "Licensees" and 267 | "recipients" may be individuals or organizations. 268 | 269 | To "modify" a work means to copy from or adapt all or part of the work 270 | in a fashion requiring copyright permission, other than the making of an 271 | exact copy. The resulting work is called a "modified version" of the 272 | earlier work or a work "based on" the earlier work. 273 | 274 | A "covered work" means either the unmodified Program or a work based 275 | on the Program. 276 | 277 | To "propagate" a work means to do anything with it that, without 278 | permission, would make you directly or secondarily liable for 279 | infringement under applicable copyright law, except executing it on a 280 | computer or modifying a private copy. Propagation includes copying, 281 | distribution (with or without modification), making available to the 282 | public, and in some countries other activities as well. 283 | 284 | To "convey" a work means any kind of propagation that enables other 285 | parties to make or receive copies. Mere interaction with a user through 286 | a computer network, with no transfer of a copy, is not conveying. 287 | 288 | An interactive user interface displays "Appropriate Legal Notices" 289 | to the extent that it includes a convenient and prominently visible 290 | feature that (1) displays an appropriate copyright notice, and (2) 291 | tells the user that there is no warranty for the work (except to the 292 | extent that warranties are provided), that licensees may convey the 293 | work under this License, and how to view a copy of this License. If 294 | the interface presents a list of user commands or options, such as a 295 | menu, a prominent item in the list meets this criterion. 296 | 297 | 1. Source Code. 298 | 299 | The "source code" for a work means the preferred form of the work 300 | for making modifications to it. "Object code" means any non-source 301 | form of a work. 302 | 303 | A "Standard Interface" means an interface that either is an official 304 | standard defined by a recognized standards body, or, in the case of 305 | interfaces specified for a particular programming language, one that 306 | is widely used among developers working in that language. 307 | 308 | The "System Libraries" of an executable work include anything, other 309 | than the work as a whole, that (a) is included in the normal form of 310 | packaging a Major Component, but which is not part of that Major 311 | Component, and (b) serves only to enable use of the work with that 312 | Major Component, or to implement a Standard Interface for which an 313 | implementation is available to the public in source code form. A 314 | "Major Component", in this context, means a major essential component 315 | (kernel, window system, and so on) of the specific operating system 316 | (if any) on which the executable work runs, or a compiler used to 317 | produce the work, or an object code interpreter used to run it. 318 | 319 | The "Corresponding Source" for a work in object code form means all 320 | the source code needed to generate, install, and (for an executable 321 | work) run the object code and to modify the work, including scripts to 322 | control those activities. However, it does not include the work's 323 | System Libraries, or general-purpose tools or generally available free 324 | programs which are used unmodified in performing those activities but 325 | which are not part of the work. For example, Corresponding Source 326 | includes interface definition files associated with source files for 327 | the work, and the source code for shared libraries and dynamically 328 | linked subprograms that the work is specifically designed to require, 329 | such as by intimate data communication or control flow between those 330 | subprograms and other parts of the work. 331 | 332 | The Corresponding Source need not include anything that users 333 | can regenerate automatically from other parts of the Corresponding 334 | Source. 335 | 336 | The Corresponding Source for a work in source code form is that 337 | same work. 338 | 339 | 2. Basic Permissions. 340 | 341 | All rights granted under this License are granted for the term of 342 | copyright on the Program, and are irrevocable provided the stated 343 | conditions are met. This License explicitly affirms your unlimited 344 | permission to run the unmodified Program. The output from running a 345 | covered work is covered by this License only if the output, given its 346 | content, constitutes a covered work. This License acknowledges your 347 | rights of fair use or other equivalent, as provided by copyright law. 348 | 349 | You may make, run and propagate covered works that you do not 350 | convey, without conditions so long as your license otherwise remains 351 | in force. You may convey covered works to others for the sole purpose 352 | of having them make modifications exclusively for you, or provide you 353 | with facilities for running those works, provided that you comply with 354 | the terms of this License in conveying all material for which you do 355 | not control copyright. Those thus making or running the covered works 356 | for you must do so exclusively on your behalf, under your direction 357 | and control, on terms that prohibit them from making any copies of 358 | your copyrighted material outside their relationship with you. 359 | 360 | Conveying under any other circumstances is permitted solely under 361 | the conditions stated below. Sublicensing is not allowed; section 10 362 | makes it unnecessary. 363 | 364 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 365 | 366 | No covered work shall be deemed part of an effective technological 367 | measure under any applicable law fulfilling obligations under article 368 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 369 | similar laws prohibiting or restricting circumvention of such 370 | measures. 371 | 372 | When you convey a covered work, you waive any legal power to forbid 373 | circumvention of technological measures to the extent such circumvention 374 | is effected by exercising rights under this License with respect to 375 | the covered work, and you disclaim any intention to limit operation or 376 | modification of the work as a means of enforcing, against the work's 377 | users, your or third parties' legal rights to forbid circumvention of 378 | technological measures. 379 | 380 | 4. Conveying Verbatim Copies. 381 | 382 | You may convey verbatim copies of the Program's source code as you 383 | receive it, in any medium, provided that you conspicuously and 384 | appropriately publish on each copy an appropriate copyright notice; 385 | keep intact all notices stating that this License and any 386 | non-permissive terms added in accord with section 7 apply to the code; 387 | keep intact all notices of the absence of any warranty; and give all 388 | recipients a copy of this License along with the Program. 389 | 390 | You may charge any price or no price for each copy that you convey, 391 | and you may offer support or warranty protection for a fee. 392 | 393 | 5. Conveying Modified Source Versions. 394 | 395 | You may convey a work based on the Program, or the modifications to 396 | produce it from the Program, in the form of source code under the 397 | terms of section 4, provided that you also meet all of these conditions: 398 | 399 | a) The work must carry prominent notices stating that you modified 400 | it, and giving a relevant date. 401 | 402 | b) The work must carry prominent notices stating that it is 403 | released under this License and any conditions added under section 404 | 7. This requirement modifies the requirement in section 4 to 405 | "keep intact all notices". 406 | 407 | c) You must license the entire work, as a whole, under this 408 | License to anyone who comes into possession of a copy. This 409 | License will therefore apply, along with any applicable section 7 410 | additional terms, to the whole of the work, and all its parts, 411 | regardless of how they are packaged. This License gives no 412 | permission to license the work in any other way, but it does not 413 | invalidate such permission if you have separately received it. 414 | 415 | d) If the work has interactive user interfaces, each must display 416 | Appropriate Legal Notices; however, if the Program has interactive 417 | interfaces that do not display Appropriate Legal Notices, your 418 | work need not make them do so. 419 | 420 | A compilation of a covered work with other separate and independent 421 | works, which are not by their nature extensions of the covered work, 422 | and which are not combined with it such as to form a larger program, 423 | in or on a volume of a storage or distribution medium, is called an 424 | "aggregate" if the compilation and its resulting copyright are not 425 | used to limit the access or legal rights of the compilation's users 426 | beyond what the individual works permit. Inclusion of a covered work 427 | in an aggregate does not cause this License to apply to the other 428 | parts of the aggregate. 429 | 430 | 6. Conveying Non-Source Forms. 431 | 432 | You may convey a covered work in object code form under the terms 433 | of sections 4 and 5, provided that you also convey the 434 | machine-readable Corresponding Source under the terms of this License, 435 | in one of these ways: 436 | 437 | a) Convey the object code in, or embodied in, a physical product 438 | (including a physical distribution medium), accompanied by the 439 | Corresponding Source fixed on a durable physical medium 440 | customarily used for software interchange. 441 | 442 | b) Convey the object code in, or embodied in, a physical product 443 | (including a physical distribution medium), accompanied by a 444 | written offer, valid for at least three years and valid for as 445 | long as you offer spare parts or customer support for that product 446 | model, to give anyone who possesses the object code either (1) a 447 | copy of the Corresponding Source for all the software in the 448 | product that is covered by this License, on a durable physical 449 | medium customarily used for software interchange, for a price no 450 | more than your reasonable cost of physically performing this 451 | conveying of source, or (2) access to copy the 452 | Corresponding Source from a network server at no charge. 453 | 454 | c) Convey individual copies of the object code with a copy of the 455 | written offer to provide the Corresponding Source. This 456 | alternative is allowed only occasionally and noncommercially, and 457 | only if you received the object code with such an offer, in accord 458 | with subsection 6b. 459 | 460 | d) Convey the object code by offering access from a designated 461 | place (gratis or for a charge), and offer equivalent access to the 462 | Corresponding Source in the same way through the same place at no 463 | further charge. You need not require recipients to copy the 464 | Corresponding Source along with the object code. If the place to 465 | copy the object code is a network server, the Corresponding Source 466 | may be on a different server (operated by you or a third party) 467 | that supports equivalent copying facilities, provided you maintain 468 | clear directions next to the object code saying where to find the 469 | Corresponding Source. Regardless of what server hosts the 470 | Corresponding Source, you remain obligated to ensure that it is 471 | available for as long as needed to satisfy these requirements. 472 | 473 | e) Convey the object code using peer-to-peer transmission, provided 474 | you inform other peers where the object code and Corresponding 475 | Source of the work are being offered to the general public at no 476 | charge under subsection 6d. 477 | 478 | A separable portion of the object code, whose source code is excluded 479 | from the Corresponding Source as a System Library, need not be 480 | included in conveying the object code work. 481 | 482 | A "User Product" is either (1) a "consumer product", which means any 483 | tangible personal property which is normally used for personal, family, 484 | or household purposes, or (2) anything designed or sold for incorporation 485 | into a dwelling. In determining whether a product is a consumer product, 486 | doubtful cases shall be resolved in favor of coverage. For a particular 487 | product received by a particular user, "normally used" refers to a 488 | typical or common use of that class of product, regardless of the status 489 | of the particular user or of the way in which the particular user 490 | actually uses, or expects or is expected to use, the product. A product 491 | is a consumer product regardless of whether the product has substantial 492 | commercial, industrial or non-consumer uses, unless such uses represent 493 | the only significant mode of use of the product. 494 | 495 | "Installation Information" for a User Product means any methods, 496 | procedures, authorization keys, or other information required to install 497 | and execute modified versions of a covered work in that User Product from 498 | a modified version of its Corresponding Source. The information must 499 | suffice to ensure that the continued functioning of the modified object 500 | code is in no case prevented or interfered with solely because 501 | modification has been made. 502 | 503 | If you convey an object code work under this section in, or with, or 504 | specifically for use in, a User Product, and the conveying occurs as 505 | part of a transaction in which the right of possession and use of the 506 | User Product is transferred to the recipient in perpetuity or for a 507 | fixed term (regardless of how the transaction is characterized), the 508 | Corresponding Source conveyed under this section must be accompanied 509 | by the Installation Information. But this requirement does not apply 510 | if neither you nor any third party retains the ability to install 511 | modified object code on the User Product (for example, the work has 512 | been installed in ROM). 513 | 514 | The requirement to provide Installation Information does not include a 515 | requirement to continue to provide support service, warranty, or updates 516 | for a work that has been modified or installed by the recipient, or for 517 | the User Product in which it has been modified or installed. Access to a 518 | network may be denied when the modification itself materially and 519 | adversely affects the operation of the network or violates the rules and 520 | protocols for communication across the network. 521 | 522 | Corresponding Source conveyed, and Installation Information provided, 523 | in accord with this section must be in a format that is publicly 524 | documented (and with an implementation available to the public in 525 | source code form), and must require no special password or key for 526 | unpacking, reading or copying. 527 | 528 | 7. Additional Terms. 529 | 530 | "Additional permissions" are terms that supplement the terms of this 531 | License by making exceptions from one or more of its conditions. 532 | Additional permissions that are applicable to the entire Program shall 533 | be treated as though they were included in this License, to the extent 534 | that they are valid under applicable law. If additional permissions 535 | apply only to part of the Program, that part may be used separately 536 | under those permissions, but the entire Program remains governed by 537 | this License without regard to the additional permissions. 538 | 539 | When you convey a copy of a covered work, you may at your option 540 | remove any additional permissions from that copy, or from any part of 541 | it. (Additional permissions may be written to require their own 542 | removal in certain cases when you modify the work.) You may place 543 | additional permissions on material, added by you to a covered work, 544 | for which you have or can give appropriate copyright permission. 545 | 546 | Notwithstanding any other provision of this License, for material you 547 | add to a covered work, you may (if authorized by the copyright holders of 548 | that material) supplement the terms of this License with terms: 549 | 550 | a) Disclaiming warranty or limiting liability differently from the 551 | terms of sections 15 and 16 of this License; or 552 | 553 | b) Requiring preservation of specified reasonable legal notices or 554 | author attributions in that material or in the Appropriate Legal 555 | Notices displayed by works containing it; or 556 | 557 | c) Prohibiting misrepresentation of the origin of that material, or 558 | requiring that modified versions of such material be marked in 559 | reasonable ways as different from the original version; or 560 | 561 | d) Limiting the use for publicity purposes of names of licensors or 562 | authors of the material; or 563 | 564 | e) Declining to grant rights under trademark law for use of some 565 | trade names, trademarks, or service marks; or 566 | 567 | f) Requiring indemnification of licensors and authors of that 568 | material by anyone who conveys the material (or modified versions of 569 | it) with contractual assumptions of liability to the recipient, for 570 | any liability that these contractual assumptions directly impose on 571 | those licensors and authors. 572 | 573 | All other non-permissive additional terms are considered "further 574 | restrictions" within the meaning of section 10. If the Program as you 575 | received it, or any part of it, contains a notice stating that it is 576 | governed by this License along with a term that is a further 577 | restriction, you may remove that term. If a license document contains 578 | a further restriction but permits relicensing or conveying under this 579 | License, you may add to a covered work material governed by the terms 580 | of that license document, provided that the further restriction does 581 | not survive such relicensing or conveying. 582 | 583 | If you add terms to a covered work in accord with this section, you 584 | must place, in the relevant source files, a statement of the 585 | additional terms that apply to those files, or a notice indicating 586 | where to find the applicable terms. 587 | 588 | Additional terms, permissive or non-permissive, may be stated in the 589 | form of a separately written license, or stated as exceptions; 590 | the above requirements apply either way. 591 | 592 | 8. Termination. 593 | 594 | You may not propagate or modify a covered work except as expressly 595 | provided under this License. Any attempt otherwise to propagate or 596 | modify it is void, and will automatically terminate your rights under 597 | this License (including any patent licenses granted under the third 598 | paragraph of section 11). 599 | 600 | However, if you cease all violation of this License, then your 601 | license from a particular copyright holder is reinstated (a) 602 | provisionally, unless and until the copyright holder explicitly and 603 | finally terminates your license, and (b) permanently, if the copyright 604 | holder fails to notify you of the violation by some reasonable means 605 | prior to 60 days after the cessation. 606 | 607 | Moreover, your license from a particular copyright holder is 608 | reinstated permanently if the copyright holder notifies you of the 609 | violation by some reasonable means, this is the first time you have 610 | received notice of violation of this License (for any work) from that 611 | copyright holder, and you cure the violation prior to 30 days after 612 | your receipt of the notice. 613 | 614 | Termination of your rights under this section does not terminate the 615 | licenses of parties who have received copies or rights from you under 616 | this License. If your rights have been terminated and not permanently 617 | reinstated, you do not qualify to receive new licenses for the same 618 | material under section 10. 619 | 620 | 9. Acceptance Not Required for Having Copies. 621 | 622 | You are not required to accept this License in order to receive or 623 | run a copy of the Program. Ancillary propagation of a covered work 624 | occurring solely as a consequence of using peer-to-peer transmission 625 | to receive a copy likewise does not require acceptance. However, 626 | nothing other than this License grants you permission to propagate or 627 | modify any covered work. These actions infringe copyright if you do 628 | not accept this License. Therefore, by modifying or propagating a 629 | covered work, you indicate your acceptance of this License to do so. 630 | 631 | 10. Automatic Licensing of Downstream Recipients. 632 | 633 | Each time you convey a covered work, the recipient automatically 634 | receives a license from the original licensors, to run, modify and 635 | propagate that work, subject to this License. You are not responsible 636 | for enforcing compliance by third parties with this License. 637 | 638 | An "entity transaction" is a transaction transferring control of an 639 | organization, or substantially all assets of one, or subdividing an 640 | organization, or merging organizations. If propagation of a covered 641 | work results from an entity transaction, each party to that 642 | transaction who receives a copy of the work also receives whatever 643 | licenses to the work the party's predecessor in interest had or could 644 | give under the previous paragraph, plus a right to possession of the 645 | Corresponding Source of the work from the predecessor in interest, if 646 | the predecessor has it or can get it with reasonable efforts. 647 | 648 | You may not impose any further restrictions on the exercise of the 649 | rights granted or affirmed under this License. For example, you may 650 | not impose a license fee, royalty, or other charge for exercise of 651 | rights granted under this License, and you may not initiate litigation 652 | (including a cross-claim or counterclaim in a lawsuit) alleging that 653 | any patent claim is infringed by making, using, selling, offering for 654 | sale, or importing the Program or any portion of it. 655 | 656 | 11. Patents. 657 | 658 | A "contributor" is a copyright holder who authorizes use under this 659 | License of the Program or a work on which the Program is based. The 660 | work thus licensed is called the contributor's "contributor version". 661 | 662 | A contributor's "essential patent claims" are all patent claims 663 | owned or controlled by the contributor, whether already acquired or 664 | hereafter acquired, that would be infringed by some manner, permitted 665 | by this License, of making, using, or selling its contributor version, 666 | but do not include claims that would be infringed only as a 667 | consequence of further modification of the contributor version. For 668 | purposes of this definition, "control" includes the right to grant 669 | patent sublicenses in a manner consistent with the requirements of 670 | this License. 671 | 672 | Each contributor grants you a non-exclusive, worldwide, royalty-free 673 | patent license under the contributor's essential patent claims, to 674 | make, use, sell, offer for sale, import and otherwise run, modify and 675 | propagate the contents of its contributor version. 676 | 677 | In the following three paragraphs, a "patent license" is any express 678 | agreement or commitment, however denominated, not to enforce a patent 679 | (such as an express permission to practice a patent or covenant not to 680 | sue for patent infringement). To "grant" such a patent license to a 681 | party means to make such an agreement or commitment not to enforce a 682 | patent against the party. 683 | 684 | If you convey a covered work, knowingly relying on a patent license, 685 | and the Corresponding Source of the work is not available for anyone 686 | to copy, free of charge and under the terms of this License, through a 687 | publicly available network server or other readily accessible means, 688 | then you must either (1) cause the Corresponding Source to be so 689 | available, or (2) arrange to deprive yourself of the benefit of the 690 | patent license for this particular work, or (3) arrange, in a manner 691 | consistent with the requirements of this License, to extend the patent 692 | license to downstream recipients. "Knowingly relying" means you have 693 | actual knowledge that, but for the patent license, your conveying the 694 | covered work in a country, or your recipient's use of the covered work 695 | in a country, would infringe one or more identifiable patents in that 696 | country that you have reason to believe are valid. 697 | 698 | If, pursuant to or in connection with a single transaction or 699 | arrangement, you convey, or propagate by procuring conveyance of, a 700 | covered work, and grant a patent license to some of the parties 701 | receiving the covered work authorizing them to use, propagate, modify 702 | or convey a specific copy of the covered work, then the patent license 703 | you grant is automatically extended to all recipients of the covered 704 | work and works based on it. 705 | 706 | A patent license is "discriminatory" if it does not include within 707 | the scope of its coverage, prohibits the exercise of, or is 708 | conditioned on the non-exercise of one or more of the rights that are 709 | specifically granted under this License. You may not convey a covered 710 | work if you are a party to an arrangement with a third party that is 711 | in the business of distributing software, under which you make payment 712 | to the third party based on the extent of your activity of conveying 713 | the work, and under which the third party grants, to any of the 714 | parties who would receive the covered work from you, a discriminatory 715 | patent license (a) in connection with copies of the covered work 716 | conveyed by you (or copies made from those copies), or (b) primarily 717 | for and in connection with specific products or compilations that 718 | contain the covered work, unless you entered into that arrangement, 719 | or that patent license was granted, prior to 28 March 2007. 720 | 721 | Nothing in this License shall be construed as excluding or limiting 722 | any implied license or other defenses to infringement that may 723 | otherwise be available to you under applicable patent law. 724 | 725 | 12. No Surrender of Others' Freedom. 726 | 727 | If conditions are imposed on you (whether by court order, agreement or 728 | otherwise) that contradict the conditions of this License, they do not 729 | excuse you from the conditions of this License. If you cannot convey a 730 | covered work so as to satisfy simultaneously your obligations under this 731 | License and any other pertinent obligations, then as a consequence you may 732 | not convey it at all. For example, if you agree to terms that obligate you 733 | to collect a royalty for further conveying from those to whom you convey 734 | the Program, the only way you could satisfy both those terms and this 735 | License would be to refrain entirely from conveying the Program. 736 | 737 | 13. Use with the GNU Affero General Public License. 738 | 739 | Notwithstanding any other provision of this License, you have 740 | permission to link or combine any covered work with a work licensed 741 | under version 3 of the GNU Affero General Public License into a single 742 | combined work, and to convey the resulting work. The terms of this 743 | License will continue to apply to the part which is the covered work, 744 | but the special requirements of the GNU Affero General Public License, 745 | section 13, concerning interaction through a network will apply to the 746 | combination as such. 747 | 748 | 14. Revised Versions of this License. 749 | 750 | The Free Software Foundation may publish revised and/or new versions of 751 | the GNU General Public License from time to time. Such new versions will 752 | be similar in spirit to the present version, but may differ in detail to 753 | address new problems or concerns. 754 | 755 | Each version is given a distinguishing version number. If the 756 | Program specifies that a certain numbered version of the GNU General 757 | Public License "or any later version" applies to it, you have the 758 | option of following the terms and conditions either of that numbered 759 | version or of any later version published by the Free Software 760 | Foundation. If the Program does not specify a version number of the 761 | GNU General Public License, you may choose any version ever published 762 | by the Free Software Foundation. 763 | 764 | If the Program specifies that a proxy can decide which future 765 | versions of the GNU General Public License can be used, that proxy's 766 | public statement of acceptance of a version permanently authorizes you 767 | to choose that version for the Program. 768 | 769 | Later license versions may give you additional or different 770 | permissions. However, no additional obligations are imposed on any 771 | author or copyright holder as a result of your choosing to follow a 772 | later version. 773 | 774 | 15. Disclaimer of Warranty. 775 | 776 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 777 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 778 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 779 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 780 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 781 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 782 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 783 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 784 | 785 | 16. Limitation of Liability. 786 | 787 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 788 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 789 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 790 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 791 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 792 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 793 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 794 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 795 | SUCH DAMAGES. 796 | 797 | 17. Interpretation of Sections 15 and 16. 798 | 799 | If the disclaimer of warranty and limitation of liability provided 800 | above cannot be given local legal effect according to their terms, 801 | reviewing courts shall apply local law that most closely approximates 802 | an absolute waiver of all civil liability in connection with the 803 | Program, unless a warranty or assumption of liability accompanies a 804 | copy of the Program in return for a fee. 805 | 806 | END OF TERMS AND CONDITIONS 807 | 808 | How to Apply These Terms to Your New Programs 809 | 810 | If you develop a new program, and you want it to be of the greatest 811 | possible use to the public, the best way to achieve this is to make it 812 | free software which everyone can redistribute and change under these terms. 813 | 814 | To do so, attach the following notices to the program. It is safest 815 | to attach them to the start of each source file to most effectively 816 | state the exclusion of warranty; and each file should have at least 817 | the "copyright" line and a pointer to where the full notice is found. 818 | 819 | 820 | Copyright (C) 821 | 822 | This program is free software: you can redistribute it and/or modify 823 | it under the terms of the GNU General Public License as published by 824 | the Free Software Foundation, either version 3 of the License, or 825 | (at your option) any later version. 826 | 827 | This program is distributed in the hope that it will be useful, 828 | but WITHOUT ANY WARRANTY; without even the implied warranty of 829 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 830 | GNU General Public License for more details. 831 | 832 | You should have received a copy of the GNU General Public License 833 | along with this program. If not, see . 834 | 835 | Also add information on how to contact you by electronic and paper mail. 836 | 837 | If the program does terminal interaction, make it output a short 838 | notice like this when it starts in an interactive mode: 839 | 840 | Copyright (C) 841 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 842 | This is free software, and you are welcome to redistribute it 843 | under certain conditions; type `show c' for details. 844 | 845 | The hypothetical commands `show w' and `show c' should show the appropriate 846 | parts of the General Public License. Of course, your program's commands 847 | might be different; for a GUI interface, you would use an "about box". 848 | 849 | You should also get your employer (if you work as a programmer) or school, 850 | if any, to sign a "copyright disclaimer" for the program, if necessary. 851 | For more information on this, and how to apply and follow the GNU GPL, see 852 | . 853 | 854 | The GNU General Public License does not permit incorporating your program 855 | into proprietary programs. If your program is a subroutine library, you 856 | may consider it more useful to permit linking proprietary applications with 857 | the library. If this is what you want to do, use the GNU Lesser General 858 | Public License instead of this License. But first, please read 859 | . 860 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install @runtest 3 | 4 | install: 5 | dune install 6 | 7 | uninstall: 8 | dune uninstall 9 | 10 | clean: 11 | rm -rf _build *~ */*~ 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocplib-json-typed 2 | 3 | This library is a collection of type-aware JSON utilities for OCaml. 4 | 5 | - `Json_encoding` contains an `'a encoding` type that represents 6 | the JSON encoding of OCaml values of type `'a`, and a collection 7 | of combinators to build them. These encodings can be used to 8 | serialize / deserialize OCaml values to / from JSON 9 | documents. JSON schemas can also be generated automatically to 10 | produce documented, interoperable JSON formats. 11 | - `Json_schema` contains an OCaml intermediate representation for 12 | the JSON schema document grammar description language, along with 13 | translators to / from the concrete JSON schema format. 14 | - `Json_query` contains various utilities to manipulate, introspect 15 | and update JSON data. 16 | - `Json_repr` defines an abstraction over JSON representations. 17 | This module is mainly useful when using the functorial interface of 18 | the library, or if you use several JSON libraries in your program 19 | and want to convert data from one JSON representation to another. 20 | 21 | The type of JSON documents handled by this library is directly 22 | compatible with `ezjsonm`, but converters are provided for `yojson` 23 | users, and an advanced functorial interface allows you to use any JSON 24 | representation. Two other representations are also provided. 25 | 26 | - `Json_repr_browser` interfaces JavaScripts objects. It is 27 | available only when compiling to JavaScript via 28 | `js_of_ocaml`. 29 | Provided by the extra package `ocplib-json-typed-browser`. 30 | - `Json_repr_bson` is an implementation of a subset of BSON. 31 | Provided by the extra package `ocplib-json-typed-bson`. 32 | 33 | Thanks to polymorphic variants, this library does not depend on any 34 | JSON library, so you are free to use whichever you want for printing 35 | and parsing. 36 | -------------------------------------------------------------------------------- /ocplib-json-typed-browser.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ocplib-json-typed-browser" 3 | synopsis: "Libraries for reliable manipulation JSON objects (browser support)" 4 | version: "dev" 5 | maintainer: "Benjamin Canou " 6 | authors: "Benjamin Canou " 7 | homepage: "https://github.com/ocamlpro/ocplib-json-typed" 8 | bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" 9 | license: "LGPLv3 w/ linking exception" 10 | dev-repo: "git+https://github.com/ocamlpro/ocplib-json-typed.git" 11 | 12 | build: [ 13 | ["dune" "build" "-j" jobs "-p" name "@install"] 14 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 15 | ] 16 | depends: [ 17 | "ocaml" {>= "4.03.0"} 18 | "dune" {build & >= "1.7"} 19 | "ocplib-json-typed" {= "dev" } 20 | "js_of_ocaml" {>= "3.3.0"} 21 | ] 22 | -------------------------------------------------------------------------------- /ocplib-json-typed-bson.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ocplib-json-typed-bson" 3 | synopsis: "Libraries for reliable manipulation JSON objects (BSON)" 4 | version: "dev" 5 | maintainer: "Benjamin Canou " 6 | authors: "Benjamin Canou " 7 | homepage: "https://github.com/ocamlpro/ocplib-json-typed" 8 | bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" 9 | license: "LGPLv3 w/ linking exception" 10 | dev-repo: "git+https://github.com/ocamlpro/ocplib-json-typed.git" 11 | 12 | build: [ 13 | ["dune" "build" "-j" jobs "-p" name "@install"] 14 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 15 | ] 16 | depends: [ 17 | "ocaml" {>= "4.03.0"} 18 | "dune" {build & >= "1.7"} 19 | "ocplib-json-typed" {= "dev" } 20 | "ocplib-endian" {>= "1.0"} 21 | ] 22 | -------------------------------------------------------------------------------- /ocplib-json-typed.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ocplib-json-typed" 3 | synopsis: "Libraries for reliable manipulation JSON objects" 4 | version: "dev" 5 | maintainer: "Benjamin Canou " 6 | authors: "Benjamin Canou " 7 | homepage: "https://github.com/ocamlpro/ocplib-json-typed" 8 | bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" 9 | license: "LGPLv3 w/ linking exception" 10 | dev-repo: "git+https://github.com/ocamlpro/ocplib-json-typed.git" 11 | 12 | build: [ 13 | ["dune" "build" "-j" jobs "-p" name "@install"] 14 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 15 | ] 16 | depends: [ 17 | "ocaml" {>= "4.03.0"} 18 | "dune" {build & >= "1.7"} 19 | "uri" {>= "1.9.0" } 20 | ] 21 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ocplib_json_typed) 3 | (public_name ocplib-json-typed) 4 | (flags (:standard -w -9)) 5 | (modules json_encoding json_query json_repr json_schema) 6 | (synopsis "Reliable manipulation of JSON objects") 7 | (libraries uri) 8 | (wrapped false)) 9 | 10 | (library 11 | (name ocplib_json_typed_bson) 12 | (public_name ocplib-json-typed-bson) 13 | (flags (:standard -w -9)) 14 | (modules json_repr_bson) 15 | (synopsis "BSON representation of JSON documents") 16 | (libraries ocplib-json-typed ocplib-endian) 17 | (wrapped false)) 18 | 19 | (library 20 | (name ocplib_json_typed_browser) 21 | (public_name ocplib-json-typed-browser) 22 | (flags (:standard -w -9 -open Js_of_ocaml)) 23 | (modules json_repr_browser) 24 | (synopsis "Native browser representation of JSON documents") 25 | (libraries ocplib-json-typed js_of_ocaml) 26 | (wrapped false)) 27 | -------------------------------------------------------------------------------- /src/json_encoding.ml: -------------------------------------------------------------------------------- 1 | (* JSON structure description using dependently typed combinators. *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | exception Unexpected of string * string 21 | exception No_case_matched of exn list 22 | exception Bad_array_size of int * int 23 | exception Missing_field of string 24 | exception Unexpected_field of string 25 | exception Bad_schema of exn 26 | exception Cannot_destruct of (Json_query.path * exn) 27 | 28 | (*-- types and errors --------------------------------------------------------*) 29 | 30 | let unexpected kind expected = 31 | let kind = match kind with 32 | | `O [] -> "empty object" 33 | | `A [] -> "empty array" 34 | | `O _ -> "object" 35 | | `A _ -> "array" 36 | | `Null -> "null" 37 | | `String _ -> "string" 38 | | `Float _ -> "number" 39 | | `Bool _ -> "boolean" in 40 | Cannot_destruct ([], Unexpected (kind, expected)) 41 | 42 | type 't repr_agnostic_custom = 43 | { write : 'rt. (module Json_repr.Repr with type value = 'rt) -> 't -> 'rt ; 44 | read : 'rf. (module Json_repr.Repr with type value = 'rf) -> 'rf -> 't } 45 | 46 | (* The GADT definition for encodings. This type must be kept internal 47 | because it does not encode all invariants. Some properties are 48 | checked at encoding construction time by smart constructors, since 49 | checking them would either be impossible, or would make the type 50 | too complex. In a few corners that involve custom encodings using 51 | user defined functions, some properties cannot be checked until 52 | construction/destruction time. If such a run time check fails, is 53 | denotes a programmer error and an [Invalid_argument] exceptions is 54 | thus raised. *) 55 | type _ encoding = 56 | | Null : unit encoding 57 | | Empty : unit encoding 58 | | Ignore : unit encoding 59 | | Option : 'a encoding -> 'a option encoding 60 | | Constant : string -> unit encoding 61 | | Int : 'a int_encoding -> 'a encoding 62 | | Bool : bool encoding 63 | | String : string encoding 64 | | Float : bounds option -> float encoding 65 | | Array : 'a encoding -> 'a array encoding 66 | | Obj : 'a field -> 'a encoding 67 | | Objs : 'a encoding * 'b encoding -> ('a * 'b) encoding 68 | | Tup : 'a encoding -> 'a encoding 69 | | Tups : 'a encoding * 'b encoding -> ('a * 'b) encoding 70 | | Custom : 't repr_agnostic_custom * Json_schema.schema -> 't encoding 71 | | Conv : ('a -> 'b) * ('b -> 'a) * 'b encoding * Json_schema.schema option -> 'a encoding 72 | | Describe : { id: string ; 73 | title: string option ; 74 | description: string option ; 75 | encoding: 'a encoding } -> 'a encoding 76 | | Mu : { id: string ; 77 | title: string option ; 78 | description: string option ; 79 | self: ('a encoding -> 'a encoding) ; 80 | }-> 'a encoding 81 | | Union : 't case list -> 't encoding 82 | 83 | and 'a int_encoding = 84 | { int_name : string ; 85 | of_float : float -> 'a ; 86 | to_float : 'a -> float ; 87 | lower_bound : 'a ; 88 | upper_bound : 'a } 89 | 90 | and bounds = 91 | { float_name : string ; 92 | minimum : float ; 93 | maximum : float } 94 | 95 | and _ field = 96 | | Req : { name: string ; 97 | encoding: 'a encoding ; 98 | title: string option ; 99 | description: string option ; 100 | } -> 'a field 101 | | Opt : { name: string ; 102 | encoding: 'a encoding ; 103 | title: string option ; 104 | description: string option ; 105 | } -> 'a option field 106 | | Dft : { name: string ; 107 | encoding: 'a encoding ; 108 | title: string option ; 109 | description: string option ; 110 | default: 'a ; 111 | } -> 'a field 112 | 113 | and 't case = 114 | | Case : { encoding : 'a encoding ; 115 | proj : ('t -> 'a option) ; 116 | inj : ('a -> 't) } -> 't case 117 | 118 | (*-- construct / destruct / schema over the main GADT forms ------------------*) 119 | 120 | module Make (Repr : Json_repr.Repr) = struct 121 | 122 | let construct enc v = 123 | let rec construct 124 | : type t. t encoding -> t -> Repr.value 125 | = function 126 | | Null -> (fun () -> Repr.repr `Null) 127 | | Empty -> (fun () -> Repr.repr (`O [])) 128 | | Ignore -> (fun () -> Repr.repr (`O [])) 129 | | Option t -> 130 | (function 131 | | None -> Repr.repr `Null 132 | | Some v -> construct t v) 133 | | Constant str -> (fun () -> Repr.repr (`String str)) 134 | | Int { int_name ; to_float ; lower_bound ; upper_bound } -> 135 | (fun (i : t) -> 136 | if i < lower_bound || i > upper_bound then 137 | invalid_arg 138 | ("Json_encoding.construct: " ^ int_name ^ " out of range"); 139 | Repr.repr (`Float (to_float i))) 140 | | Bool -> (fun (b : t) -> Repr.repr (`Bool b)) 141 | | String -> (fun s -> Repr.repr (`String s)) 142 | | Float (Some { minimum ; maximum ; float_name }) -> 143 | let err = "Json_encoding.construct: " ^ float_name ^ " out of range" in 144 | (fun float -> 145 | if float < minimum || float > maximum then invalid_arg err ; 146 | Repr.repr (`Float float)) 147 | | Float None -> (fun float -> Repr.repr (`Float float)) 148 | | Describe { encoding = t } -> construct t 149 | | Custom ({ write }, _) -> (fun (j : t) -> write (module Repr) j) 150 | | Conv (ffrom, _, t, _) -> (fun v -> construct t (ffrom v)) 151 | | Mu { self } as enc -> construct (self enc) 152 | | Array t -> 153 | let w v = construct t v in 154 | (fun arr -> Repr.repr (`A (Array.to_list (Array.map w arr)))) 155 | | Obj (Req { name = n ; encoding = t }) -> 156 | let w v = construct t v in 157 | (fun v -> Repr.repr (`O [ n, w v ])) 158 | | Obj (Dft { name = n ; encoding = t ; default = d }) -> 159 | let w v = construct t v in 160 | (fun v -> Repr.repr (`O (if v <> d then [ n, w v ] else []))) 161 | | Obj (Opt { name = n ; encoding = t }) -> 162 | let w v = construct t v in 163 | (function None -> Repr.repr (`O []) | Some v -> Repr.repr (`O [ n, w v ])) 164 | | Objs (o1, o2) -> 165 | let w1 v = construct o1 v in 166 | let w2 v = construct o2 v in 167 | (function (v1, v2) -> 168 | match Repr.view (w1 v1), Repr.view (w2 v2) with 169 | | `O l1, `O l2 -> Repr.repr (`O (l1 @ l2)) 170 | | `Null, `Null 171 | | _ -> invalid_arg "Json_encoding.construct: consequence of bad merge_objs") 172 | | Tup t -> 173 | let w v = construct t v in 174 | (fun v -> Repr.repr (`A [ w v ])) 175 | | Tups (o1, o2) -> 176 | let w1 v = construct o1 v in 177 | let w2 v = construct o2 v in 178 | (function (v1, v2) -> 179 | match Repr.view (w1 v1), Repr.view (w2 v2) with 180 | | `A l1, `A l2 -> Repr.repr (`A (l1 @ l2)) 181 | | _ -> invalid_arg "Json_encoding.construct: consequence of bad merge_tups") 182 | | Union cases -> 183 | (fun v -> 184 | let rec do_cases = function 185 | | [] -> invalid_arg "Json_encoding.construct: consequence of bad union" 186 | | Case { encoding ; proj } :: rest -> 187 | match proj v with 188 | | Some v -> construct encoding v 189 | | None -> do_cases rest in 190 | do_cases cases) in 191 | construct enc v 192 | 193 | let rec destruct 194 | : type t. t encoding -> (Repr.value -> t) 195 | = function 196 | | Null -> (fun v -> match Repr.view v with `Null -> () | k -> raise (unexpected k "null")) 197 | | Empty -> (fun v -> match Repr.view v with 198 | | `O [] -> () 199 | | `O [ f, _] -> raise (Cannot_destruct ([], Unexpected_field f)) 200 | | k -> raise @@ unexpected k "an empty object") 201 | | Ignore -> (fun v -> match Repr.view v with _ -> ()) 202 | | Option t -> (fun v -> match Repr.view v with 203 | | `Null -> None 204 | | _ -> Some (destruct t v)) 205 | | Constant str -> 206 | (fun v -> 207 | match Repr.view v with 208 | | `String s when s = str -> () 209 | | x -> raise @@ unexpected x str) 210 | | Int { int_name ; of_float ; to_float ; lower_bound ; upper_bound } -> 211 | let lower_bound = to_float lower_bound in 212 | let upper_bound = to_float upper_bound in 213 | (fun v -> 214 | match Repr.view v with 215 | | `Float v -> 216 | let rest, v = modf v in 217 | if rest <> 0. then begin 218 | let exn = Failure (int_name ^ " cannot have a fractional part") in 219 | raise (Cannot_destruct ([], exn)) 220 | end ; 221 | if v < lower_bound || v > upper_bound then begin 222 | let exn = Failure (int_name ^ " out of range") in 223 | raise (Cannot_destruct ([], exn)) 224 | end ; 225 | of_float v 226 | | k -> raise (unexpected k "number")) 227 | | Bool -> (fun v -> match Repr.view v with `Bool b -> (b : t) | k -> raise (unexpected k "boolean")) 228 | | String -> (fun v -> match Repr.view v with `String s -> s | k -> raise (unexpected k "string")) 229 | | Float None -> (fun v -> match Repr.view v with `Float f -> f | k -> raise (unexpected k "float")) 230 | | Float (Some { minimum ; maximum ; float_name }) -> 231 | (fun v -> 232 | match Repr.view v with 233 | | `Float f -> 234 | if f < minimum || f > maximum 235 | then 236 | let exn = Failure (float_name ^ " out of range") in 237 | raise (Cannot_destruct ([], exn)) 238 | else f 239 | | k -> raise (unexpected k "float")) 240 | | Describe { encoding = t } -> destruct t 241 | | Custom ({ read }, _) -> read (module Repr) 242 | | Conv (_, fto, t, _) -> (fun v -> fto (destruct t v)) 243 | | Mu { self } as enc -> destruct (self enc) 244 | | Array t -> 245 | (fun v -> match Repr.view v with 246 | | `O [] -> 247 | (* Weak `Repr`s like BSON don't know the difference *) 248 | [||] 249 | | `A cells -> 250 | Array.mapi 251 | (fun i cell -> 252 | try destruct t cell with Cannot_destruct (path, err) -> 253 | raise (Cannot_destruct (`Index i :: path, err))) 254 | (Array.of_list cells) 255 | | k -> raise @@ unexpected k "array") 256 | | Obj _ as t -> 257 | let d = destruct_obj t in 258 | (fun v -> match Repr.view v with 259 | | `O fields -> 260 | let r, rest, ign = d fields in 261 | begin match rest with 262 | | (field, _) :: _ when not ign -> raise @@ Unexpected_field field 263 | | _ -> r 264 | end 265 | | k -> raise @@ unexpected k "object") 266 | | Objs _ as t -> 267 | let d = destruct_obj t in 268 | (fun v -> match Repr.view v with 269 | | `O fields -> 270 | let r, rest, ign = d fields in 271 | begin match rest with 272 | | (field, _) :: _ when not ign -> raise @@ Unexpected_field field 273 | | _ -> r 274 | end 275 | | k -> raise @@ unexpected k "object") 276 | | Tup _ as t -> 277 | let r, i = destruct_tup 0 t in 278 | (fun v -> match Repr.view v with 279 | | `A cells -> 280 | let cells = Array.of_list cells in 281 | let len = Array.length cells in 282 | if i <> Array.length cells then 283 | raise (Cannot_destruct ([], Bad_array_size (len, i))) 284 | else r cells 285 | | k -> raise @@ unexpected k "array") 286 | | Tups _ as t -> 287 | let r, i = destruct_tup 0 t in 288 | (fun v -> match Repr.view v with 289 | | `A cells -> 290 | let cells = Array.of_list cells in 291 | let len = Array.length cells in 292 | if i <> Array.length cells then 293 | raise (Cannot_destruct ([], Bad_array_size (len, i))) 294 | else r cells 295 | | k -> raise @@ unexpected k "array") 296 | | Union cases -> 297 | (fun v -> 298 | let rec do_cases errs = function 299 | | [] -> raise (Cannot_destruct ([], No_case_matched (List.rev errs))) 300 | | Case { encoding ; inj } :: rest -> 301 | try inj (destruct encoding v) with 302 | err -> do_cases (err :: errs) rest in 303 | do_cases [] cases) 304 | and destruct_tup 305 | : type t. int -> t encoding -> (Repr.value array -> t) * int 306 | = fun i t -> match t with 307 | | Tup t -> 308 | (fun arr -> 309 | (try destruct t arr.(i) with Cannot_destruct (path, err) -> 310 | raise (Cannot_destruct (`Index i :: path, err)))), succ i 311 | | Tups (t1, t2) -> 312 | let r1, i = destruct_tup i t1 in 313 | let r2, i = destruct_tup i t2 in 314 | (fun arr -> r1 arr, r2 arr), i 315 | | Conv (_, fto, t, _) -> 316 | let r, i = destruct_tup i t in 317 | (fun arr -> fto (r arr)), i 318 | | Mu { self } as enc -> destruct_tup i (self enc) 319 | | Describe { encoding } -> destruct_tup i encoding 320 | | _ -> invalid_arg "Json_encoding.destruct: consequence of bad merge_tups" 321 | and destruct_obj 322 | : type t. t encoding -> (string * Repr.value) list -> t * (string * Repr.value) list * bool 323 | = fun t -> 324 | let rec assoc acc n = function 325 | | [] -> raise Not_found 326 | | (f, v) :: rest when n = f -> v, acc @ rest 327 | | oth :: rest -> assoc (oth :: acc) n rest in 328 | match t with 329 | | Empty -> (fun fields -> (), fields, false) 330 | | Ignore -> (fun fields -> (), fields, true) 331 | | Obj (Req { name = n ; encoding = t }) -> 332 | (fun fields -> 333 | try 334 | let v, rest = assoc [] n fields in 335 | destruct t v, rest, false 336 | with 337 | | Not_found -> 338 | raise (Cannot_destruct ([], Missing_field n)) 339 | | Cannot_destruct (path, err) -> 340 | raise (Cannot_destruct (`Field n :: path, err))) 341 | | Obj (Opt { name = n ; encoding = t }) -> 342 | (fun fields -> 343 | try 344 | let v, rest = assoc [] n fields in 345 | Some (destruct t v), rest, false 346 | with 347 | | Not_found -> None, fields, false 348 | | Cannot_destruct (path, err) -> 349 | raise (Cannot_destruct (`Field n :: path, err))) 350 | | Obj (Dft { name = n ; encoding = t ; default = d }) -> 351 | (fun fields -> 352 | try 353 | let v, rest = assoc [] n fields in 354 | destruct t v, rest, false 355 | with 356 | | Not_found -> d, fields, false 357 | | Cannot_destruct (path, err) -> 358 | raise (Cannot_destruct (`Field n :: path, err))) 359 | | Objs (o1, o2) -> 360 | let d1 = destruct_obj o1 in 361 | let d2 = destruct_obj o2 in 362 | (fun fields -> 363 | let r1, rest, ign1 = d1 fields in 364 | let r2, rest, ign2 = d2 rest in 365 | (r1, r2), rest, ign1 || ign2) 366 | | Conv (_, fto, t, _) -> 367 | let d = destruct_obj t in 368 | (fun fields -> 369 | let r, rest, ign = d fields in 370 | fto r, rest, ign) 371 | | Mu { self } as enc -> destruct_obj (self enc) 372 | | Describe { encoding } -> destruct_obj encoding 373 | | Union cases -> 374 | (fun fields -> 375 | let rec do_cases errs = function 376 | | [] -> raise (Cannot_destruct ([], No_case_matched (List.rev errs))) 377 | | Case { encoding ; inj } :: rest -> 378 | try 379 | let r, rest, ign = destruct_obj encoding fields in 380 | inj r, rest, ign 381 | with err -> do_cases (err :: errs) rest in 382 | do_cases [] cases) 383 | | _ -> invalid_arg "Json_encoding.destruct: consequence of bad merge_objs" 384 | 385 | let custom write read ~schema = 386 | let read 387 | : type tf. (module Json_repr.Repr with type value = tf) -> tf -> 't 388 | = fun (module Repr_f) repr -> 389 | read (Json_repr.convert (module Repr_f) (module Repr) repr) in 390 | let write 391 | : type tf. (module Json_repr.Repr with type value = tf) -> 't -> tf 392 | = fun (module Repr_f) v -> 393 | Json_repr.convert (module Repr) (module Repr_f) (write v) in 394 | Custom ({ read ; write }, schema) 395 | end 396 | 397 | module Ezjsonm_encoding = Make (Json_repr.Ezjsonm) 398 | 399 | let patch_description ?title ?description (elt : Json_schema.element) = 400 | match title, description with 401 | | None, None -> elt 402 | | Some _, None -> { elt with title } 403 | | None, Some _ -> { elt with description } 404 | | Some _, Some _ -> { elt with title ; description } 405 | 406 | let schema ?definitions_path encoding = 407 | let open Json_schema in 408 | let sch = ref any in 409 | let rec prod l1 l2 = match l1 with 410 | | [] -> [] 411 | | (l1, b1) :: es -> 412 | List.map (fun (l2, b2) -> l1 @ l2, b1 || b2) l2 413 | @ prod es l2 in 414 | let rec object_schema 415 | : type t. t encoding -> ((string * element * bool * Json_repr.any option) list * bool) list 416 | = function 417 | | Conv (_, _, o, None) -> object_schema o 418 | | Empty -> [ [], false ] 419 | | Ignore -> [ [], true ] 420 | | Obj (Req { name = n ; encoding = t ; title ; description }) -> 421 | [ [ n, patch_description ?title ?description (schema t), true, None ], false ] 422 | | Obj (Opt { name = n ; encoding = t ; title ; description }) -> 423 | [ [ n, patch_description ?title ?description (schema t), false, None ], false ] 424 | | Obj (Dft { name = n ; encoding = t ; title ; description ; default = d }) -> 425 | let d = Json_repr.repr_to_any (module Json_repr.Ezjsonm) (Ezjsonm_encoding.construct t d) in 426 | [ [ n, patch_description ?title ?description (schema t), false, Some d], false ] 427 | | Objs (o1, o2) -> 428 | prod (object_schema o1) (object_schema o2) 429 | | Union [] -> 430 | invalid_arg "Json_encoding.schema: empty union in object" 431 | | Union cases -> 432 | List.flatten 433 | (List.map 434 | (fun (Case { encoding = o }) -> object_schema o) 435 | cases) 436 | | Mu { self } as enc -> object_schema (self enc) 437 | | Describe { encoding = t } -> object_schema t 438 | | Conv (_, _, _, Some _) (* FIXME: We could do better *) 439 | | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_objs" 440 | and array_schema 441 | : type t. t encoding -> element list 442 | = function 443 | | Conv (_, _, o, None) -> array_schema o 444 | | Tup t -> [ schema t ] 445 | | Tups (t1, t2) -> array_schema t1 @ array_schema t2 446 | | Mu { self } as enc -> array_schema (self enc) 447 | | Describe { encoding = t } -> array_schema t 448 | | Conv (_, _, _, Some _) (* FIXME: We could do better *) 449 | | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_tups" 450 | and schema 451 | : type t. t encoding -> element 452 | = function 453 | | Null -> element Null 454 | | Empty -> element (Object { object_specs with additional_properties = None }) 455 | | Ignore -> element Any 456 | | Option t -> 457 | element (Combine (One_of, [schema t ; element Null])) 458 | | Int { to_float ; lower_bound ; upper_bound } -> 459 | let minimum = Some (to_float lower_bound, `Inclusive) in 460 | let maximum = Some (to_float upper_bound, `Inclusive) in 461 | element (Integer { multiple_of = None ; minimum ; maximum }) 462 | | Bool -> element Boolean 463 | | Constant str -> 464 | { (element (String string_specs)) with 465 | enum = Some [ Json_repr.to_any (`String str) ] } 466 | | String -> element (String string_specs) 467 | | Float (Some { minimum ; maximum }) -> 468 | element (Number { multiple_of = None ; 469 | minimum = Some (minimum, `Inclusive) ; 470 | maximum = Some (maximum, `Inclusive) }) 471 | | Float None -> element (Number numeric_specs) 472 | | Describe { id = name ; title ; description ; encoding } -> 473 | let schema = patch_description ?title ?description (schema encoding) in 474 | let s, def = add_definition ?definitions_path name schema !sch in 475 | sch := fst (merge_definitions (!sch, s)) ; 476 | def 477 | | Custom (_, s) -> 478 | sch := fst (merge_definitions (!sch, s)) ; 479 | root s 480 | | Conv (_, _, _, Some s) -> 481 | sch := fst (merge_definitions (!sch, s)) ; 482 | root s 483 | | Conv (_, _, t, None) -> schema t 484 | | Mu { id = name ; title ; description ; self = f } -> 485 | let fake_schema = 486 | if definition_exists ?definitions_path name !sch then 487 | update (definition_ref ?definitions_path name) !sch 488 | else 489 | let sch, elt = add_definition ?definitions_path name (element Dummy) !sch in 490 | update elt sch in 491 | let fake_self = 492 | Custom ({ write = (fun _ _ -> assert false) ; 493 | read = (fun _ -> assert false) }, 494 | fake_schema) in 495 | let root = 496 | patch_description 497 | ?title ?description 498 | (schema (f fake_self)) in 499 | let nsch, def = add_definition ?definitions_path name root !sch in 500 | sch := nsch ; def 501 | | Array t -> 502 | element (Monomorphic_array (schema t, array_specs)) 503 | | Objs _ as o -> 504 | begin match object_schema o with 505 | | [ properties, ext ] -> 506 | let additional_properties = if ext then Some (element Any) else None in 507 | element (Object { object_specs with properties ; additional_properties }) 508 | | more -> 509 | let elements = 510 | List.map 511 | (fun (properties, ext) -> 512 | let additional_properties = if ext then Some (element Any) else None in 513 | element (Object { object_specs with properties ; additional_properties })) 514 | more in 515 | element (Combine (One_of, elements)) 516 | end 517 | | Obj _ as o -> 518 | begin match object_schema o with 519 | | [ properties, ext ] -> 520 | let additional_properties = if ext then Some (element Any) else None in 521 | element (Object { object_specs with properties ; additional_properties }) 522 | | more -> 523 | let elements = 524 | List.map 525 | (fun (properties, ext) -> 526 | let additional_properties = if ext then Some (element Any) else None in 527 | element (Object { object_specs with properties ; additional_properties })) 528 | more in 529 | element (Combine (One_of, elements)) 530 | end 531 | | Tup _ as t -> element (Array (array_schema t, array_specs)) 532 | | Tups _ as t -> element (Array (array_schema t, array_specs)) 533 | | Union cases -> (* FIXME: smarter merge *) 534 | let elements = 535 | List.map (fun (Case { encoding }) -> schema encoding) cases in 536 | element (Combine (One_of, elements)) in 537 | let schema = schema encoding in 538 | update schema !sch 539 | 540 | (*-- utility wrappers over the GADT ------------------------------------------*) 541 | 542 | let req ?title ?description n t = 543 | Req { name = n ; encoding = t ; title ; description } 544 | let opt ?title ?description n t = 545 | Opt { name = n ; encoding = t ; title ; description } 546 | let dft ?title ?description n t d = 547 | Dft { name = n ; encoding = t ; title ; description ; default = d } 548 | 549 | let mu name ?title ?description self = Mu { id = name ; title ; description ; self } 550 | let null = Null 551 | let int = 552 | Int { int_name = "int" ; 553 | of_float = int_of_float ; 554 | to_float = float_of_int ; 555 | (* cross-platform consistent OCaml ints *) 556 | lower_bound = -(1 lsl 30) ; 557 | upper_bound = (1 lsl 30) - 1 } 558 | let ranged_int ~minimum:lower_bound ~maximum:upper_bound name = 559 | if Sys.word_size = 64 560 | && (lower_bound < -(1 lsl 30) 561 | || upper_bound > (1 lsl 30) - 1) then 562 | invalid_arg "Json_encoding.ranged_int: bounds out of portable int31 range" ; 563 | Int { int_name = name ; 564 | of_float = int_of_float ; 565 | to_float = float_of_int ; 566 | lower_bound ; 567 | upper_bound } 568 | 569 | let int53 = 570 | Int { int_name = "int53" ; 571 | of_float = Int64.of_float ; 572 | to_float = Int64.to_float ; 573 | lower_bound = Int64.neg (Int64.shift_left 1L 53) ; 574 | upper_bound = Int64.shift_left 1L 53 } 575 | let ranged_int53 ~minimum:lower_bound ~maximum:upper_bound name = 576 | if lower_bound < Int64.neg (Int64.shift_left 1L 53) 577 | || upper_bound > Int64.shift_left 1L 53 then 578 | invalid_arg "Json_encoding.ranged_int53: bounds out of JSON-representable integers" ; 579 | Int { int_name = name ; 580 | of_float = Int64.of_float ; 581 | to_float = Int64.to_float ; 582 | lower_bound ; 583 | upper_bound } 584 | 585 | let int32 = 586 | Int { int_name = "int32" ; 587 | of_float = Int32.of_float ; 588 | to_float = Int32.to_float ; 589 | lower_bound = Int32.min_int ; 590 | upper_bound = Int32.max_int } 591 | let ranged_int32 ~minimum:lower_bound ~maximum:upper_bound name = 592 | Int { int_name = name ; 593 | of_float = Int32.of_float ; 594 | to_float = Int32.to_float ; 595 | lower_bound ; 596 | upper_bound } 597 | 598 | let ranged_float ~minimum ~maximum float_name = 599 | Float (Some { minimum ; maximum ; float_name }) 600 | 601 | let float = Float None 602 | let string = String 603 | let conv ffrom fto ?schema t = 604 | Conv (ffrom, fto, t, schema) 605 | let bytes = Conv (Bytes.to_string, Bytes.of_string, string, None) 606 | let bool = Bool 607 | let array t = Array t 608 | let obj1 f1 = Obj f1 609 | let obj2 f1 f2 = Objs (Obj f1, Obj f2) 610 | let obj3 f1 f2 f3 = 611 | conv 612 | (fun (a, b, c) -> (a, (b, c))) 613 | (fun (a, (b, c)) -> (a, b, c)) 614 | (Objs (Obj f1, Objs (Obj f2, Obj f3))) 615 | let obj4 f1 f2 f3 f4 = 616 | conv 617 | (fun (a, b, c, d) -> (a, (b, (c, d)))) 618 | (fun (a, (b, (c, d))) -> (a, b, c, d)) 619 | (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Obj f4)))) 620 | let obj5 f1 f2 f3 f4 f5 = 621 | conv 622 | (fun (a, b, c, d, e) -> (a, (b, (c, (d, e))))) 623 | (fun (a, (b, (c, (d, e)))) -> (a, b, c, d, e)) 624 | (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Obj f5))))) 625 | let obj6 f1 f2 f3 f4 f5 f6 = 626 | conv 627 | (fun (a, b, c, d, e, f) -> (a, (b, (c, (d, (e, f)))))) 628 | (fun (a, (b, (c, (d, (e, f))))) -> (a, b, c, d, e, f)) 629 | (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, Obj f6)))))) 630 | let obj7 f1 f2 f3 f4 f5 f6 f7 = 631 | conv 632 | (fun (a, b, c, d, e, f, g) -> (a, (b, (c, (d, (e, (f, g))))))) 633 | (fun (a, (b, (c, (d, (e, (f, g)))))) -> (a, b, c, d, e, f, g)) 634 | (let rest = Objs (Obj f6, Obj f7) in 635 | Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) 636 | let obj8 f1 f2 f3 f4 f5 f6 f7 f8 = 637 | conv 638 | (fun (a, b, c, d, e, f, g, h) -> (a, (b, (c, (d, (e, (f, (g, h)))))))) 639 | (fun (a, (b, (c, (d, (e, (f, (g, h))))))) -> (a, b, c, d, e, f, g, h)) 640 | (let rest = Objs (Obj f6, Objs (Obj f7, Obj f8)) in 641 | Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) 642 | let obj9 f1 f2 f3 f4 f5 f6 f7 f8 f9 = 643 | conv 644 | (fun (a, b, c, d, e, f, g, h, i) -> (a, (b, (c, (d, (e, (f, (g, (h, i))))))))) 645 | (fun (a, (b, (c, (d, (e, (f, (g, (h, i)))))))) -> (a, b, c, d, e, f, g, h, i)) 646 | (let rest = Objs (Obj f6, Objs (Obj f7, Objs (Obj f8, Obj f9))) in 647 | Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) 648 | let obj10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 = 649 | conv 650 | (fun (a, b, c, d, e, f, g, h, i, j) -> (a, (b, (c, (d, (e, (f, (g, (h, (i, j)))))))))) 651 | (fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) -> (a, b, c, d, e, f, g, h, i, j)) 652 | (let rest = Objs (Obj f6, Objs (Obj f7, Objs (Obj f8, Objs (Obj f9, Obj f10)))) in 653 | Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) 654 | let tup1 f1 = Tup f1 655 | let tup2 f1 f2 = Tups (Tup f1, Tup f2) 656 | let tup3 f1 f2 f3 = 657 | conv 658 | (fun (a, b, c) -> (a, (b, c))) 659 | (fun (a, (b, c)) -> (a, b, c)) 660 | (Tups (Tup f1, Tups (Tup f2, Tup f3))) 661 | let tup4 f1 f2 f3 f4 = 662 | conv 663 | (fun (a, b, c, d) -> (a, (b, (c, d)))) 664 | (fun (a, (b, (c, d))) -> (a, b, c, d)) 665 | (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tup f4)))) 666 | let tup5 f1 f2 f3 f4 f5 = 667 | conv 668 | (fun (a, b, c, d, e) -> (a, (b, (c, (d, e))))) 669 | (fun (a, (b, (c, (d, e)))) -> (a, b, c, d, e)) 670 | (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tup f5))))) 671 | let tup6 f1 f2 f3 f4 f5 f6 = 672 | conv 673 | (fun (a, b, c, d, e, f) -> (a, (b, (c, (d, (e, f)))))) 674 | (fun (a, (b, (c, (d, (e, f))))) -> (a, b, c, d, e, f)) 675 | (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, Tup f6)))))) 676 | let tup7 f1 f2 f3 f4 f5 f6 f7 = 677 | conv 678 | (fun (a, b, c, d, e, f, g) -> (a, (b, (c, (d, (e, (f, g))))))) 679 | (fun (a, (b, (c, (d, (e, (f, g)))))) -> (a, b, c, d, e, f, g)) 680 | (let rest = Tups (Tup f6, Tup f7) in 681 | Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) 682 | let tup8 f1 f2 f3 f4 f5 f6 f7 f8 = 683 | conv 684 | (fun (a, b, c, d, e, f, g, h) -> (a, (b, (c, (d, (e, (f, (g, h)))))))) 685 | (fun (a, (b, (c, (d, (e, (f, (g, h))))))) -> (a, b, c, d, e, f, g, h)) 686 | (let rest = Tups (Tup f6, Tups (Tup f7, Tup f8)) in 687 | Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) 688 | let tup9 f1 f2 f3 f4 f5 f6 f7 f8 f9 = 689 | conv 690 | (fun (a, b, c, d, e, f, g, h, i) -> (a, (b, (c, (d, (e, (f, (g, (h, i))))))))) 691 | (fun (a, (b, (c, (d, (e, (f, (g, (h, i)))))))) -> (a, b, c, d, e, f, g, h, i)) 692 | (let rest = Tups (Tup f6, Tups (Tup f7, Tups (Tup f8, Tup f9))) in 693 | Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) 694 | let tup10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 = 695 | conv 696 | (fun (a, b, c, d, e, f, g, h, i, j) -> (a, (b, (c, (d, (e, (f, (g, (h, (i, j)))))))))) 697 | (fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) -> (a, b, c, d, e, f, g, h, i, j)) 698 | (let rest = Tups (Tup f6, Tups (Tup f7, Tups (Tup f8, Tups (Tup f9, Tup f10)))) in 699 | Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) 700 | 701 | let repr_agnostic_custom { write ; read } ~schema = 702 | Custom ({ write ; read }, schema) 703 | 704 | let constant s = Constant s 705 | 706 | let string_enum cases = 707 | let schema = 708 | let specs = Json_schema.({ pattern = None ; min_length = 0 ; max_length = None }) in 709 | let enum = List.map (fun (s, _) -> Json_repr.(repr_to_any (module Ezjsonm)) (`String s)) cases in 710 | Json_schema.(update { (element (String specs)) with enum = Some enum } any) in 711 | let len = List.length cases in 712 | let mcases = Hashtbl.create len 713 | and rcases = Hashtbl.create len in 714 | let cases_str = String.concat " " (List.map (fun x -> "'" ^ fst x ^ "'") cases) in 715 | List.iter 716 | (fun (s, c) -> 717 | if Hashtbl.mem mcases s then 718 | invalid_arg "Json_encoding.string_enum: duplicate case" ; 719 | Hashtbl.add mcases s c ; 720 | Hashtbl.add rcases c s) 721 | cases ; 722 | conv 723 | (fun v -> try Hashtbl.find rcases v with Not_found -> 724 | invalid_arg (Format.sprintf "Json_encoding.construct: consequence of non exhaustive Json_encoding.string_enum. Strings are: %s" cases_str)) 725 | (fun s -> 726 | (try Hashtbl.find mcases s with Not_found -> 727 | let rec orpat ppf = function 728 | | [] -> assert false 729 | | [ last, _ ] -> Format.fprintf ppf "%S" last 730 | | [ prev, _ ; last, _ ] -> Format.fprintf ppf "%S or %S" prev last 731 | | (prev, _) :: rem -> Format.fprintf ppf "%S , %a" prev orpat rem in 732 | let unexpected = Format.asprintf "string value %S" s in 733 | let expected = Format.asprintf "%a" orpat cases in 734 | raise (Cannot_destruct ([], Unexpected (unexpected, expected))))) 735 | ~schema 736 | string 737 | 738 | let def id ?title ?description encoding = 739 | Describe { id ; title ; description ; encoding } 740 | 741 | let assoc : type t. t encoding -> (string * t) list encoding = fun t -> 742 | Ezjsonm_encoding.custom 743 | (fun l -> `O (List.map (fun (n, v) -> n, Ezjsonm_encoding.construct t v) l)) 744 | (fun v -> match v with 745 | | `O l -> 746 | let destruct n t v = try 747 | Ezjsonm_encoding.destruct t v 748 | with Cannot_destruct (p, exn) -> raise (Cannot_destruct (`Field n :: p, exn)) in 749 | List.map (fun (n, v) -> n, destruct n t v) l 750 | | #Json_repr.ezjsonm as k -> raise (unexpected k "asssociative object")) 751 | ~schema:(let s = schema t in 752 | Json_schema.(update (element (Object { object_specs with additional_properties = Some (root s)})) s)) 753 | 754 | let rec is_nullable: type t. t encoding -> bool = function 755 | | Constant _ -> false 756 | | Int _ -> false 757 | | Float _ -> false 758 | | Array _ -> false 759 | | Empty -> false 760 | | String -> false 761 | | Bool -> false 762 | | Obj _ -> false 763 | | Tup _ -> false 764 | | Objs _ -> false 765 | | Tups _ -> false 766 | | Null -> true 767 | | Ignore -> true 768 | | Option _ -> true 769 | | Conv (_, _, t, _) -> is_nullable t 770 | | Union cases -> 771 | List.exists (fun (Case { encoding = t }) -> is_nullable t) cases 772 | | Describe { encoding = t } -> is_nullable t 773 | | Mu { self } as enc -> is_nullable (self enc) 774 | | Custom (_, sch) -> Json_schema.is_nullable sch 775 | 776 | let option : type t. t encoding -> t option encoding = fun t -> 777 | if is_nullable t then 778 | invalid_arg "Json_encoding.option: cannot nest nullable encodings"; 779 | Option t 780 | 781 | let any_value = 782 | let read repr v = Json_repr.repr_to_any repr v in 783 | let write repr v = Json_repr.any_to_repr repr v in 784 | Custom ({ read ; write }, Json_schema.any) 785 | 786 | let any_ezjson_value = 787 | let read repr v = Json_repr.convert repr (module Json_repr.Ezjsonm) v in 788 | let write repr v = Json_repr.convert (module Json_repr.Ezjsonm) repr v in 789 | Custom ({ read ; write }, Json_schema.any) 790 | 791 | let any_document = 792 | let read 793 | : type tt. (module Json_repr.Repr with type value = tt) -> tt -> Json_repr.any 794 | = fun (module Repr) v -> 795 | match Repr.view v with 796 | | `A _ | `O _ -> 797 | Json_repr.repr_to_any (module Repr) v 798 | | k -> raise @@ unexpected k "array or object" in 799 | let write repr v = Json_repr.any_to_repr repr v in 800 | Custom ({ read ; write }, Json_schema.any) 801 | 802 | let any_schema = 803 | Ezjsonm_encoding.custom 804 | Json_schema.to_json 805 | (fun j -> try Json_schema.of_json j with err -> 806 | raise (Cannot_destruct ([], Bad_schema err))) 807 | ~schema:Json_schema.self 808 | 809 | let merge_tups t1 t2 = 810 | let rec is_tup : type t. t encoding -> bool = function 811 | | Tup _ -> true 812 | | Tups _ (* by construction *) -> true 813 | | Conv (_, _, t, None) -> is_tup t 814 | | Mu { self } as enc -> is_tup (self enc) 815 | | Describe { encoding = t } -> is_tup t 816 | | _ -> false in 817 | if is_tup t1 && is_tup t2 then 818 | Tups (t1, t2) 819 | else 820 | invalid_arg "Json_encoding.merge_tups" 821 | 822 | let list t = 823 | Conv (Array.of_list, Array.to_list, Array t, None) 824 | 825 | let merge_objs o1 o2 = 826 | (* FIXME: check fields unicity *) 827 | let rec is_obj : type t. t encoding -> bool = function 828 | | Obj _ -> true 829 | | Objs _ (* by construction *) -> true 830 | | Conv (_, _, t, None) -> is_obj t 831 | | Empty -> true 832 | | Ignore -> true 833 | | Union cases -> List.for_all (fun (Case { encoding = o }) -> is_obj o) cases 834 | | Mu { self } as enc -> is_obj (self enc) 835 | | Describe { encoding = t } -> is_obj t 836 | | _ -> false in 837 | if is_obj o1 && is_obj o2 then 838 | Objs (o1, o2) 839 | else 840 | invalid_arg "Json_encoding.merge_objs" 841 | 842 | let empty = 843 | Empty 844 | 845 | let unit = 846 | Ignore 847 | 848 | let case encoding proj inj = 849 | Case { encoding ; proj ; inj } 850 | 851 | let union = function 852 | | [] -> invalid_arg "Json_encoding.union" 853 | | cases -> 854 | (* FIXME: check mutual exclusion *) 855 | Union cases 856 | 857 | let rec print_error ?print_unknown ppf = function 858 | | Cannot_destruct ([], exn) -> 859 | print_error ?print_unknown ppf exn 860 | | Cannot_destruct (path, Unexpected (unex, ex)) -> 861 | Format.fprintf ppf 862 | "At %a, unexpected %s instead of %s" 863 | (Json_query.print_path_as_json_path ~wildcards:true) path 864 | unex ex 865 | | Cannot_destruct (path, No_case_matched errs) -> 866 | Format.fprintf ppf 867 | "@[At %a, no case matched:@,%a@]" 868 | (Json_query.print_path_as_json_path ~wildcards:true) path 869 | (Format.pp_print_list (print_error ?print_unknown)) errs 870 | | Cannot_destruct (path, Bad_array_size (unex, ex)) -> 871 | Format.fprintf ppf 872 | "At %a, unexpected array of size %d instead of %d" 873 | (Json_query.print_path_as_json_path ~wildcards:true) path 874 | unex ex 875 | | Cannot_destruct (path, Missing_field n) -> 876 | Format.fprintf ppf 877 | "At %a, missing object field %s" 878 | (Json_query.print_path_as_json_path ~wildcards:true) path 879 | n 880 | | Cannot_destruct (path, Unexpected_field n) -> 881 | Format.fprintf ppf 882 | "At %a, unexpected object field %s" 883 | (Json_query.print_path_as_json_path ~wildcards:true) path 884 | n 885 | | Cannot_destruct (path, Bad_schema exn) -> 886 | Format.fprintf ppf 887 | "@[At %a, bad custom schema:@,%a@]" 888 | (Json_query.print_path_as_json_path ~wildcards:true) path 889 | (print_error ?print_unknown) exn 890 | | Unexpected (unex, ex) -> 891 | Format.fprintf ppf 892 | "Unexpected %s instead of %s" unex ex 893 | | No_case_matched errs -> 894 | Format.fprintf ppf 895 | "@[No case matched:@,%a@]" 896 | (Format.pp_print_list (print_error ?print_unknown)) errs 897 | | Bad_array_size (unex, ex) -> 898 | Format.fprintf ppf 899 | "Unexpected array of size %d instead of %d" unex ex 900 | | Missing_field n -> 901 | Format.fprintf ppf 902 | "Missing object field %s" n 903 | | Unexpected_field n -> 904 | Format.fprintf ppf 905 | "Unexpected object field %s" n 906 | | Bad_schema exn -> 907 | Format.fprintf ppf 908 | "@[bad custom schema:@,%a@]" 909 | (print_error ?print_unknown) exn 910 | | Cannot_destruct (path, exn) -> 911 | Format.fprintf ppf 912 | "@[At %a:@,%a@]" 913 | (Json_query.print_path_as_json_path ~wildcards:true) path 914 | (print_error ?print_unknown) exn 915 | | exn -> 916 | Json_schema.print_error ?print_unknown ppf exn 917 | 918 | include Ezjsonm_encoding 919 | -------------------------------------------------------------------------------- /src/json_encoding.mli: -------------------------------------------------------------------------------- 1 | (************************************************************************) 2 | (* ocplib-json-typed *) 3 | (* *) 4 | (* Copyright 2014 OCamlPro *) 5 | (* *) 6 | (* This file is distributed under the terms of the GNU Lesser General *) 7 | (* Public License as published by the Free Software Foundation; either *) 8 | (* version 2.1 of the License, or (at your option) any later version, *) 9 | (* with the OCaml static compilation exception. *) 10 | (* *) 11 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 12 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 13 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 14 | (* GNU General Public License for more details. *) 15 | (* *) 16 | (************************************************************************) 17 | 18 | (** JSON structure description using dependently typed combinators. *) 19 | 20 | (** {2 Dependent types describing JSON document structures} *) 21 | 22 | (** An encoding between an OCaml data type (the parameter) and a 23 | JSON representation. To be built using the predefined 24 | combinators provided by this module. 25 | 26 | For instance, here is an encoding, of type [(int * string) 27 | encoding], mapping values of type [int * string] to JSON objects 28 | with a field [code] of whose value is a number and a field 29 | [message] whose value is a string. 30 | 31 | [let enc = obj2 (req "code" int) (req "message" string)] 32 | 33 | This encoding serves three purposes: 34 | 35 | 1. Output an OCaml value of type ['a] to an intermediate JSON 36 | representation using {!construct}. To be printed to actual 37 | JSON using an external library. 38 | 2. Input a JSON intermediate structure (already parsed with an external 39 | library) to produce an OCaml value of type ['a]. 40 | 3. Describe this encoding in JSON-schema format for inter-operability: 41 | you describe the encoding of your internal types, and obtain 42 | machine-readable descriptions of the formats as a byproduct. 43 | Specific documentation combinators are provided for that purpose. 44 | 45 | By default, this library provides functions that work on the 46 | {!Json_repr.ezjsonm} data type, compatible with {!Ezjsonm.value}. 47 | However, encodings are not tied with this representation. 48 | See functor {!Make} and module {!Json_repr} for using another format. *) 49 | type 'a encoding 50 | 51 | (** {2 Constructors and destructors for Json_repr.ezjsonm} *) (***************) 52 | (** see {!Json_repr.ezjsonm} *) 53 | 54 | (** Builds a json value from an OCaml value and an encoding. 55 | 56 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 57 | format. See functor {!Make} for using another representation. *) 58 | val construct : 't encoding -> 't -> Json_repr.ezjsonm 59 | 60 | (** Reads an OCaml value from a JSON value and an encoding. 61 | May raise [Cannot_destruct]. 62 | 63 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 64 | format. See functor {!Make} for using another representation. *) 65 | val destruct : 't encoding -> Json_repr.ezjsonm -> 't 66 | 67 | (** {2 JSON type combinators for simple immediates} *) (***********************) 68 | 69 | (** An encoding of an OCaml unit by any (ignored) JSON. *) 70 | val unit : unit encoding 71 | 72 | (** An encoding of an OCaml unit by a JSON null. *) 73 | val null : unit encoding 74 | 75 | (** An encoding of an OCaml unit by an empty JSON object. *) 76 | val empty : unit encoding 77 | 78 | (** An encoding of an OCaml int by a JSON number. 79 | 80 | When destructing, the JSON number cannot have a fractional part, 81 | and must be between [-2^30] and [2^30-1] (these bounds are chosen 82 | to be compatible with both 32-bit and 64bit native OCaml compilers 83 | as well as JavaScript). When constructing, the value coming from 84 | the OCaml world is assumed to be valid, otherwise an 85 | [Invalid_argument] will be raised (can only happen on 64-bit systems). 86 | 87 | Use {!int32} or {!int53} for a greater range. 88 | Use {!ranged_int} to restrict to an interval. *) 89 | val int : int encoding 90 | 91 | (** An encoding of an OCaml int32 by a JSON number. 92 | 93 | Must be a floating point without fractional part and between 94 | [-2^31] and [2^31-1] when destructing. Never fails when 95 | constructing, as all 32-bit integers are included in JSON numbers. *) 96 | val int32 : int32 encoding 97 | 98 | (** An encoding of a JSON-representable OCaml int64 by a JSON number. 99 | 100 | Restricted to the [-2^53] to [2^53] range, as this is the limit of 101 | representable integers in JSON numbers. Must be a floating point 102 | without fractional part and in this range when destructing. When 103 | constructing, the value coming from the OCaml world is assumed to 104 | be in this range, otherwise an [Invalid_argument] will be raised. *) 105 | val int53 : int64 encoding 106 | 107 | (** An encoding of an OCaml int by a JSON number restricted to a specific range. 108 | 109 | The bounds must be between [-2^30] and [2^30-1]. 110 | 111 | The inclusive bounds are checked when destructing. When 112 | constructing, the value coming from the OCaml world is assumed to 113 | be within the bounds, otherwise an [Invalid_argument] will be 114 | raised. The string parameter is a name used to tweak the error 115 | messages. *) 116 | val ranged_int : minimum: int -> maximum: int -> string -> int encoding 117 | 118 | (** An encoding of an OCaml int32 by a JSON number restricted to a specific range. 119 | 120 | The bounds must be between [-2^31] and [2^31-1]. 121 | 122 | The inclusive bounds are checked when destructing. When 123 | constructing, the value coming from the OCaml world is assumed to 124 | be within the bounds, otherwise an [Invalid_argument] will be 125 | raised. The string parameter is a name used to tweak the error 126 | messages. *) 127 | val ranged_int32 : minimum: int32 -> maximum: int32 -> string -> int32 encoding 128 | 129 | (** An encoding of an OCaml int64 by a JSON number restricted to a specific range. 130 | 131 | The bounds must be between [-2^53] and [2^53]. 132 | 133 | The inclusive bounds are checked when destructing. When 134 | constructing, the value coming from the OCaml world is assumed to 135 | be within the bounds, otherwise an [Invalid_argument] will be 136 | raised. The string parameter is a name used to tweak the error 137 | messages. *) 138 | val ranged_int53 : minimum: int64 -> maximum: int64 -> string -> int64 encoding 139 | 140 | (** An encoding of an OCaml boolean by a JSON one. *) 141 | val bool : bool encoding 142 | 143 | (** An encoding of an OCaml string by a JSON one. *) 144 | val string : string encoding 145 | 146 | (** An encoding of a closed set of OCaml values by JSON strings. *) 147 | val string_enum : (string * 'a) list -> 'a encoding 148 | 149 | (** An encoding of a constant string. *) 150 | val constant : string -> unit encoding 151 | 152 | (** An encoding of an OCaml mutable string by a JSON string. *) 153 | val bytes : bytes encoding 154 | 155 | (** An encoding of an OCaml float by a JSON number. *) 156 | val float : float encoding 157 | 158 | (** An encoding of an OCaml float by a JSON number with range constraints *) 159 | val ranged_float : minimum:float -> maximum:float -> string -> float encoding 160 | 161 | (** An encoding of an OCaml option by a nullable JSON value. Raises 162 | [Invalid_argument] when nesting options – i.e., when building ['a option 163 | option encoding]. Also raises [Invalid_argument] when used on the encoding 164 | of [null]. *) 165 | val option : 'a encoding -> 'a option encoding 166 | 167 | (** {2 JSON type combinators for objects} *) (*********************************) 168 | 169 | (** A first class handle to a JSON field. *) 170 | type 'a field 171 | 172 | (** A required field of a given its type. *) 173 | val req : ?title:string -> ?description:string -> string -> 't encoding -> 't field 174 | 175 | (** An optional field of a given type, using an OCaml [option]. *) 176 | val opt : ?title:string -> ?description:string -> string -> 't encoding -> 't option field 177 | 178 | (** An optional field of a given type, ommited when equal to a default value. *) 179 | val dft : ?title:string -> ?description:string -> string -> 't encoding -> 't -> 't field 180 | 181 | (** An encoding of an OCaml value by a singleton object. *) 182 | val obj1 : 183 | 'f1 field -> 184 | 'f1 encoding 185 | 186 | (** An encoding of an OCaml pair by a JSON object with two fields. *) 187 | val obj2 : 188 | 'f1 field -> 'f2 field -> 189 | ('f1 * 'f2) encoding 190 | 191 | (** An encoding of an OCaml triple by a JSON object with three fields. *) 192 | val obj3 : 193 | 'f1 field -> 'f2 field -> 'f3 field -> 194 | ('f1 * 'f2 * 'f3) encoding 195 | 196 | (** An encoding of an OCaml quadruple by a JSON object with four fields. *) 197 | val obj4 : 198 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 199 | ('f1 * 'f2 * 'f3 * 'f4) encoding 200 | 201 | (** An encoding of an OCaml quintuple by a JSON object with five fields. *) 202 | val obj5 : 203 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 204 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding 205 | 206 | (** An encoding of an OCaml sextuple by a JSON object with six fields. *) 207 | val obj6 : 208 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 209 | 'f6 field -> 210 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding 211 | 212 | (** An encoding of an OCaml septuple by a JSON object with seven fields. *) 213 | val obj7 : 214 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 215 | 'f6 field -> 'f7 field -> 216 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding 217 | 218 | (** An encoding of an OCaml octuple by a JSON object with eight fields. *) 219 | val obj8 : 220 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 221 | 'f6 field -> 'f7 field -> 'f8 field -> 222 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding 223 | 224 | (** An encoding of an OCaml nonuple by a JSON object with nine fields. *) 225 | val obj9 : 226 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 227 | 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 228 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding 229 | 230 | (** An encoding of an OCaml decuple by a JSON object with ten fields. *) 231 | val obj10 : 232 | 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> 233 | 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 'f10 field -> 234 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding 235 | 236 | (** Merge two object [encoding]s. For describing heavyweight objects with 237 | a lot of fields. The ocaml type is a pair of tuples, but the JSON 238 | object is flat. Both arguments must be object encodings, 239 | otherwise a future {!construct}, {!destruct} or {!schema} will fail 240 | with [Invalid_argument]. *) 241 | val merge_objs : 242 | 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding 243 | 244 | (** {2 JSON type combinators for arrays} *) (**********************************) 245 | 246 | (** An encoding of an OCaml array by a JSON one. *) 247 | val array : 248 | 'a encoding -> 249 | 'a array encoding 250 | 251 | (** An encoding of an OCaml list by a JSON one. *) 252 | val list : 253 | 'a encoding -> 254 | 'a list encoding 255 | 256 | (** An encoding of an OCaml associative list by a JSON object. *) 257 | val assoc : 258 | 'a encoding -> 259 | (string * 'a) list encoding 260 | 261 | (** An encoding of an OCaml value by a singleton array. *) 262 | val tup1 : 263 | 'f1 encoding -> 264 | 'f1 encoding 265 | 266 | (** An encoding of an OCaml pair by a JSON array with two cells. *) 267 | val tup2 : 268 | 'f1 encoding -> 'f2 encoding -> 269 | ('f1 * 'f2) encoding 270 | 271 | (** An encoding of an OCaml triple by a JSON array with three cells. *) 272 | val tup3 : 273 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 274 | ('f1 * 'f2 * 'f3) encoding 275 | 276 | (** An encoding of an OCaml quadruple by a JSON array with four cells. *) 277 | val tup4 : 278 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 279 | ('f1 * 'f2 * 'f3 * 'f4) encoding 280 | 281 | (** An encoding of an OCaml quintuple by a JSON array with five cells. *) 282 | val tup5 : 283 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 284 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding 285 | 286 | (** An encoding of an OCaml sextuple by a JSON array with six cells. *) 287 | val tup6 : 288 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 289 | 'f6 encoding -> 290 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding 291 | 292 | (** An encoding of an OCaml septuple by a JSON array with seven cells. *) 293 | val tup7 : 294 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 295 | 'f6 encoding -> 'f7 encoding -> 296 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding 297 | 298 | (** An encoding of an OCaml octuple by a JSON array with eight cells. *) 299 | val tup8 : 300 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 301 | 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> 302 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding 303 | 304 | (** An encoding of an OCaml nonuple by a JSON array with nine cells. *) 305 | val tup9 : 306 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 307 | 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> 'f9 encoding -> 308 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding 309 | 310 | (** An encoding of an OCaml decuple by a JSON array with ten cells. *) 311 | val tup10 : 312 | 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> 313 | 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> 'f9 encoding -> 'f10 encoding -> 314 | ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding 315 | 316 | (** Merge two tuple [encoding]s. For describing heavyweight arrays with a 317 | lot of cells. The ocaml type is a pair of tuples, but the JSON 318 | array is flat, with the elements of the first tuple before the 319 | ones of the second. Both arguments must be tuple encodings, 320 | otherwise a future {!construct}, {!destruct} or {!schema} will fail 321 | with [Invalid_argument]. *) 322 | val merge_tups : 323 | 'a1 encoding -> 324 | 'a2 encoding -> 325 | ('a1 * 'a2) encoding 326 | 327 | (** {2 JSON type combinators for unions} *) (**********************************) 328 | 329 | (** A case for describing union types using {!union} ans {!case}. *) 330 | type 't case 331 | 332 | (** To be used inside a {!union}. Takes a [encoding] for a specific 333 | case, and a converter to and from a type common to all cases 334 | (['t]). Usually, it consists in boxing / deboxing the specific 335 | data in an OCaml sum type contructor. *) 336 | val case : 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case 337 | 338 | (** A utility to build destructors for custom encoded sum types. *) 339 | val union : 't case list -> 't encoding 340 | 341 | (** {2 JSON generic type combinators} *) (*************************************) 342 | 343 | (** A simple custom encoding using the {!Json_repr.ezjsonm} 344 | intermediate representation for the conversion functions. The 345 | resulting encoding is usable with any other instanciation of 346 | functor {!Make}, internal conversions may be performed needed. 347 | The second transformer function can 348 | [raise (Cannot_destruct ([ (* location *)], exn))] 349 | to indicate an error, which will be relocated correctly. *) 350 | val custom : 351 | ('t -> Json_repr.ezjsonm) -> 352 | (Json_repr.ezjsonm -> 't) -> 353 | schema: Json_schema.schema -> 354 | 't encoding 355 | 356 | (** An encoding adapter, with an optional handwritten schema. 357 | The second transformer function can [raise (Cannot_destruct ([], exn))] 358 | to indicate an error, which will be relocated correctly. *) 359 | val conv : 360 | ('a -> 'b) -> 361 | ('b -> 'a) -> 362 | ?schema: Json_schema.schema -> 363 | 'b encoding -> 364 | 'a encoding 365 | 366 | (** A fixpoint combinator. Links a recursive OCaml type to an internal 367 | JSON schema reference, by allowing to use the encoding inside its 368 | own definition. The first parameter is a path, that must be unique 369 | and respect the format of {!Json_schema.add_definition}. It is 370 | used to encode the recursivity as a named reference in the JSON 371 | schema. 372 | 373 | Here is an example to turn a standard OCaml list into either 374 | ["nil"] for [[]] or [{"hd":hd,"tl":tl}] for [hd::tl]. 375 | 376 | {[ let reclist itemencoding = 377 | mu "list" @@ fun self -> 378 | union 379 | [ case (string_enum [ "nil", () ]) 380 | (function [] -> Some () | _ :: _ -> None) 381 | (fun () -> []) ; 382 | case (obj2 (req "hd" itemencoding) (req "tl" self)) 383 | (function hd :: tl -> Some (hd, tl) | [] -> None) 384 | (fun (hd, tl) -> hd :: tl) ]) ]} *) 385 | val mu : 386 | string -> 387 | ?title: string -> 388 | ?description: string -> 389 | ('a encoding -> 'a encoding) -> 'a encoding 390 | 391 | (** A raw JSON value in ezjsonm representation. *) 392 | val any_ezjson_value : Json_repr.ezjsonm encoding 393 | 394 | (** A valid JSON document (i.e. an array or object value). *) 395 | val any_document : Json_repr.any encoding 396 | 397 | (** The encoding of a JSON schema, linked to its OCaml definiton. *) 398 | val any_schema : Json_schema.schema encoding 399 | 400 | (** {2 Exporting [encoding]s as JSON schemas} *) (********************************) 401 | 402 | (** Describe an encoding in JSON schema format. 403 | May raise {!Bad_schema}. *) 404 | val schema : ?definitions_path:string -> 't encoding -> Json_schema.schema 405 | 406 | (** Name a definition so its occurences can be shared in the JSON 407 | schema. The first parameter is a path, that must be unique and 408 | respect the format of {!Json_schema.add_definition}. *) 409 | val def : 410 | string -> 411 | ?title:string -> 412 | ?description:string -> 413 | 't encoding -> 't encoding 414 | 415 | (** {2 Errors} *) (************************************************************) 416 | 417 | (** Exception raised by destructors, with the location in the original 418 | JSON structure and the specific error. *) 419 | exception Cannot_destruct of (Json_query.path * exn) 420 | 421 | (** Unexpected kind of data encountered (w/ the expectation). *) 422 | exception Unexpected of string * string 423 | 424 | (** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *) 425 | exception No_case_matched of exn list 426 | 427 | (** Array of unexpected size encountered (w/ the expectation). *) 428 | exception Bad_array_size of int * int 429 | 430 | (** Missing field in an object. *) 431 | exception Missing_field of string 432 | 433 | (** Supernumerary field in an object. *) 434 | exception Unexpected_field of string 435 | 436 | (** Bad custom schema encountered. *) 437 | exception Bad_schema of exn 438 | 439 | (** Produces a human readable version of an error. *) 440 | val print_error 441 | : ?print_unknown: (Format.formatter -> exn -> unit) -> 442 | Format.formatter -> exn -> unit 443 | 444 | (** {2 Advanced interface for using a custom JSON representation} *) (**********) 445 | 446 | module Make (Repr : Json_repr.Repr) : sig 447 | 448 | (** Same as {!construct} for a custom JSON representation. *) 449 | val construct : 't encoding -> 't -> Repr.value 450 | 451 | (** Same as {!destruct} for a custom JSON representation. *) 452 | val destruct : 't encoding -> Repr.value -> 't 453 | 454 | (** Same as {!custom} for a custom JSON representation. *) 455 | val custom : 456 | ('t -> Repr.value) -> (Repr.value -> 't) -> 457 | schema: Json_schema.schema -> 458 | 't encoding 459 | 460 | end 461 | 462 | (** Custom encoders for an OCaml type, given both custom conversion 463 | functions. The actual representation is not known in advance, so 464 | the conversion functions have to examine / construct the JSON 465 | value through the first class modules they are passed. The [read] 466 | transformer function can [raise (Cannot_destruct ([], "message"))] 467 | to indicate an error, which will be relocated correctly. 468 | 469 | Here is an example of how to build such a value for a type ['t]. 470 | 471 | {[ let read 472 | : type tf. (module Json_repr.Repr with type value = tf) -> tf -> 't 473 | = fun (module Repr_f) repr -> 474 | match Repr_f.view repr with 475 | | `Null (* destruct the JSON using [Repr_f.view] *) -> 476 | (* create a value of type 't *) 477 | | _ -> 478 | (* or fail with this wrapping exception *) 479 | raise (Cannot_destruct ([ (* location *) ], (* exn *))) in 480 | let write 481 | : type tf. (module Json_repr.Repr with type value = tf) -> 't -> tf 482 | = fun (module Repr_f) v -> 483 | (* examine the value and produce a JSON using [Repr_f.repr] *) 484 | Repr_f.repr `Null in 485 | { read ; write } ]} *) 486 | type 't repr_agnostic_custom = 487 | { write : 'rt. (module Json_repr.Repr with type value = 'rt) -> 't -> 'rt ; 488 | read : 'rf. (module Json_repr.Repr with type value = 'rf) -> 'rf -> 't } 489 | 490 | (** A custom encoding, using custom encoders and a schema. *) 491 | val repr_agnostic_custom : 492 | 't repr_agnostic_custom -> 493 | schema: Json_schema.schema -> 494 | 't encoding 495 | 496 | (** A raw JSON value in its original representation. *) 497 | val any_value : Json_repr.any encoding 498 | 499 | (** Returns [true] is the encoding might construct [null]. *) 500 | val is_nullable : 't encoding -> bool 501 | -------------------------------------------------------------------------------- /src/json_query.ml: -------------------------------------------------------------------------------- 1 | (* Queries in JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | type path = 21 | path_item list 22 | 23 | and path_item = 24 | [ `Field of string 25 | | `Index of int 26 | | `Star | `Next ] 27 | 28 | exception Illegal_pointer_notation of string * int * string 29 | exception Unsupported_path_item of path_item * string 30 | exception Cannot_merge of path 31 | 32 | (*-- path operations -------------------------------------------------------*) 33 | 34 | let print_path_as_json_path ?(wildcards = true) ppf = function 35 | | [] -> Format.fprintf ppf "/" 36 | | nonempty -> 37 | let rec print ppf = function 38 | | [] -> () 39 | | `Field n :: rem -> Format.fprintf ppf "/%s%a" n print rem 40 | | `Index n :: rem -> Format.fprintf ppf "[%d]%a" n print rem 41 | | `Next :: rem when wildcards -> Format.fprintf ppf "-%a" print rem 42 | | `Star :: rem when wildcards -> Format.fprintf ppf "*%a" print rem 43 | | (`Next | `Star) :: _ -> 44 | raise (Unsupported_path_item (`Star, "JSON path w/o wildcards")) in 45 | print ppf nonempty 46 | 47 | let print_path_as_json_pointer ?(wildcards = true) ppf = function 48 | | [] -> Format.fprintf ppf "/" 49 | | nonempty -> 50 | let rec print ppf = function 51 | | [] -> () 52 | | `Field n :: rem -> Format.fprintf ppf "/%s%a" n print rem 53 | | `Index n :: rem -> Format.fprintf ppf "/%d%a" n print rem 54 | | `Next :: rem when wildcards -> Format.fprintf ppf "/-%a" print rem 55 | | `Next :: _ -> raise (Unsupported_path_item (`Star, "JSON pointer w/o wildcards")) 56 | | `Star :: _ -> raise (Unsupported_path_item (`Star, "JSON pointer")) in 57 | print ppf nonempty 58 | 59 | let json_pointer_of_path ?wildcards path = 60 | Format.asprintf "%a" (print_path_as_json_pointer ?wildcards) path 61 | 62 | let path_of_json_pointer ?(wildcards = true) str = 63 | let buf = Buffer.create 100 in 64 | let len = String.length str in 65 | let rec slashes acc i = 66 | if i >= len then List.rev acc 67 | else if String.get str i = '/' then slashes acc (i + 1) 68 | else item acc i 69 | and item acc i = 70 | if i >= len then List.rev (interp () :: acc) 71 | else match String.get str i with 72 | | '/' -> slashes (interp () :: acc) i 73 | | '~' -> 74 | if i + 1 >= len then 75 | raise (Illegal_pointer_notation (str, i, "Unterminated escape sequence")) ; 76 | begin match String.get str i with 77 | | '0' -> Buffer.add_char buf '~' 78 | | '1' -> Buffer.add_char buf '/' 79 | | _illegal -> 80 | raise (Illegal_pointer_notation (str, i + 1, "Illegal escape character")) end ; 81 | item acc (i + 1) 82 | | unescaped -> 83 | Buffer.add_char buf unescaped ; 84 | item acc (i + 1) 85 | and interp () = 86 | let field = Buffer.contents buf in 87 | Buffer.clear buf ; 88 | if field = "-" then 89 | if wildcards then 90 | `Next 91 | else 92 | raise (Unsupported_path_item (`Next, "JSON pointer w/o wildcards")) 93 | else try `Index (int_of_string field) with 94 | | _ -> `Field field in 95 | if len = 0 then [] 96 | else if String.get str 0 <> '/' then 97 | raise (Illegal_pointer_notation (str, 0, "Missing initial slash")) 98 | else slashes [] 1 99 | 100 | (*-- queries ---------------------------------------------------------------*) 101 | 102 | module Make (Repr : Json_repr.Repr) = struct 103 | 104 | let rec query path json = match path, Repr.view json with 105 | | [], _ -> 106 | json 107 | | `Field n :: rempath, `O ((n', v) :: rem) -> 108 | if n = n' then query rempath v else query path (Repr.repr (`O rem)) 109 | | `Index i :: rempath, `A cells -> 110 | let i = if i < 0 then List.length cells - i else i in 111 | query rempath (List.nth cells i) 112 | | `Star :: rempath, `O ((_, v) :: rem) -> 113 | begin try query rempath v with Not_found -> query path (Repr.repr (`O rem)) end 114 | | `Star :: rempath, `A (v :: rem) -> 115 | begin try query rempath v with Not_found -> query path (Repr.repr (`A rem)) end 116 | | _, _ -> raise Not_found 117 | 118 | let query_all path json = 119 | let res = ref [] in 120 | let rec query path json = match path, Repr.view json with 121 | | [], _ -> 122 | res := json :: !res 123 | | `Field n :: rempath, `O ((n', v) :: rem) -> 124 | if n = n' then query rempath v else query path (Repr.repr (`O rem)) 125 | | `Index i :: rempath, `A cells -> 126 | let i = if i < 0 then List.length cells - i else i in 127 | query rempath (List.nth cells i) 128 | | `Star :: rempath, `O fields -> 129 | List.iter (fun (_, v) -> query rempath v) fields 130 | | `Star :: rempath, `A cells -> 131 | List.iter (query rempath) cells 132 | | _, _ -> () in 133 | query path json ; !res 134 | 135 | (*-- updates ---------------------------------------------------------------*) 136 | 137 | let sort_fields = 138 | List.sort (fun (l, _) (r, _) -> compare l r) 139 | 140 | let equals l r = 141 | let rec canon v = match Repr.view v with 142 | | `O l -> Repr.repr (`O (List.map (fun (n, o) -> n, canon o) l |> sort_fields)) 143 | | `A l -> Repr.repr (`A (List.map canon l)) 144 | | _ -> v in 145 | canon l = canon r 146 | 147 | let merge l r = 148 | let rec merge path l r = 149 | match Repr.view l, Repr.view r with 150 | | `O l, `O r -> Repr.repr (`O (merge_fields path [] (sort_fields (l @ r)))) 151 | | `Null, v | v, `Null -> Repr.repr v 152 | | `A l, `A r -> Repr.repr (`A (merge_cells path 0 [] l r)) 153 | | _ -> if equals l r then l else raise (Cannot_merge (List.rev path)) 154 | and merge_cells path i acc l r = match l, r with 155 | | [], rem | rem, [] -> List.rev_append acc rem 156 | | l :: ls, r :: rs -> 157 | let item = merge (`Index i :: path) l r in 158 | merge_cells path (succ i) (item :: acc) ls rs 159 | and merge_fields path acc = function 160 | | (lf, lv) :: ((rf, rv) :: rem as rrem) -> 161 | if lf = rf then 162 | let item = merge (`Field lf :: path) lv rv in 163 | merge_fields path ((lf, item) :: acc) rem 164 | else 165 | merge_fields path ((lf, lv) :: acc) rrem 166 | | [ _ ] | [] as last -> last in 167 | merge [] l r 168 | 169 | let insert ?(merge = merge) path value root = 170 | let revpath sub = 171 | let rec loop acc = function 172 | | l when l == sub -> List.rev acc 173 | | item :: items -> loop (item :: acc) items 174 | | [] -> (* absurd *) assert false 175 | in loop [] path in 176 | let merge path l r = 177 | try merge l r with 178 | Cannot_merge sub -> raise (Cannot_merge (revpath path @ sub)) in 179 | let rec nulls acc n last = 180 | if n <= 0 then 181 | List.rev (last :: acc) 182 | else 183 | nulls (Repr.repr `Null :: acc) (pred n) last in 184 | let rec insert ?root path = 185 | let root = match root with None -> None | Some repr -> Some (Repr.view repr) in 186 | match path, root with 187 | (* create objects *) 188 | | `Field n :: rempath, None -> 189 | Repr.repr (`O [ (n, insert rempath) ]) 190 | | (`Index 0 | `Star | `Next) :: rempath, None -> 191 | Repr.repr (`A [ insert rempath ]) 192 | | `Index i :: rempath, None -> 193 | if i < 0 then raise (Cannot_merge (revpath path)) ; 194 | Repr.repr (`A (nulls [] (max 0 (pred i)) (insert rempath))) 195 | | [], None -> value 196 | (* insert in existing *) 197 | | [], Some value' -> 198 | merge path value (Repr.repr value') 199 | | `Field n :: rempath, Some (`O fields) -> 200 | Repr.repr (`O (insert_fields [] n rempath fields)) 201 | | `Index i :: rempath, Some (`A cells) -> 202 | let i = if i < 0 then List.length cells - i else i in 203 | if i < 0 then raise (Cannot_merge (revpath path)) ; 204 | Repr.repr (`A (insert_cells [] i rempath cells)) 205 | | `Next :: rempath, Some (`A cells) -> 206 | Repr.repr (`A (List.rev_append (List.rev cells) [ insert rempath ])) 207 | (* multiple insertions *) 208 | | `Star :: rempath, Some (`A cells) -> 209 | Repr.repr (`A (List.map (fun root -> insert ~root rempath) cells)) 210 | | `Star :: rempath, Some (`O fields) -> 211 | Repr.repr (`O (List.map (fun (n, root) -> (n, insert ~root rempath)) fields)) 212 | | [ `Star ], Some root -> 213 | merge path value (Repr.repr root) 214 | (* FIXME: make explicit unhandled cases *) 215 | | _, Some _ -> raise (Cannot_merge (revpath path)) 216 | and insert_fields acc n rempath fields = match fields with 217 | | [] -> 218 | List.rev ((n, insert rempath) :: acc) 219 | | (n', root) :: rem when n = n' -> 220 | List.rev_append ((n, insert ~root rempath) :: acc) rem 221 | | other :: rem -> 222 | insert_fields (other :: acc) n rempath rem 223 | and insert_cells acc n rempath cells = 224 | match cells, n with 225 | | [], n -> 226 | nulls acc n (insert rempath) 227 | | root :: rem, 0 -> 228 | List.rev_append ((insert ~root rempath) :: acc) rem 229 | | other :: rem, n -> 230 | insert_cells (other :: acc) (n - 1) rempath rem in 231 | insert ~root path 232 | 233 | let replace path value root = 234 | insert ~merge:(fun value _prev -> value) path value root 235 | 236 | let insert path value root = 237 | insert path value root 238 | 239 | end 240 | 241 | let path_operator_name = function 242 | | `Field _ -> "field access" 243 | | `Index _ -> "array access" 244 | | `Star -> "wildcard" 245 | | `Next -> "array append" 246 | 247 | let print_error ?print_unknown ppf err = match err with 248 | | Illegal_pointer_notation (notation, pos, msg) -> 249 | Format.fprintf ppf 250 | "@[Illegal pointer notation@,At character %d of %S@,%s@]" 251 | pos notation msg 252 | | Unsupported_path_item (item, msg) -> 253 | Format.fprintf ppf 254 | "Path operator %s unsupported by %s" 255 | (path_operator_name item) msg 256 | | Cannot_merge [] -> 257 | Format.fprintf ppf 258 | "Unmergeable objects" 259 | | Cannot_merge path -> 260 | Format.fprintf ppf 261 | "Unmergeable objects, incompatibility at %a" 262 | (print_path_as_json_path ~wildcards:true) path 263 | | exn -> 264 | match print_unknown with 265 | | Some print_unknown -> print_unknown ppf exn 266 | | None -> 267 | Format.fprintf ppf "Unhandled error %s" (Printexc.to_string exn) 268 | 269 | include Make (Json_repr.Ezjsonm) 270 | -------------------------------------------------------------------------------- /src/json_query.mli: -------------------------------------------------------------------------------- 1 | (** Queries in JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | (** {2 Paths in JSON documents} *) (*****************************************) 21 | 22 | (** An abstract type for paths into a JSON document. 23 | A sequence of sub-tree selectors to descend into a JSON tree. *) 24 | type path = path_item list 25 | 26 | (** A JSON sub-tree selector. 27 | Indendent from any concrete format (JSON pointer, JSON path, etc.) 28 | The semantics depends on the use (selection, insertion, etc.) *) 29 | and path_item = 30 | [ `Field of string 31 | (** A field in an object. *) 32 | | `Index of int 33 | (** An index in an array. *) 34 | | `Star 35 | (** Any / every field or index. *) 36 | | `Next 37 | (** The next element after an array. *) ] 38 | 39 | (** Pretty prints a path in JSON pointer format (RFC6901). May throw 40 | {!Unsupported_path_item}. Use [~wildcards:false] to deactivate the 41 | support of wildcard path items, which may lead to 42 | {!Unsupported_path_item}. *) 43 | val print_path_as_json_pointer : ?wildcards: bool -> Format.formatter -> path -> unit 44 | 45 | (** Pretty prints a path in JSON path format. Use [~wildcards:false] to 46 | deactivate the support of wildcard path items, which may lead to 47 | {!Unsupported_path_item}. *) 48 | val print_path_as_json_path : ?wildcards: bool -> Format.formatter -> path -> unit 49 | 50 | (** Pretty prints a path in JSON pointer format into a fresh string. 51 | May throw {!Unsupported_path_item}. Use [~wildcards:false] to 52 | deactivate the support of wildcard path items, which may lead to 53 | {!Unsupported_path_item}. *) 54 | val json_pointer_of_path : ?wildcards: bool -> path -> string 55 | 56 | (** Parses a path from a string in JSON pointer format. May throw 57 | {!Illegal_pointer_notation}. The string is expected to be ASCII 58 | compatible, including UTF-8. Use [~wildcards:false] to deactivate 59 | the support of wildcard path items, which may lead to 60 | {!Unsupported_path_item}. *) 61 | val path_of_json_pointer : ?wildcards: bool -> string -> path 62 | 63 | (** {2 Querying JSON documents} *) (*******************************************) 64 | 65 | (** Extracts the value located at a given path. If multiple locations 66 | satisfy the path (in presence of wildcard path items), the chosen 67 | one is unspecified. May throw [Not_found]. 68 | 69 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 70 | format. See functor {!Make} for using another representation. *) 71 | val query : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm 72 | 73 | (** Extracts the values located at a given path (may be more than one 74 | in presence of wildcard path items). The order is unspecified. 75 | 76 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 77 | format. See functor {!Make} for using another representation. *) 78 | val query_all : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm list 79 | 80 | (** Insert a value at a given path. If multiple locations satisfy the 81 | path (in presence of wildcard path items), the chosen one is 82 | unspecified. Will create parent objects or arrays if needed, for 83 | instance inserting [3] at [/a/b/c] in [{}] will result in 84 | [{"a":{"b":{"c":3}}}]. Inserting in an array at an index bigger 85 | than the previous size will expand the array, filling potential 86 | missing cells with [`Null]. Inserting in an array at [`Index n] 87 | where [n] is negative inserts from the last element of the 88 | array. If a value is inserted at a location where there is already 89 | one, both are merged as if with {!merge}. May throw 90 | {!Cannot_merge} if the path is incompatible with the original 91 | object (such as inserting in a field of something which is not an 92 | object) or if the value is to be merged with an incompatible 93 | existing value. 94 | 95 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 96 | format. See functor {!Make} for using another representation. *) 97 | val insert : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm 98 | 99 | (** Same as {!insert}, except that if the path leads to a pre-existing 100 | value, it is replaced with the new one instead of being merged. 101 | 102 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 103 | format. See functor {!Make} for using another representation. *) 104 | val replace : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm 105 | 106 | (** Merges two compatible JSON values. Merges [`Null] with any JSON 107 | value. Merges two deeply equal values together. Merges two objects 108 | by merging their common fields and adding all the others. Merges 109 | two arrays by merging their common cells pairwise and adding the 110 | remaining ones if one array is bigger than the other. May throw 111 | {!Cannot_merge}. 112 | 113 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 114 | format. See functor {!Make} for using another representation. *) 115 | val merge : Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm 116 | 117 | (** {2 Errors} *) (**********************************************************) 118 | 119 | (** When two incompatible objects are unsuccessfully merged. Comes 120 | with the path to the first incompatibility encountered.*) 121 | exception Cannot_merge of path 122 | 123 | (** An path litteral could not be parsed. Comes with the original 124 | string, the position and an explanation. *) 125 | exception Illegal_pointer_notation of string * int * string 126 | 127 | (** An operation was given a path containing an unsupported construct. 128 | Comes with an explanation as its second argument. *) 129 | exception Unsupported_path_item of path_item * string 130 | 131 | (** Produces a human readable version of an error. *) 132 | val print_error 133 | : ?print_unknown: (Format.formatter -> exn -> unit) -> 134 | Format.formatter -> exn -> unit 135 | 136 | (** {2 Advanced interface for using a custom JSON representation} *) (**********) 137 | 138 | module Make (Repr : Json_repr.Repr) : sig 139 | 140 | (** Same as {!query} for a custom JSON representation. *) 141 | val query : path -> Repr.value -> Repr.value 142 | 143 | (** Same as {!query_all} for a custom JSON representation. *) 144 | val query_all : path -> Repr.value -> Repr.value list 145 | 146 | (** Same as {!insert} for a custom JSON representation. *) 147 | val insert : path -> Repr.value -> Repr.value -> Repr.value 148 | 149 | (** Same as {!replace} for a custom JSON representation. *) 150 | val replace : path -> Repr.value -> Repr.value -> Repr.value 151 | 152 | (** Same as {!merge} for a custom JSON representation. *) 153 | val merge : Repr.value -> Repr.value -> Repr.value 154 | 155 | end 156 | -------------------------------------------------------------------------------- /src/json_repr.ml: -------------------------------------------------------------------------------- 1 | (* Representations of JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | type 'a view = 21 | [ `O of (string * 'a) list 22 | | `A of 'a list 23 | | `Bool of bool 24 | | `Float of float 25 | | `String of string 26 | | `Null ] 27 | 28 | type 'a repr_uid = 'a option ref 29 | (* This is used for limiting conversions. When a value is converted 30 | from a representation to another, which mostly happens when using 31 | the {!type:any} boxing, such as when writing custom encodings, the 32 | original value is usually traversed using the [view] of the 33 | original representation, and recreated using the [repr] of the 34 | destination representation. When converting from a representation 35 | to itself, we want to optimize out this transformation, that is a 36 | deep copy, and just get the same value. For this, we have to prove 37 | to OCaml that it is indeed a value from the same representation. 38 | To do that, we use the following trick. Each representation has a 39 | bucket, the uid below. When converting from the original 40 | representation, we put the value in its bucket. Then, we check the 41 | bucket of the destination, and if it happens to be occupied, we 42 | find in it the original value, under the destination type. Voilà. *) 43 | let repr_uid () = ref None 44 | let eq_repr_uid 45 | : 'a -> 'a repr_uid -> 'b repr_uid -> 'b option 46 | = fun a ta tb -> tb := None ; ta := Some a ; !tb 47 | 48 | module type Repr = sig 49 | type value 50 | val view : value -> value view 51 | val repr : value view -> value 52 | val repr_uid : value repr_uid 53 | end 54 | 55 | module Ezjsonm = struct 56 | type value = 57 | [ `O of (string * value) list 58 | | `A of value list 59 | | `Bool of bool 60 | | `Float of float 61 | | `String of string 62 | | `Null ] 63 | let view v = v 64 | let repr v = v 65 | let repr_uid = repr_uid () 66 | end 67 | 68 | type ezjsonm = Ezjsonm.value 69 | 70 | module Yojson = struct 71 | type value = 72 | [ `Bool of bool 73 | | `Assoc of (string * value) list 74 | | `Float of float 75 | | `Int of int 76 | | `Intlit of string 77 | | `List of value list 78 | | `Null 79 | | `String of string 80 | | `Tuple of value list 81 | | `Variant of string * value option ] 82 | let view = function 83 | | `Intlit i -> `String i 84 | | `Tuple l -> `A l 85 | | `Variant (label, Some x) -> `A [ `String label ; x ] 86 | | `Variant (label, None) -> `String label 87 | | `Assoc l -> `O l 88 | | `List l -> `A l 89 | | `Int i -> `Float (float i) 90 | | `Float f -> `Float f 91 | | `String s -> `String s 92 | | `Null -> `Null 93 | | `Bool b -> `Bool b 94 | let repr = function 95 | | `O l -> `Assoc l 96 | | `A l -> `List l 97 | | `Bool b -> `Bool b 98 | | `Float f -> `Float f 99 | | `String s -> `String s 100 | | `Null -> `Null 101 | let repr_uid = repr_uid () 102 | end 103 | 104 | type yojson = Yojson.value 105 | 106 | let convert 107 | : type tt tf. 108 | (module Repr with type value = tf) -> 109 | (module Repr with type value = tt) -> 110 | tf -> tt 111 | = fun (module Repr_f) (module Repr_t) v -> 112 | match eq_repr_uid v Repr_f.repr_uid Repr_t.repr_uid with 113 | | Some r -> r 114 | | None -> 115 | let rec conv v = match Repr_f.view v with 116 | | `Float _ | `Bool _ | `String _ | `Null as v -> Repr_t.repr v 117 | | `A values -> Repr_t.repr (`A (List.map conv values)) 118 | | `O values -> Repr_t.repr (`O (List.map (fun (k, v) -> (k, conv v)) values)) in 119 | conv v 120 | 121 | let pp_string ppf s = 122 | Format.fprintf ppf "\"" ; 123 | for i = 0 to String.length s - 1 do 124 | match String.get s i with 125 | | '\"' -> Format.fprintf ppf "\\\"" 126 | | '\n' -> Format.fprintf ppf "\\n" 127 | | '\r' -> Format.fprintf ppf "\\r" 128 | | '\b' -> Format.fprintf ppf "\\b" 129 | | '\t' -> Format.fprintf ppf "\\t" 130 | | '\\' -> Format.fprintf ppf "\\\\" 131 | | '\x00' .. '\x1F' as c -> Format.fprintf ppf "\\u%04x" (Char.code c) 132 | | c -> Format.fprintf ppf "%c" c 133 | done ; 134 | Format.fprintf ppf "\"" 135 | 136 | let pp 137 | ?(compact = false) ?(pp_string = pp_string) 138 | (type value) (module Repr : Repr with type value = value) ppf (v : value) = 139 | let rec pp_compact ppf v = match Repr.view v with 140 | | `O l -> 141 | let pp_sep ppf () = 142 | Format.fprintf ppf "," in 143 | let pp_field ppf (name, v) = 144 | Format.fprintf ppf "%a:%a" 145 | pp_string name 146 | pp_compact v in 147 | Format.fprintf ppf "{%a}" 148 | (Format.pp_print_list ~pp_sep pp_field) 149 | l 150 | | `A l -> 151 | let pp_sep ppf () = 152 | Format.fprintf ppf "," in 153 | Format.fprintf ppf "[%a]" 154 | (Format.pp_print_list ~pp_sep pp_compact) l 155 | | `Bool true -> Format.fprintf ppf "true" 156 | | `Bool false -> Format.fprintf ppf "false" 157 | | `Float f -> 158 | let fract, intr = modf f in 159 | if fract = 0.0 then 160 | Format.fprintf ppf "%.0f" intr 161 | else 162 | Format.fprintf ppf "%g" f 163 | | `String s -> pp_string ppf s 164 | | `Null -> Format.fprintf ppf "null" in 165 | let rec pp_box ppf v = match Repr.view v with 166 | | `O [] -> Format.fprintf ppf "{}" 167 | | `O l -> 168 | let pp_sep ppf () = 169 | Format.fprintf ppf ",@ " in 170 | let pp_field ppf (name, v) = 171 | Format.fprintf ppf "@[%a:@ %a@]" 172 | pp_string name 173 | pp_box v in 174 | Format.fprintf ppf "@[{ %a }@]" 175 | (Format.pp_print_list ~pp_sep pp_field) 176 | l 177 | | `A [] -> Format.fprintf ppf "[]" 178 | | `A l -> 179 | let pp_sep ppf () = 180 | Format.fprintf ppf ",@ " in 181 | Format.fprintf ppf "@[[ %a ]@]" 182 | (Format.pp_print_list ~pp_sep pp_box) l 183 | | _ -> pp_compact ppf v in 184 | if compact then 185 | pp_compact ppf v 186 | else 187 | pp_box ppf v 188 | 189 | let from_yojson non_basic = 190 | (* Delete `Variant, `Tuple and `Intlit *) 191 | let rec to_basic non_basic = match non_basic with 192 | | `Intlit i -> `String i 193 | | `Tuple l -> `List (List.map to_basic l) 194 | | `Variant (label, Some x) -> `List [`String label; to_basic x] 195 | | `Variant (label, None) -> `String label 196 | | `Assoc l -> `Assoc (List.map (fun (key, value) -> (key, to_basic value)) l) 197 | | `List l -> `List (List.map to_basic l) 198 | | `Int i -> `Int i 199 | | `Float f -> `Float f 200 | | `String s -> `String s 201 | | `Null -> `Null 202 | | `Bool b -> `Bool b in 203 | (* Rename `Assoc, `Int and `List *) 204 | let rec to_value : 'a. _ -> ([> ezjsonm ] as 'a) = function 205 | | `List l -> `A (List.map to_value l) 206 | | `Assoc l -> `O (List.map (fun (key, value) -> (key, to_value value)) l) 207 | | `Int i -> `Float (float_of_int i) 208 | | `Float f -> `Float f 209 | | `Null -> `Null 210 | | `String s -> `String s 211 | | `Bool b -> `Bool b in 212 | to_basic (non_basic :> yojson) |> to_value 213 | 214 | let to_yojson json = 215 | let rec aux : 'a. _ -> ([> yojson ] as 'a) = function 216 | | `A values -> 217 | `List (List.map aux values) 218 | | `O values -> 219 | `Assoc (List.map (fun (k, v) -> (k, aux v)) values) 220 | | `Float f -> 221 | let fract, intr = modf f in 222 | let max_intf = float 0x3F_FF_FF_FF in 223 | let min_intf = ~-. max_intf -. 1. in 224 | if fract = 0.0 then 225 | if intr >= min_intf && intr <= max_intf 226 | then `Int (int_of_float intr) 227 | else `Intlit (Printf.sprintf "%.0f" intr) 228 | else `Float f 229 | | `Bool b -> `Bool b 230 | | `String s -> `String s 231 | | `Null -> `Null 232 | in aux (json :> ezjsonm) 233 | 234 | type any = Value_with_repr: (module Repr with type value = 'a) * 'a -> any 235 | 236 | let pp_any ?compact ?pp_string () ppf (Value_with_repr (repr, v)) = 237 | pp ?compact ?pp_string repr ppf v 238 | 239 | let any_to_repr : 240 | type tt. (module Repr with type value = tt) -> any -> tt = 241 | fun repr_t (Value_with_repr (repr_f, v)) -> convert repr_f repr_t v 242 | 243 | let repr_to_any repr v = 244 | Value_with_repr (repr, v) 245 | 246 | let from_any : 'a. any -> ([> ezjsonm] as 'a) = fun repr -> 247 | let res = any_to_repr (module Ezjsonm) repr in 248 | (res : ezjsonm :> [> ezjsonm]) 249 | 250 | let to_any v = 251 | Value_with_repr ((module Ezjsonm), (v :> ezjsonm)) 252 | -------------------------------------------------------------------------------- /src/json_repr.mli: -------------------------------------------------------------------------------- 1 | (************************************************************************) 2 | (* ocplib-json-typed *) 3 | (* *) 4 | (* Copyright 2014 OCamlPro *) 5 | (* *) 6 | (* This file is distributed under the terms of the GNU Lesser General *) 7 | (* Public License as published by the Free Software Foundation; either *) 8 | (* version 2.1 of the License, or (at your option) any later version, *) 9 | (* with the OCaml static compilation exception. *) 10 | (* *) 11 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 12 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 13 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 14 | (* GNU General Public License for more details. *) 15 | (* *) 16 | (************************************************************************) 17 | 18 | (** Representations of JSON documents *) 19 | 20 | (** {2 Abstraction over JSON representations} *) 21 | 22 | (** The internal format used by the library. A common format to view 23 | JSON structures from different representations. It only shows the 24 | head of structures, hiding the contents of fields, so that the 25 | conversion from another format or a stream can be done lazily. *) 26 | type 'a view = 27 | [ `O of (string * 'a) list 28 | (** An associative table (object). *) 29 | | `A of 'a list 30 | (** An (integer indexed) array. *) 31 | | `Bool of bool 32 | (** A JS boolean [true] or [false]. *) 33 | | `Float of float 34 | (** A floating point number (double precision). *) 35 | | `String of string 36 | (** An UTF-8 encoded string. *) 37 | | `Null 38 | (** The [null] constant. *) ] 39 | 40 | (** Each representation must provide a unique identifier, obtained via 41 | the {!repr_uid} function. This identifier is used when converting 42 | between representations, to optimize out a copy when converting 43 | from a representation to itself. Beware that this optimization 44 | relies only on this [uid] token. Converting between values of the 45 | same type using two different representation modules with 46 | different [uid]s will perform a copy. A practical way to ensure 47 | that the optimization is made is to write your representations as 48 | toplevel modules, and not inside functors. *) 49 | type 'a repr_uid 50 | 51 | (** See {!type:repr_uid}. *) 52 | val repr_uid : unit -> 'a repr_uid 53 | 54 | (** A view over a given implementation. *) 55 | module type Repr = sig 56 | 57 | (** The implementation type. *) 58 | type value 59 | 60 | (** View a value in the common format. *) 61 | val view : value -> value view 62 | 63 | (** Builds a value from a view *) 64 | val repr : value view -> value 65 | 66 | (** See {!type:repr_uid}. *) 67 | val repr_uid : value repr_uid 68 | 69 | end 70 | 71 | (** Convert a JSON value from one representation to another. *) 72 | val convert : 73 | (module Repr with type value = 'tf) -> 74 | (module Repr with type value = 'tt) -> 75 | 'tf -> 'tt 76 | 77 | (** Generic pretty-printer. If [compact] is set (by default), then the 78 | output is not really pretty (no space is output). Ascii-compatible 79 | string encoding is expected, as printing only escapes double 80 | quotes and control characters. Use [pp_string] for more advanced 81 | escaping. This function does not claim to be the best JSON pretty 82 | printer, it is mostly a small utility. *) 83 | val pp : 84 | ?compact: bool -> ?pp_string: (Format.formatter -> string -> unit) -> 85 | (module Repr with type value = 'tf) -> 86 | Format.formatter -> 'tf -> unit 87 | 88 | 89 | (** {2 Third party in-memory JSON document representations} *) 90 | 91 | (** A JSON value compatible with {!Ezjsonm.value}. *) 92 | type ezjsonm = 93 | [ `O of (string * ezjsonm) list 94 | (** An associative table (object). *) 95 | | `A of ezjsonm list 96 | (** An (integer indexed) array. *) 97 | | `Bool of bool 98 | (** A JS boolean [true] or [false]. *) 99 | | `Float of float 100 | (** A floating point number (double precision). *) 101 | | `String of string 102 | (** An UTF-8 encoded string. *) 103 | | `Null 104 | (** The [null] constant. *) ] 105 | 106 | (** A view over the {!type:ezjsonm} representation.*) 107 | module Ezjsonm : Repr with type value = ezjsonm 108 | 109 | (** A JSON value compatible with {!Yojson.Safe.json}. *) 110 | type yojson = 111 | [ `Bool of bool 112 | (** A JS boolean [true] of [false]. *) 113 | | `Assoc of (string * yojson) list 114 | (** JSON object. *) 115 | | `Float of float 116 | (** A floating point number (double precision). *) 117 | | `Int of int 118 | (** A number without decimal point or exponent. *) 119 | | `Intlit of string 120 | (** A number without decimal point or exponent, preserved as string. *) 121 | | `List of yojson list 122 | (** A JS array. *) 123 | | `Null 124 | (** The [null] constant. *) 125 | | `String of string 126 | (** An UTF-8 encoded string. *) 127 | | `Tuple of yojson list 128 | (** A tuple (non-standard). Syntax: ("abc", 123). *) 129 | | `Variant of string * yojson option 130 | (** A variant (non-standard). Syntax: <"Foo"> or <"Bar": 123>. *) ] 131 | 132 | (** A view over the {!yojson} representation.*) 133 | module Yojson : Repr with type value = yojson 134 | 135 | (** {2 Representation-agnostic JSON format} *) 136 | 137 | (** A meta-representation for JSON values that can unify values of 138 | different representations by boxing them with their corresponding 139 | {!Repr} modules. *) 140 | type any = private Value_with_repr: (module Repr with type value = 'a) * 'a -> any 141 | 142 | (** Converts a boxed value from its intrinsic representation to the 143 | one of the given {!Repr} module. Optimized if the internal 144 | representation of the value actually is the requested one. *) 145 | val any_to_repr : (module Repr with type value = 'a) -> any -> 'a 146 | 147 | (** Boxes a value with a compatible {!Repr} module. *) 148 | val repr_to_any : (module Repr with type value = 'a) -> 'a -> any 149 | 150 | (** Pretty-printer for values of type {!any}. See {!pp} for details. *) 151 | val pp_any : 152 | ?compact: bool -> ?pp_string: (Format.formatter -> string -> unit) -> unit -> 153 | Format.formatter -> any -> unit 154 | 155 | (** {2 Predefined converters for ezjsonm } *) 156 | (** see {!type:ezjsonm} *) 157 | 158 | (** Conversion helper. *) 159 | val from_yojson : [< yojson ] -> [> ezjsonm ] 160 | 161 | (** Conversion helper. *) 162 | val to_yojson : [< ezjsonm] -> [> yojson ] 163 | 164 | (** Converts a boxed value from its representation to {!ezjsonm}. *) 165 | val from_any : any -> [> ezjsonm ] 166 | 167 | (** Boxes as {!ezjsonm} value. *) 168 | val to_any : [< ezjsonm] -> any 169 | -------------------------------------------------------------------------------- /src/json_repr_browser.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of Learn-OCaml. 2 | * 3 | * Copyright (C) 2016 OCamlPro. 4 | * 5 | * Learn-OCaml is free software: you can redistribute it and/or modify 6 | * it under the terms of the GNU Affero General Public License as 7 | * published by the Free Software Foundation, either version 3 of the 8 | * License, or (at your option) any later version. 9 | * 10 | * Learn-OCaml is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU Affero General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU Affero General Public License 16 | * along with this program. If not, see . *) 17 | 18 | module Repr = struct 19 | 20 | (* Not for the faint of heart. *) 21 | 22 | type value = unit Js.t 23 | 24 | let repr = function 25 | | `String s -> Js.Unsafe.coerce (Js.string s) 26 | | `Float f -> Js.Unsafe.coerce (Obj.magic f) 27 | | `Bool true -> Js.Unsafe.coerce Js._true 28 | | `Bool false -> Js.Unsafe.coerce Js._false 29 | | `Null -> Obj.magic Js.null (* Oh, nom nom nom! *) 30 | | `O fields -> 31 | let obj = Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "Object") [||] in 32 | List.iter 33 | (fun (n, v) -> Js.Unsafe.set obj (Js.string n) v) 34 | fields ; 35 | obj 36 | | `A cells -> 37 | Js.Unsafe.coerce (Js.array (Array.of_list cells)) 38 | 39 | let view v = 40 | match Js.to_string (Js.typeof v) with 41 | | "string" -> `String (Js.to_string (Js.Unsafe.coerce v)) 42 | | "number" -> `Float (Obj.magic v) 43 | | "boolean" -> `Bool (Js.to_bool (Obj.magic v)) 44 | | "undefined" -> `Null (* Oh yeah! *) 45 | | "object" -> 46 | if v == Js.Unsafe.pure_js_expr "null" then 47 | `Null 48 | else if Js.instanceof v (Js.Unsafe.pure_js_expr "Array") then 49 | let rec loop acc n = 50 | if n < 0 then 51 | `A acc 52 | else 53 | loop (Js.Unsafe.get v n :: acc) (n - 1) 54 | in 55 | loop [] (Js.Unsafe.get v (Js.string "length") - 1) 56 | else 57 | let fields : Js.js_string Js.t list = 58 | Array.to_list @@ Js.to_array 59 | (Js.Unsafe.fun_call 60 | (Js.Unsafe.js_expr 61 | "(function(o){\ 62 | \ var p=[];\ 63 | \ for(var n in o){if(o.hasOwnProperty(n)){p.push(n);}}\ 64 | \ return p;\ 65 | })") 66 | [| Js.Unsafe.inject v |]) in 67 | `O (List.map 68 | (fun f -> Js.to_string f, Js.Unsafe.get v f) 69 | fields) 70 | | _ -> invalid_arg "Json_repr_browser.Repr.view" 71 | 72 | let repr_uid = Json_repr.repr_uid () 73 | 74 | end 75 | 76 | type value = Repr.value 77 | 78 | let js_stringify ?indent obj = 79 | Js.Unsafe.meth_call 80 | (Js.Unsafe.variable "JSON") 81 | "stringify" 82 | (match indent with 83 | | None -> 84 | [| Js.Unsafe.inject obj |] 85 | | Some indent -> 86 | [| Js.Unsafe.inject obj ; 87 | Js.Unsafe.inject Js.null ; 88 | Js.Unsafe.inject indent |]) 89 | 90 | let parse_js_string jsstr = 91 | Js.Unsafe.meth_call 92 | (Js.Unsafe.variable "JSON") 93 | "parse" 94 | [| Js.Unsafe.inject jsstr |] 95 | 96 | let stringify ?indent obj = 97 | Js.to_string (js_stringify ?indent obj) 98 | 99 | let parse str = 100 | parse_js_string (Js.string str) 101 | 102 | module Json_encoding = Json_encoding.Make (Repr) 103 | module Json_query = Json_query.Make (Repr) 104 | -------------------------------------------------------------------------------- /src/json_repr_browser.mli: -------------------------------------------------------------------------------- 1 | (** Native browser representation of JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | (** An abstract type for native browser objects. *) 21 | type value 22 | 23 | (** A view over the browser representation.*) 24 | module Repr : Json_repr.Repr with type value = value 25 | 26 | (** Pre-instanciated {!Json_encoding.Make}. *) 27 | module Json_encoding : module type of Json_encoding.Make (Repr) 28 | 29 | (** Pre-instanciated {!Json_encoding.Make}. *) 30 | module Json_query : module type of Json_query.Make (Repr) 31 | 32 | (** Parse a JSON string using the native browser parser. *) 33 | val parse : string -> value 34 | 35 | (** Produce a JSON string using the native browser printer. 36 | 37 | If indent is not present, everything is printed on a single line. 38 | Otherwise, it is the number (up to 10) of spaces inserted at 39 | beginning of lines for each indentation level. *) 40 | val stringify : ?indent: int -> value -> string 41 | 42 | (** Same as {!parse} with native browser strings. *) 43 | val parse_js_string : Js.js_string Js.t -> value 44 | 45 | (** Same as {!stringify} with native browser strings. *) 46 | val js_stringify : ?indent: int -> value -> Js.js_string Js.t 47 | -------------------------------------------------------------------------------- /src/json_repr_bson.ml: -------------------------------------------------------------------------------- 1 | (* Representations of JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | open Json_repr 21 | 22 | module Repr = struct 23 | type serialized = 24 | { buffer : bytes ; 25 | offset : int ; 26 | length : int ; 27 | array_field : bool } 28 | and deserialized = 29 | [ `O of (string * value) list 30 | | `A of value list 31 | | `Bool of bool 32 | | `Float of float 33 | | `String of string 34 | | `Null ] 35 | and node = 36 | | Deserialized of deserialized 37 | | Serialized of serialized 38 | | Both of deserialized * serialized 39 | and value = 40 | { mutable node : node ; 41 | conforming : bool ; (* when lazily deserializing the root *) 42 | cache : bool (* when lazily deserializing *) } 43 | 44 | module LEB = EndianBytes.LittleEndian_unsafe 45 | 46 | exception Bson_decoding_error of string * bytes * int 47 | 48 | let view root = 49 | match root.node with 50 | | Deserialized deserialized 51 | | Both (deserialized, _) -> deserialized 52 | | Serialized ({ buffer ; offset ; length ; array_field } as serialized) -> 53 | let offset = ref offset in 54 | let length = ref length in 55 | let error fmt = 56 | Format.ksprintf 57 | (fun msg -> raise (Bson_decoding_error (msg, buffer, !offset))) 58 | fmt in 59 | let box node = 60 | { node ; conforming = false ; cache = root.cache } in 61 | let skip n = 62 | offset := !offset + n ; 63 | length := !length - n in 64 | let read_float () = 65 | if !length < 8 then 66 | error "not enough data, double expected (8 bytes)" ; 67 | let res = LEB.get_double buffer !offset in 68 | skip 8 ; 69 | res in 70 | let read_string () = 71 | if !length < 4 then 72 | error "not enough data, string size tag expected (4 bytes)" ; 73 | let strlen = Int32.to_int (LEB.get_int32 buffer !offset) - 1 in 74 | skip 4 ; 75 | if !length < strlen then 76 | error "not enough data, string expected (%d bytes)" strlen ; 77 | let res = Bytes.sub_string buffer !offset strlen in 78 | skip strlen ; 79 | if !length < 1 then 80 | error "not enough data, string terminator expected (0x00)" ; 81 | if LEB.get_int8 buffer !offset <> 0x00 then 82 | error "string terminator expected (0x00)" ; 83 | skip 1 ; 84 | res in 85 | let read_bool () = 86 | if !length < 1 then 87 | error "not enough data, bool expected (1 byte)" ; 88 | let res = match LEB.get_int8 buffer !offset with 89 | | 0x00 -> false 90 | | 0x01 -> true 91 | | byte -> error "invalid bool value (0x%02X)" byte in 92 | skip 1 ; 93 | res in 94 | let read_field_name () = 95 | let rec find_terminator len = 96 | if !length = 0 then 97 | error "not enough data, field name terminator expected (0x00)" ; 98 | match LEB.get_int8 buffer !offset with 99 | | 0x00 -> 100 | skip (-len) ; 101 | len 102 | | _ -> 103 | skip 1 ; 104 | find_terminator (len + 1) in 105 | let fieldlen = find_terminator 0 in 106 | let res = Bytes.sub_string buffer !offset fieldlen in 107 | skip (fieldlen + 1) ; 108 | res in 109 | let deserialized = 110 | if !length < 5 then 111 | error "not enough data for size and terminator" ; 112 | let size = Int32.to_int (LEB.get_int32 buffer !offset) in 113 | if size <> !length then 114 | error "size tag inconsistent with actual data" ; 115 | skip 4 ; 116 | let tag = LEB.get_int8 buffer !offset in 117 | if tag = 0x00 then begin 118 | if !length = 1 then 119 | `O [] 120 | else 121 | error "early terminator" ; 122 | end else if not root.conforming && tag land 0xF0 = 0x80 then begin 123 | skip 1 ; 124 | let res = match tag land 0x0F with 125 | | 0x01 -> `Float (read_float ()) 126 | | 0x02 -> `String (read_string ()) 127 | | 0x08 -> `Bool (read_bool ()) 128 | | 0x0A -> `Null 129 | | tag -> 130 | error "unknown immediate tag (0x%02X)" tag in 131 | if !length <> 1 then 132 | error "not enough data, terminator expected (0x00)" ; 133 | if LEB.get_int8 buffer !offset <> 0x00 then 134 | error "terminator expected (0x00)" ; 135 | skip 1 ; 136 | res 137 | end else begin 138 | let rec loop acc = 139 | let tag = LEB.get_int8 buffer !offset in 140 | if tag = 0x00 then 141 | if !length = 1 then 142 | if array_field then 143 | try 144 | let rec to_array acc i = function 145 | | [] -> `A (List.rev acc) 146 | | (name, bson) :: rest -> 147 | if name = string_of_int i then 148 | to_array (bson :: acc) (i + 1) rest 149 | else raise Exit in 150 | to_array [] 0 (List.rev acc) 151 | with Exit -> 152 | error "invalid field names for array field" 153 | else 154 | `O (List.rev acc) 155 | else 156 | error "early terminator" 157 | else begin 158 | skip 1 ; 159 | match tag with 160 | | 0x01 -> 161 | let name = read_field_name () in 162 | loop ((name, box (Deserialized (`Float (read_float ())))) :: acc) 163 | | 0x02 -> 164 | let name = read_field_name () in 165 | loop ((name, box (Deserialized (`String (read_string ())))) :: acc) 166 | | 0x08 -> 167 | let name = read_field_name () in 168 | loop ((name, box (Deserialized (`Bool (read_bool ())))) :: acc) 169 | | 0x0A -> 170 | let name = read_field_name () in 171 | loop ((name, box (Deserialized (`Null))) :: acc) 172 | | 0x03 | 0x04 -> 173 | let name = read_field_name () in 174 | if !length < 4 then 175 | error "not enough data, subdocument size tag expected (4 bytes)" ; 176 | let doclen = Int32.to_int (LEB.get_int32 buffer !offset) in 177 | if !length < doclen then 178 | error "not enough data, subdocument expected (%d bytes)" doclen ; 179 | let serialized = 180 | { buffer ; length = doclen ; offset = !offset ; 181 | array_field = (tag = 0x04) } in 182 | skip doclen ; 183 | loop ((name, box (Serialized serialized)) :: acc) 184 | | tag -> 185 | error "unknown tag (0x%02X)" tag 186 | end in 187 | loop [] 188 | end in 189 | if root.cache then begin 190 | root.node <- Both (deserialized, serialized) 191 | end else begin 192 | root.node <- Deserialized deserialized 193 | end ; 194 | deserialized 195 | 196 | let repr deserialized = 197 | { node = (Deserialized deserialized) ; 198 | conforming = false ; 199 | cache = true } 200 | 201 | let to_bytes ~cache ~conforming root = 202 | match root.node with 203 | | Serialized serialized 204 | | Both (_, serialized) -> 205 | if serialized.offset = 0 206 | && serialized.length = Bytes.length serialized.buffer then 207 | serialized.buffer 208 | else 209 | Bytes.sub serialized.buffer serialized.offset serialized.length 210 | | Deserialized _ -> 211 | let rec compute_size bson = 212 | match bson.node with 213 | | Serialized { length } 214 | | Both (_, { length }) -> 215 | length 216 | | Deserialized deserialized -> 217 | match deserialized with 218 | | `Float _ -> 4 + 1 + 8 + 1 219 | | `String str -> 4 + 1 + 4 + String.length str + 1 + 1 220 | | `Bool _ -> 4 + 1 + 1 + 1 221 | | `Null -> 4 + 1 + 1 222 | | `O fields -> 223 | let acc = List.fold_left 224 | (fun acc (name, bson) -> 225 | let self = match view bson with 226 | | `Float _ -> 8 227 | | `String str -> 4 + String.length str + 1 228 | | `Bool _ -> 1 229 | | `Null -> 0 230 | | `O _ | `A _ -> compute_size bson in 231 | acc + 1 + String.length name + 1 + self) 232 | 0 fields in 233 | 4 + acc + 1 234 | | `A cells -> 235 | let acc, _ = List.fold_left 236 | (fun (acc, i) bson -> 237 | let self = match view bson with 238 | | `Float _ -> 8 239 | | `String str -> 4 + String.length str + 1 240 | | `Bool _ -> 1 241 | | `Null -> 0 242 | | `O _ | `A _ -> compute_size bson in 243 | let rec digits acc i = 244 | if i <= 9 then (1 + acc) 245 | else digits (1 + acc) (i / 10) in 246 | (acc + 1 + digits 0 i + 1 + self, i + 1)) 247 | (0, 0) cells in 248 | 4 + acc + 1 in 249 | let computed_size = compute_size root in 250 | let result = Bytes.create computed_size in 251 | let pos = ref 0 in 252 | let (+=) r i = r := !r + i in 253 | let reserve_size_stamp () = 254 | let offset = !pos in 255 | pos += 4 ; 256 | fun () -> 257 | LEB.set_int8 result !pos 0x00 ; 258 | pos += 1 ; 259 | let size = Int32.of_int (!pos - offset) in 260 | LEB.set_int32 result offset size in 261 | let rec serialize_toplevel conforming = function 262 | | `Float _ | `String _ | `Bool _ | `Null | `A _ when conforming -> 263 | raise (Invalid_argument "Json_repr.bson_to_bytes") 264 | | `Float f -> 265 | let update_size_stamp = reserve_size_stamp () in 266 | LEB.set_int8 result !pos 0x81 ; 267 | pos += 1 ; 268 | LEB.set_double result !pos f ; 269 | pos += 8 ; 270 | update_size_stamp () 271 | | `String str -> 272 | let update_size_stamp = reserve_size_stamp () in 273 | LEB.set_int8 result !pos 0x82 ; 274 | pos += 1 ; 275 | let strlen = String.length str in 276 | LEB.set_int32 result !pos Int32.(of_int (strlen + 1)) ; 277 | pos += 4 ; 278 | Bytes.blit_string str 0 result !pos strlen ; 279 | pos += strlen ; 280 | LEB.set_int8 result !pos 0x00 ; 281 | pos += 1 ; 282 | update_size_stamp () 283 | | `Bool b -> 284 | let update_size_stamp = reserve_size_stamp () in 285 | LEB.set_int8 result !pos 0x88 ; 286 | pos += 1 ; 287 | LEB.set_int8 result !pos (if b then 0x01 else 0x00) ; 288 | pos += 1 ; 289 | update_size_stamp () 290 | | `Null -> 291 | let update_size_stamp = reserve_size_stamp () in 292 | LEB.set_int8 result !pos 0x8A ; 293 | pos += 1 ; 294 | update_size_stamp () 295 | | `O _ | `A _ as fields_or_cells -> 296 | let fields = match fields_or_cells with 297 | | `O fields -> fields 298 | | `A cells -> List.mapi (fun i v -> string_of_int i, v) cells in 299 | let update_size_stamp = reserve_size_stamp () in 300 | serialize_fields fields ; 301 | update_size_stamp () 302 | and serialize_fields fields = 303 | List.iter 304 | (fun (name, bson) -> 305 | LEB.set_int8 result !pos 306 | (match view bson with 307 | | `Float _ -> 0x01 308 | | `String _ -> 0x02 309 | | `Bool _ -> 0x08 310 | | `Null -> 0x0A 311 | | `O _ -> 0x03 ; 312 | | `A _ -> 0x04) ; 313 | pos += 1 ; 314 | let strlen = String.length name in 315 | Bytes.blit_string name 0 result !pos strlen ; 316 | pos += strlen ; 317 | LEB.set_int8 result !pos 0x00 ; 318 | pos += 1 ; 319 | begin match view bson with 320 | | `Float f -> 321 | LEB.set_double result !pos f ; 322 | pos += 8 ; 323 | | `String str -> 324 | let strlen = String.length str in 325 | LEB.set_int32 result !pos Int32.(of_int (strlen + 1)) ; 326 | pos += 4 ; 327 | Bytes.blit_string str 0 result !pos strlen ; 328 | pos += strlen ; 329 | LEB.set_int8 result !pos 0x00 ; 330 | pos += 1 ; 331 | | `Bool b -> 332 | LEB.set_int8 result !pos (if b then 0x01 else 0x00) ; 333 | pos += 1 ; 334 | | `Null -> () 335 | | `O _ | `A _ -> serialize false bson 336 | end) 337 | fields 338 | and serialize conforming bson = 339 | match bson.node with 340 | | Serialized { buffer ; offset ; length } 341 | | Both (_, { buffer ; offset ; length }) -> 342 | Bytes.blit buffer offset result !pos length ; 343 | pos := !pos + length 344 | | Deserialized deserialized -> 345 | let offset = !pos in 346 | serialize_toplevel conforming deserialized ; 347 | let length = !pos - offset in 348 | if cache then begin 349 | let serialized = 350 | let array_field = 351 | match deserialized with `A _ -> true | _ -> false in 352 | { buffer = result ; offset ; length ; array_field } in 353 | bson.node <- Both (deserialized, serialized) 354 | end in 355 | serialize conforming root ; 356 | result 357 | 358 | let from_bytes ~laziness ~cache ~conforming buffer = 359 | let serialized = 360 | { offset = 0 ; length = Bytes.length buffer ; buffer ; 361 | array_field = false } in 362 | let root = 363 | { node = Serialized serialized ; conforming ; cache } in 364 | let rec traverse bson = match view bson with 365 | | `O fields -> List.iter (fun (_, bson) -> traverse bson) fields 366 | | `A cells -> List.iter traverse cells 367 | | `Float _ | `String _ | `Bool _ | `Null -> () in 368 | if not laziness then begin 369 | (* a simple traversal will expand the structure as a side effect *) 370 | traverse root 371 | end ; 372 | root 373 | 374 | let repr_uid : value Json_repr.repr_uid = repr_uid () 375 | 376 | end 377 | 378 | type bson = Repr.value 379 | 380 | exception Bson_decoding_error = Repr.Bson_decoding_error 381 | 382 | let bson_to_bytes ?(cache = true) ?(conforming = false) bson = 383 | Repr.to_bytes ~cache ~conforming bson 384 | 385 | let bytes_to_bson ?(laziness = true) ?(cache = true) ?(conforming = false) ~copy buffer = 386 | let buffer = if copy then Bytes.copy buffer else buffer in 387 | Repr.from_bytes ~laziness ~cache ~conforming buffer 388 | 389 | module Json_encoding = Json_encoding.Make (Repr) 390 | module Json_query = Json_query.Make (Repr) 391 | -------------------------------------------------------------------------------- /src/json_repr_bson.mli: -------------------------------------------------------------------------------- 1 | (** BSON representation of JSON documents *) 2 | 3 | (************************************************************************) 4 | (* ocplib-json-typed *) 5 | (* *) 6 | (* Copyright 2014 OCamlPro *) 7 | (* *) 8 | (* This file is distributed under the terms of the GNU Lesser General *) 9 | (* Public License as published by the Free Software Foundation; either *) 10 | (* version 2.1 of the License, or (at your option) any later version, *) 11 | (* with the OCaml static compilation exception. *) 12 | (* *) 13 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU General Public License for more details. *) 17 | (* *) 18 | (************************************************************************) 19 | 20 | (** A intermediate representation for BSON, a binary encoding for JSON. 21 | 22 | Decoding and encoding is (optionally) done as lazily as possible. 23 | First, the [view] function is able to unfold only one 24 | level and not the whole structure. Also, serialized versions are 25 | cached, so that later serializations of the same object are faster. 26 | 27 | Notes: 28 | 29 | 1. Only JSON compatible BSON documents are supported. 30 | BSON extensions are not supported (int32, int64, timestamp, etc.). 31 | 2. Arrays in BSON are stored inefficiently. 32 | Prefer another binary format if you manipulate lots of arrays. 33 | 3. We differ from BSON to allow toplevel immediates. 34 | For this, we produce a document with only one byte indicating 35 | the kind of immediate followed by the immediate. 36 | The byte is [0x80 lor (the corresponding BSON field kind)]. 37 | 4. We differ from BSON to allow unambiguous toplevel arrays. 38 | As with (3), the subdocument to be decoded as an array is 39 | preceded with a 0x84. 40 | 41 | Use the [conforming] flag to deactivates the extension from notes (3) 42 | and (4). In this case, the toplevel value must be an object. *) 43 | type bson 44 | 45 | (** A view over the {!bson} representation.*) 46 | module Repr : Json_repr.Repr with type value = bson 47 | 48 | (** Pre-instanciated {!Json_encoding.Make}. *) 49 | module Json_encoding : module type of Json_encoding.Make (Repr) 50 | 51 | (** Pre-instanciated {!Json_encoding.Make}. *) 52 | module Json_query : module type of Json_query.Make (Repr) 53 | 54 | 55 | (** Serializes the intermediate BSON representation to actual BSON. 56 | 57 | By default, [conforming] is [false], so that any value can be serialized, 58 | including immediates (see {!type:bson}). 59 | 60 | By default, [cache] is [true], so a future serialization of the 61 | same data will be faster. The resulting bytes are stored in the 62 | value. You may want to turn this off if these values have a long 63 | lifespan, and that you care more about memory consumption than 64 | serialization speed. 65 | 66 | Will raise [Invalid_argument "Json_repr.bson_to_bytes"] when 67 | [conforming] and trying to serialize a toplevel array or immediate. *) 68 | val bson_to_bytes : 69 | ?cache: bool -> ?conforming: bool -> 70 | bson -> bytes 71 | 72 | (** Bson decoding error, with a message, the BSON and an offset. *) 73 | exception Bson_decoding_error of string * bytes * int 74 | 75 | (** Creates a lazily unfolded representation for some BSON. 76 | Because of the mutability of [bytes] and this laziness, 77 | set the copy parameter to [true] if you are not sure that the 78 | [bytes] will not be mutated in the future. 79 | 80 | By default, [conforming] is [false], so that any value can be serialized, 81 | including immediates (see {!type:bson}). 82 | 83 | By default, [cache] is [true], so a future serialization of the 84 | same data will be faster. The input bytes are stored in the 85 | value. You may want to turn this off if these values have a long 86 | lifespan, and that you care more about memory consumption than 87 | serialization speed. 88 | 89 | By default, [laziness] is [true]. If the data is a serialized 90 | object, it means that only the field names are read, the field 91 | values are eluded, and will be deserialized on demand when calling 92 | [Repr.view]. This implies that {!Bson_decoding_error} may be 93 | raised later. If set to [false], the whole structure is decoded 94 | upfront, so any decoding error will happen at this point. This may 95 | be preferable mostly when reading from untusted sources. 96 | 97 | May raise {!Bson_decoding_error}. *) 98 | val bytes_to_bson : 99 | ?laziness: bool -> ?cache: bool -> ?conforming: bool -> 100 | copy: bool -> bytes -> bson 101 | -------------------------------------------------------------------------------- /src/json_schema.mli: -------------------------------------------------------------------------------- 1 | (** Abstract representation of JSON schemas as of version 2 | [http://json-schema.org/draft-04/schema#]. *) 3 | 4 | (************************************************************************) 5 | (* ocplib-json-typed *) 6 | (* *) 7 | (* Copyright 2014 OCamlPro *) 8 | (* *) 9 | (* This file is distributed under the terms of the GNU Lesser General *) 10 | (* Public License as published by the Free Software Foundation; either *) 11 | (* version 2.1 of the License, or (at your option) any later version, *) 12 | (* with the OCaml static compilation exception. *) 13 | (* *) 14 | (* ocplib-json-typed is distributed in the hope that it will be useful,*) 15 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 16 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 17 | (* GNU General Public License for more details. *) 18 | (* *) 19 | (************************************************************************) 20 | 21 | (** {2 Abstract representation of schemas} *) (******************************) 22 | 23 | (** A JSON schema root. *) 24 | type schema 25 | 26 | (** A node in the schema, embeds all type-agnostic specs. *) 27 | and element = 28 | { title : string option ; 29 | (** An optional short description. *) 30 | description : string option ; 31 | (** An optional long description. *) 32 | default : Json_repr.any option ; 33 | (** A default constant to be substituted in case of a missing value. *) 34 | enum : Json_repr.any list option ; 35 | (** A valid value must equal one of these constants. *) 36 | kind : element_kind ; 37 | (** The type-specific part. *) 38 | format : string option ; 39 | (** predefined formats such as [date-time], [email], [ipv4], [ipv6], [uri]. *) 40 | id : string option 41 | (** An optional ID. *) } 42 | 43 | (** The type-specific part of schema nodes. *) 44 | and element_kind = 45 | | Object of object_specs 46 | (** The type of an object. *) 47 | | Array of element list * array_specs 48 | (** An fixed-length array with the types of its elements (a tuple). *) 49 | | Monomorphic_array of element * array_specs 50 | (** A variable-length array with the type of its children. *) 51 | | Combine of combinator * element list 52 | (** A mix of schemas using logical combinators. *) 53 | | Def_ref of Json_query.path 54 | (** A ref to an element from its path in the JSON representation. *) 55 | | Id_ref of string 56 | (** A ref to an element from its ID. *) 57 | | Ext_ref of Uri.t 58 | (** A ref to an external element. *) 59 | | String of string_specs 60 | (** A string (with optional characteristics). *) 61 | | Integer of numeric_specs 62 | (** An int (with optional characteristics). *) 63 | | Number of numeric_specs 64 | (** A float (with optional characteristics). *) 65 | | Boolean (** Any boolean. *) 66 | | Null (** The null value. *) 67 | | Any (** Any JSON value. *) 68 | | Dummy 69 | (** For building cyclic definitions, a definition bound to a dummy 70 | will be considered absent for {!add_definition} but present 71 | for {!update}. The idea is to insert a dummy definition, build a 72 | cyclic structure using it for recursion, and finally update the 73 | definition with the structure. *) 74 | 75 | (** Grammar combinators. *) 76 | and combinator = 77 | | Any_of (** Logical OR n-ary combinator. *) 78 | | One_of (** Logical XOR n-ary combinator. *) 79 | | All_of (** Logical AND n-ary combinator. *) 80 | | Not (** Logical NOT unary combinator. *) 81 | 82 | (** Parameters of the [Array] and [MonomorphicArray] type specifiers. *) 83 | and array_specs = 84 | { min_items : int ; 85 | (** The minimum number of elements. *) 86 | max_items : int option ; 87 | (** The maximum number of elements. *) 88 | unique_items : bool ; 89 | (** Teels if all elements must be different. *) 90 | additional_items : element option ; 91 | (** The type of additional items, if allowed. *) } 92 | 93 | (** Parameters of the [Integer] and [Number] type specifiers. *) 94 | and numeric_specs = 95 | { multiple_of : float option ; 96 | (** An optional divisor of valid values *) 97 | minimum : (float * [ `Inclusive | `Exclusive ]) option ; 98 | (** The optional lower bound of the numeric range *) 99 | maximum : (float * [ `Inclusive | `Exclusive ]) option 100 | (** The optional upper bound of the numeric range *) } 101 | 102 | (** Parameters of the [Object] type specifier. *) 103 | and object_specs = 104 | { properties : (string * element * bool * Json_repr.any option) list ; 105 | (** The names and types of properties, with a flag to indicate if 106 | they are required ([true]) or optional. *) 107 | pattern_properties : (string * element) list ; 108 | (** Alternative definition of properties, matching field names 109 | using regexps instead of constant strings. *) 110 | additional_properties : element option ; 111 | (** The type of additional properties, if allowed. *) 112 | min_properties : int ; 113 | (** The minimum number of properties. *) 114 | max_properties : int option ; 115 | (** The maximum number of properties. *) 116 | schema_dependencies : (string * element) list ; 117 | (** Additional schemas the value must verify if a property is 118 | present (property, additional schema). *) 119 | property_dependencies : (string * string list) list 120 | (** Additional properties required whenever some property is 121 | present (property, additional properties). *) } 122 | 123 | (** Parameters of the [String] type specifier. *) 124 | and string_specs = 125 | { pattern : string option ; 126 | (** A regexp the string must conform to. *) 127 | min_length : int ; 128 | (** The minimum string length. *) 129 | max_length : int option 130 | (** The maximum string length. *) } 131 | 132 | (** {2 Combinators to build schemas and elements} *) (*************************) 133 | 134 | (** Construct a naked element (all optional properties to None). *) 135 | val element : element_kind -> element 136 | 137 | (** Construct a schema from its root, without any definition ; the 138 | element is checked not to contain any [Def] element. *) 139 | val create : element -> schema 140 | 141 | (** Extract the root element from an existing schema. *) 142 | val root : schema -> element 143 | 144 | (** Update a schema from its root, using the definitions from an 145 | existing schema ; the element is checked to contain only valid 146 | [Def] elements ; unused definitions are kept, see {!simplify}. *) 147 | val update : element -> schema -> schema 148 | 149 | (** Describes the implemented schema specification as a schema. *) 150 | val self : schema 151 | 152 | (** A completely generic schema, without any definition. *) 153 | val any : schema 154 | 155 | (** Combines several schemas. *) 156 | val combine : combinator -> schema list -> schema 157 | 158 | (** Tells is a schema accepts null. *) 159 | val is_nullable : schema -> bool 160 | 161 | (** {2 Named definitions} *) (***********************************************) 162 | 163 | (** Merges the definitions of two schemas if possible and returns the 164 | updated schemas, so that their elements can be mixed without 165 | introducing dangling references ; if two different definitions are 166 | bound to the same path, {!Duplicate_definition} will be raised. *) 167 | val merge_definitions : schema * schema -> schema * schema 168 | 169 | (** Remove the definitions that are not present in the schema. *) 170 | val simplify : schema -> schema 171 | 172 | (** Adds a definition by its path. If the path is absolute (starting 173 | with a ['/']), it is untouched. Otherwise, it is considered 174 | relative to ["#/definitions"] as recommended by the standard. May 175 | raise {!Duplicate_definition} if this path is already used or any 176 | error raised by {!Json_repr.path_of_json_pointer} with 177 | [~wildcards:false]. Returns the modified schema and the [Def_ref] 178 | node that references this definition to be used in the schema. *) 179 | val add_definition : ?definitions_path:string -> string -> element -> schema -> schema * element 180 | 181 | (** Finds a definition by its path, may raise [Not_found]. 182 | See {!add_definition} for the name format.*) 183 | val find_definition : ?definitions_path:string -> string -> schema -> element 184 | 185 | (** Tells if a path leads to a definition. 186 | See {!add_definition} for the name format. *) 187 | val definition_exists : ?definitions_path:string -> string -> schema -> bool 188 | 189 | (** Build a reference to a definition. 190 | See {!add_definition} for the name format. *) 191 | val definition_ref : ?definitions_path:string -> string -> element 192 | 193 | (** {2 Predefined values} *) (***********************************************) 194 | 195 | (** Default Parameters of the [Array] and [MonomorphicArray] type specifiers. *) 196 | val array_specs : array_specs 197 | 198 | (** Default parameters of the [Object] type specifier. *) 199 | val object_specs : object_specs 200 | 201 | (** Default parameters of the [String] type specifier. *) 202 | val string_specs : string_specs 203 | 204 | (** Default parameters of the [Integer] and [Number] type specifiers. *) 205 | val numeric_specs : numeric_specs 206 | 207 | (** {2 JSON Serialization} *) (*********************************************) 208 | 209 | (** Formats a JSON schema as its JSON representation. 210 | 211 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 212 | format. See functor {!Make} for using another representation. *) 213 | val to_json : schema -> Json_repr.ezjsonm 214 | 215 | (** Parse a JSON structure as a JSON schema, if possible. 216 | May throw {!Cannot_parse}. 217 | 218 | This function works with JSON data represented in the {!Json_repr.ezjsonm} 219 | format. See functor {!Make} for using another representation. *) 220 | val of_json : Json_repr.ezjsonm -> schema 221 | 222 | (** Formats a JSON schema in human readable format. *) 223 | val pp : Format.formatter -> schema -> unit 224 | 225 | (** {2 Errors} *) (**********************************************************) 226 | 227 | (** An error happened during parsing. 228 | May box one of the following exceptions, among others.. *) 229 | exception Cannot_parse of Json_query.path * exn 230 | 231 | (** A reference to a non-existent location was detected. *) 232 | exception Dangling_reference of Uri.t 233 | 234 | (** A reference litteral could not be understood. *) 235 | exception Bad_reference of string 236 | 237 | (** An unexpected kind of JSON value was encountered. *) 238 | exception Unexpected of string * string 239 | 240 | (** A non-[Dummy] definition appeared twice on insertion or merge. *) 241 | exception Duplicate_definition of Json_query.path * element * element 242 | 243 | (** Produces a human readable version of an error. *) 244 | val print_error 245 | : ?print_unknown: (Format.formatter -> exn -> unit) -> 246 | Format.formatter -> exn -> unit 247 | 248 | (** {2 Advanced interface for using a custom JSON representation} *) (**********) 249 | 250 | module Make (Repr : Json_repr.Repr) : sig 251 | 252 | (** Same as {!to_json} for a custom JSON representation. *) 253 | val to_json : schema -> Repr.value 254 | 255 | (** Same as {!of_json} for a custom JSON representation. *) 256 | val of_json : Repr.value -> schema 257 | 258 | end 259 | --------------------------------------------------------------------------------