diff --git a/vendors/ocplib-json-typed/LICENSE b/vendors/ocplib-json-typed/LICENSE new file mode 100644 index 000000000..66026b6e7 --- /dev/null +++ b/vendors/ocplib-json-typed/LICENSE @@ -0,0 +1,859 @@ +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Library General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed by the copyright +holder, or a modified version of the Library that is distributed under +the conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + + + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. + + +------------------------------------------------------------------------ + + + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/vendors/ocplib-json-typed/Makefile b/vendors/ocplib-json-typed/Makefile new file mode 100644 index 000000000..681368287 --- /dev/null +++ b/vendors/ocplib-json-typed/Makefile @@ -0,0 +1,11 @@ +all: + jbuilder build @install @runtest --dev + +install: + jbuilder install + +uninstall: + jbuilder uninstall + +clean: + rm -rf _build *~ */*~ diff --git a/vendors/ocplib-json-typed/README.md b/vendors/ocplib-json-typed/README.md new file mode 100644 index 000000000..147d7858b --- /dev/null +++ b/vendors/ocplib-json-typed/README.md @@ -0,0 +1,35 @@ +# ocplib-json-typed + +This library is a collection of type-aware JSON utilities for OCaml. + + - `Json_encoding` contains an `'a encoding` type that represents + the JSON encoding of OCaml values of type `'a`, and a collection + of combinators to build them. These encodings can be used to + serialize / deserialize OCaml values to / from JSON + documents. JSON schemas can also be generated automatically to + produce documented, interoperable JSON formats. + - `Json_schema` contains an OCaml intermediate representation for + the JSON schema document grammar description language, along with + translators to / from the concrete JSON schema format. + - `Json_query` contains various utilities to manipulate, introspect + and update JSON data. + - `Json_repr` defines an abstraction over JSON representations. + This module is mainly useful when using the functorial interface of + the library, or if you use several JSON libraries in your program + and want to convert data from one JSON representation to another. + +The type of JSON documents handled by this library is directly +compatible with `ezjsonm`, but converters are provided for `yojson` +users, and an advanced functorial interface allows you to use any JSON +representation. Two other representations are also provided. + + - `Json_repr_browser` interfaces JavaScripts objects. It is + available only when compiling to JavaScript via + `js_of_ocaml`. + Provided by the extra package `ocplib-json-typed-browser`. + - `Json_repr_bson` is an implementation of a subset of BSON. + Provided by the extra package `ocplib-json-typed-bson`. + +Thanks to polymorphic variants, this library does not depend on any +JSON library, so you are free to use whichever you want for printing +and parsing. diff --git a/vendors/ocplib-json-typed/ocplib-json-typed-browser.opam b/vendors/ocplib-json-typed/ocplib-json-typed-browser.opam new file mode 100644 index 000000000..7358b1fee --- /dev/null +++ b/vendors/ocplib-json-typed/ocplib-json-typed-browser.opam @@ -0,0 +1,18 @@ +opam-version: "1.2" +name: "ocplib-json-typed-browser" +version: "0.6" +maintainer: "Benjamin Canou " +authors: "Benjamin Canou " +homepage: "https://github.com/ocamlpro/ocplib-json-typed" +bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" +license: "LGPLv3 w/ linking exception" +dev-repo: "https://github.com/ocamlpro/ocplib-json-typed.git" +available: [ ocaml-version >= "4.02.0" ] + +build: [ "jbuilder" "build" "-j" jobs "-p" name "@install" ] +build-test: [ "jbuilder" "runtest" "-p" name "-j" jobs ] +depends: [ + "jbuilder" {build & >= "1.0+beta19.1"} + "ocplib-json-typed" {= "0.6" } + "js_of_ocaml" {>= "3.1.0"} +] diff --git a/vendors/ocplib-json-typed/ocplib-json-typed-bson.opam b/vendors/ocplib-json-typed/ocplib-json-typed-bson.opam new file mode 100644 index 000000000..a6fa1cc1a --- /dev/null +++ b/vendors/ocplib-json-typed/ocplib-json-typed-bson.opam @@ -0,0 +1,18 @@ +opam-version: "1.2" +name: "ocplib-json-typed-bson" +version: "0.6" +maintainer: "Benjamin Canou " +authors: "Benjamin Canou " +homepage: "https://github.com/ocamlpro/ocplib-json-typed" +bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" +license: "LGPLv3 w/ linking exception" +dev-repo: "https://github.com/ocamlpro/ocplib-json-typed.git" +available: [ ocaml-version >= "4.02.0" ] + +build: [ "jbuilder" "build" "-j" jobs "-p" name "@install" ] +build-test: [ "jbuilder" "runtest" "-p" name "-j" jobs ] +depends: [ + "jbuilder" {build & >= "1.0+beta19.1"} + "ocplib-json-typed" {= "0.6" } + "ocplib-endian" {>= "1.0"} +] diff --git a/vendors/ocplib-json-typed/ocplib-json-typed.opam b/vendors/ocplib-json-typed/ocplib-json-typed.opam new file mode 100644 index 000000000..bc0c763ce --- /dev/null +++ b/vendors/ocplib-json-typed/ocplib-json-typed.opam @@ -0,0 +1,17 @@ +opam-version: "1.2" +name: "ocplib-json-typed" +version: "0.6" +maintainer: "Benjamin Canou " +authors: "Benjamin Canou " +homepage: "https://github.com/ocamlpro/ocplib-json-typed" +bug-reports: "https://github.com/ocamlpro/ocplib-json-typed/issues" +license: "LGPLv3 w/ linking exception" +dev-repo: "https://github.com/ocamlpro/ocplib-json-typed.git" +available: [ ocaml-version >= "4.02.0" ] + +build: [ "jbuilder" "build" "-j" jobs "-p" name "@install" ] +build-test: [ "jbuilder" "runtest" "-p" name "-j" jobs ] +depends: [ + "jbuilder" {build & >= "1.0+beta19.1"} + "uri" {>= "1.9.0" } +] diff --git a/vendors/ocplib-json-typed/src/jbuild b/vendors/ocplib-json-typed/src/jbuild new file mode 100644 index 000000000..e92299959 --- /dev/null +++ b/vendors/ocplib-json-typed/src/jbuild @@ -0,0 +1,28 @@ +(jbuild_version 1) + +(library + ((name ocplib_json_typed) + (public_name ocplib-json-typed) + (flags (:standard -w -9)) + (modules (json_encoding json_query json_repr json_schema)) + (synopsis "Reliable manipulation of JSON objects") + (libraries (uri)) + (wrapped false))) + +(library + ((name ocplib_json_typed_bson) + (public_name ocplib-json-typed-bson) + (flags (:standard -w -9)) + (modules (json_repr_bson)) + (synopsis "BSON representation of JSON documents") + (libraries (ocplib-json-typed ocplib-endian)) + (wrapped false))) + +(library + ((name ocplib_json_typed_browser) + (public_name ocplib-json-typed-browser) + (flags (:standard -w -9)) + (modules (json_repr_browser)) + (synopsis "Native browser representation of JSON documents") + (libraries (ocplib-json-typed js_of_ocaml)) + (wrapped false))) diff --git a/vendors/ocplib-json-typed/src/json_encoding.ml b/vendors/ocplib-json-typed/src/json_encoding.ml new file mode 100644 index 000000000..eb6508f73 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_encoding.ml @@ -0,0 +1,890 @@ +(* JSON structure description using dependently typed combinators. *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +exception Unexpected of string * string +exception No_case_matched of exn list +exception Bad_array_size of int * int +exception Missing_field of string +exception Unexpected_field of string +exception Bad_schema of exn +exception Cannot_destruct of (Json_query.path * exn) + +(*-- types and errors --------------------------------------------------------*) + +let unexpected kind expected = + let kind = match kind with + | `O [] -> "empty object" + | `A [] -> "empty array" + | `O _ -> "object" + | `A _ -> "array" + | `Null -> "null" + | `String _ -> "string" + | `Float _ -> "number" + | `Bool _ -> "boolean" in + Cannot_destruct ([], Unexpected (kind, expected)) + +type 't repr_agnostic_custom = + { write : 'rt. (module Json_repr.Repr with type value = 'rt) -> 't -> 'rt ; + read : 'rf. (module Json_repr.Repr with type value = 'rf) -> 'rf -> 't } + +(* The GADT definition for encodings. This type must be kept internal + because it does not encode all invariants. Some properties are + checked at encoding construction time by smart constructors, since + checking them would either be impossible, or would make the type + too complex. In a few corners that involve custom encodings using + user defined functions, some properties cannot be checked until + construction/destruction time. If such a run time check fails, is + denotes a programmer error and an [Invalid_argument] exceptions is + thus raised. *) +type _ encoding = + | Null : unit encoding + | Empty : unit encoding + | Ignore : unit encoding + | Option : 'a encoding -> 'a option encoding + | Constant : string -> unit encoding + | Int : 'a int_encoding -> 'a encoding + | Bool : bool encoding + | String : string encoding + | Float : bounds option -> float encoding + | Array : 'a encoding -> 'a array encoding + | Obj : 'a field -> 'a encoding + | Objs : 'a encoding * 'b encoding -> ('a * 'b) encoding + | Tup : 'a encoding -> 'a encoding + | Tups : 'a encoding * 'b encoding -> ('a * 'b) encoding + | Custom : 't repr_agnostic_custom * Json_schema.schema -> 't encoding + | Conv : ('a -> 'b) * ('b -> 'a) * 'b encoding * Json_schema.schema option -> 'a encoding + | Describe : string option * string option * 'a encoding -> 'a encoding + | Mu : string * ('a encoding -> 'a encoding) -> 'a encoding + | Union : 't case list -> 't encoding + +and 'a int_encoding = + { int_name : string ; + of_float : float -> 'a ; + to_float : 'a -> float ; + lower_bound : 'a ; + upper_bound : 'a } + +and bounds = + { float_name : string ; + minimum : float ; + maximum : float } + +and _ field = + | Req : string * 'a encoding -> 'a field + | Opt : string * 'a encoding -> 'a option field + | Dft : string * 'a encoding * 'a -> 'a field + +and 't case = + | Case : 'a encoding * ('t -> 'a option) * ('a -> 't) -> 't case + +(*-- construct / destruct / schema over the main GADT forms ------------------*) + +module Make (Repr : Json_repr.Repr) = struct + + let construct enc v = + let rec construct + : type t. t encoding -> t -> Repr.value + = function + | Null -> (fun () -> Repr.repr `Null) + | Empty -> (fun () -> Repr.repr (`O [])) + | Ignore -> (fun () -> Repr.repr (`O [])) + | Option t -> + (function + | None -> Repr.repr `Null + | Some v -> construct t v) + | Constant str -> (fun () -> Repr.repr (`String str)) + | Int { int_name ; to_float ; lower_bound ; upper_bound } -> + (fun (i : t) -> + if i < lower_bound || i > upper_bound then + invalid_arg + ("Json_encoding.construct: " ^ int_name ^ " out of range"); + Repr.repr (`Float (to_float i))) + | Bool -> (fun (b : t) -> Repr.repr (`Bool b)) + | String -> (fun s -> Repr.repr (`String s)) + | Float (Some { minimum ; maximum ; float_name }) -> + let err = "Json_encoding.construct: " ^ float_name ^ " out of range" in + (fun float -> + if float < minimum || float > maximum then invalid_arg err ; + Repr.repr (`Float float)) + | Float None -> (fun float -> Repr.repr (`Float float)) + | Describe (_, _, t) -> construct t + | Custom ({ write }, _) -> (fun (j : t) -> write (module Repr) j) + | Conv (ffrom, _, t, _) -> (fun v -> construct t (ffrom v)) + | Mu (name, self) -> construct (self (Mu (name, self))) + | Array t -> + let w v = construct t v in + (fun arr -> Repr.repr (`A (Array.to_list (Array.map w arr)))) + | Obj (Req (n, t)) -> + let w v = construct t v in + (fun v -> Repr.repr (`O [ n, w v ])) + | Obj (Dft (n, t, d)) -> + let w v = construct t v in + (fun v -> Repr.repr (`O (if v <> d then [ n, w v ] else []))) + | Obj (Opt (n, t)) -> + let w v = construct t v in + (function None -> Repr.repr (`O []) | Some v -> Repr.repr (`O [ n, w v ])) + | Objs (o1, o2) -> + let w1 v = construct o1 v in + let w2 v = construct o2 v in + (function (v1, v2) -> + match Repr.view (w1 v1), Repr.view (w2 v2) with + | `O l1, `O l2 -> Repr.repr (`O (l1 @ l2)) + | `Null, `Null + | _ -> invalid_arg "Json_encoding.construct: consequence of bad merge_objs") + | Tup t -> + let w v = construct t v in + (fun v -> Repr.repr (`A [ w v ])) + | Tups (o1, o2) -> + let w1 v = construct o1 v in + let w2 v = construct o2 v in + (function (v1, v2) -> + match Repr.view (w1 v1), Repr.view (w2 v2) with + | `A l1, `A l2 -> Repr.repr (`A (l1 @ l2)) + | _ -> invalid_arg "Json_encoding.construct: consequence of bad merge_tups") + | Union cases -> + (fun v -> + let rec do_cases = function + | [] -> invalid_arg "Json_encoding.construct: consequence of bad union" + | Case (encoding, fto, _) :: rest -> + match fto v with + | Some v -> construct encoding v + | None -> do_cases rest in + do_cases cases) in + construct enc v + + let rec destruct + : type t. t encoding -> (Repr.value -> t) + = function + | Null -> (fun v -> match Repr.view v with `Null -> () | k -> raise (unexpected k "null")) + | Empty -> (fun v -> match Repr.view v with + | `O [] -> () + | `O [ f, _] -> raise (Cannot_destruct ([], Unexpected_field f)) + | k -> raise @@ unexpected k "an empty object") + | Ignore -> (fun v -> match Repr.view v with _ -> ()) + | Option t -> (fun v -> match Repr.view v with + | `Null -> None + | _ -> Some (destruct t v)) + | Constant str -> + (fun v -> + match Repr.view v with + | `String s when s = str -> () + | x -> raise @@ unexpected x str) + | Int { int_name ; of_float ; to_float ; lower_bound ; upper_bound } -> + let lower_bound = to_float lower_bound in + let upper_bound = to_float upper_bound in + (fun v -> + match Repr.view v with + | `Float v -> + let rest, v = modf v in + if rest <> 0. then begin + let exn = Failure (int_name ^ " cannot have a fractional part") in + raise (Cannot_destruct ([], exn)) + end ; + if v < lower_bound || v > upper_bound then begin + let exn = Failure (int_name ^ " out of range") in + raise (Cannot_destruct ([], exn)) + end ; + of_float v + | k -> raise (unexpected k "number")) + | Bool -> (fun v -> match Repr.view v with `Bool b -> (b : t) | k -> raise (unexpected k "boolean")) + | String -> (fun v -> match Repr.view v with `String s -> s | k -> raise (unexpected k "string")) + | Float None -> (fun v -> match Repr.view v with `Float f -> f | k -> raise (unexpected k "float")) + | Float (Some { minimum ; maximum ; float_name }) -> + (fun v -> + match Repr.view v with + | `Float f -> + if f < minimum || f > maximum + then + let exn = Failure (float_name ^ " out of range") in + raise (Cannot_destruct ([], exn)) + else f + | k -> raise (unexpected k "float")) + | Describe (_, _, t) -> destruct t + | Custom ({ read }, _) -> read (module Repr) + | Conv (_, fto, t, _) -> (fun v -> fto (destruct t v)) + | Mu (name, self) -> destruct (self (Mu (name, self))) + | Array t -> + (fun v -> match Repr.view v with + | `O [] -> + (* Weak `Repr`s like BSON don't know the difference *) + [||] + | `A cells -> + Array.mapi + (fun i cell -> + try destruct t cell with Cannot_destruct (path, err) -> + raise (Cannot_destruct (`Index i :: path, err))) + (Array.of_list cells) + | k -> raise @@ unexpected k "array") + | Obj _ as t -> + let d = destruct_obj t in + (fun v -> match Repr.view v with + | `O fields -> + let r, rest, ign = d fields in + begin match rest with + | (field, _) :: _ when not ign -> raise @@ Unexpected_field field + | _ -> r + end + | k -> raise @@ unexpected k "object") + | Objs _ as t -> + let d = destruct_obj t in + (fun v -> match Repr.view v with + | `O fields -> + let r, rest, ign = d fields in + begin match rest with + | (field, _) :: _ when not ign -> raise @@ Unexpected_field field + | _ -> r + end + | k -> raise @@ unexpected k "object") + | Tup _ as t -> + let r, i = destruct_tup 0 t in + (fun v -> match Repr.view v with + | `A cells -> + let cells = Array.of_list cells in + let len = Array.length cells in + if i <> Array.length cells then + raise (Cannot_destruct ([], Bad_array_size (len, i))) + else r cells + | k -> raise @@ unexpected k "array") + | Tups _ as t -> + let r, i = destruct_tup 0 t in + (fun v -> match Repr.view v with + | `A cells -> + let cells = Array.of_list cells in + let len = Array.length cells in + if i <> Array.length cells then + raise (Cannot_destruct ([], Bad_array_size (len, i))) + else r cells + | k -> raise @@ unexpected k "array") + | Union cases -> + (fun v -> + let rec do_cases errs = function + | [] -> raise (Cannot_destruct ([], No_case_matched (List.rev errs))) + | Case (encoding, _, ffrom) :: rest -> + try ffrom (destruct encoding v) with + err -> do_cases (err :: errs) rest in + do_cases [] cases) + and destruct_tup + : type t. int -> t encoding -> (Repr.value array -> t) * int + = fun i t -> match t with + | Tup t -> + (fun arr -> + (try destruct t arr.(i) with Cannot_destruct (path, err) -> + raise (Cannot_destruct (`Index i :: path, err)))), succ i + | Tups (t1, t2) -> + let r1, i = destruct_tup i t1 in + let r2, i = destruct_tup i t2 in + (fun arr -> r1 arr, r2 arr), i + | Conv (_, fto, t, _) -> + let r, i = destruct_tup i t in + (fun arr -> fto (r arr)), i + | Mu (_, self) as mu -> destruct_tup i (self mu) + | Describe (_, _, enc) -> destruct_tup i enc + | _ -> invalid_arg "Json_encoding.destruct: consequence of bad merge_tups" + and destruct_obj + : type t. t encoding -> (string * Repr.value) list -> t * (string * Repr.value) list * bool + = fun t -> + let rec assoc acc n = function + | [] -> raise Not_found + | (f, v) :: rest when n = f -> v, acc @ rest + | oth :: rest -> assoc (oth :: acc) n rest in + match t with + | Empty -> (fun fields -> (), fields, false) + | Ignore -> (fun fields -> (), fields, true) + | Obj (Req (n, t)) -> + (fun fields -> + try + let v, rest = assoc [] n fields in + destruct t v, rest, false + with + | Not_found -> + raise (Cannot_destruct ([], Missing_field n)) + | Cannot_destruct (path, err) -> + raise (Cannot_destruct (`Field n :: path, err))) + | Obj (Opt (n, t)) -> + (fun fields -> + try + let v, rest = assoc [] n fields in + Some (destruct t v), rest, false + with + | Not_found -> None, fields, false + | Cannot_destruct (path, err) -> + raise (Cannot_destruct (`Field n :: path, err))) + | Obj (Dft (n, t, d)) -> + (fun fields -> + try + let v, rest = assoc [] n fields in + destruct t v, rest, false + with + | Not_found -> d, fields, false + | Cannot_destruct (path, err) -> + raise (Cannot_destruct (`Field n :: path, err))) + | Objs (o1, o2) -> + let d1 = destruct_obj o1 in + let d2 = destruct_obj o2 in + (fun fields -> + let r1, rest, ign1 = d1 fields in + let r2, rest, ign2 = d2 rest in + (r1, r2), rest, ign1 || ign2) + | Conv (_, fto, t, _) -> + let d = destruct_obj t in + (fun fields -> + let r, rest, ign = d fields in + fto r, rest, ign) + | Mu (_, self) as mu -> destruct_obj (self mu) + | Describe (_, _, enc) -> destruct_obj enc + | Union cases -> + (fun fields -> + let rec do_cases errs = function + | [] -> raise (Cannot_destruct ([], No_case_matched (List.rev errs))) + | Case (encoding, _, ffrom) :: rest -> + try + let r, rest, ign = destruct_obj encoding fields in + ffrom r, rest, ign + with err -> do_cases (err :: errs) rest in + do_cases [] cases) + | _ -> invalid_arg "Json_encoding.destruct: consequence of bad merge_objs" + + let custom write read ~schema = + let read + : type tf. (module Json_repr.Repr with type value = tf) -> tf -> 't + = fun (module Repr_f) repr -> + read (Json_repr.convert (module Repr_f) (module Repr) repr) in + let write + : type tf. (module Json_repr.Repr with type value = tf) -> 't -> tf + = fun (module Repr_f) v -> + Json_repr.convert (module Repr) (module Repr_f) (write v) in + Custom ({ read ; write }, schema) +end + +module Ezjsonm_encoding = Make (Json_repr.Ezjsonm) + +let schema encoding = + let open Json_schema in + let sch = ref any in + let rec prod l1 l2 = match l1 with + | [] -> [] + | (l1, b1) :: es -> + List.map (fun (l2, b2) -> l1 @ l2, b1 || b2) l2 + @ prod es l2 in + let rec object_schema + : type t. t encoding -> ((string * element * bool * Json_repr.any option) list * bool) list + = function + | Conv (_, _, o, None) -> object_schema o + | Empty -> [ [], false ] + | Ignore -> [ [], true ] + | Obj (Req (n, t)) -> [ [ n, schema t, true, None ], false ] + | Obj (Opt (n, t)) -> [ [ n, schema t, false, None ], false ] + | Obj (Dft (n, t, d)) -> + let d = Json_repr.repr_to_any (module Json_repr.Ezjsonm) (Ezjsonm_encoding.construct t d) in + [ [ n, schema t, false, Some d], false ] + | Objs (o1, o2) -> + prod (object_schema o1) (object_schema o2) + | Union [] -> + invalid_arg "Json_encoding.schema: empty union in object" + | Union cases -> + List.flatten + (List.map + (fun (Case (o, _, _)) -> object_schema o) + cases) + | Mu (_, self) as mu -> object_schema (self mu) + | Describe (_, _, t) -> object_schema t + | Conv (_, _, _, Some _) (* FIXME: We could do better *) + | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_objs" + and array_schema + : type t. t encoding -> element list + = function + | Conv (_, _, o, None) -> array_schema o + | Tup t -> [ schema t ] + | Tups (t1, t2) -> array_schema t1 @ array_schema t2 + | Mu (_, self) as mu -> array_schema (self mu) + | Describe (_, _, t) -> array_schema t + | Conv (_, _, _, Some _) (* FIXME: We could do better *) + | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_tups" + and schema + : type t. t encoding -> element + = function + | Null -> element Null + | Empty -> element (Object { object_specs with additional_properties = None }) + | Ignore -> element Any + | Option t -> + element (Combine (One_of, [schema t ; element Null])) + | Int { to_float ; lower_bound ; upper_bound } -> + let minimum = Some (to_float lower_bound, `Inclusive) in + let maximum = Some (to_float upper_bound, `Inclusive) in + element (Integer { multiple_of = None ; minimum ; maximum }) + | Bool -> element Boolean + | Constant str -> + { (element (String string_specs)) with + enum = Some [ Json_repr.to_any (`String str) ] } + | String -> element (String string_specs) + | Float (Some { minimum ; maximum }) -> + element (Number { multiple_of = None ; + minimum = Some (minimum, `Inclusive) ; + maximum = Some (maximum, `Inclusive) }) + | Float None -> element (Number numeric_specs) + | Describe (None, None, t) -> schema t + | Describe (Some _ as title, None, t) -> + { (schema t) with title } + | Describe (None, (Some _ as description), t) -> + { (schema t) with description } + | Describe (Some _ as title, (Some _ as description), t) -> + { (schema t) with title ; description } + | Custom (_, s) -> + sch := fst (merge_definitions (!sch, s)) ; + root s + | Conv (_, _, _, Some s) -> + sch := fst (merge_definitions (!sch, s)) ; + root s + | Conv (_, _, t, None) -> schema t + | Mu (name, f) -> + let fake_schema = + if definition_exists name !sch then + update (definition_ref name) !sch + else + let sch, elt = add_definition name (element Dummy) !sch in + update elt sch in + let fake_self = + Custom ({ write = (fun _ _ -> assert false) ; + read = (fun _ -> assert false) }, + fake_schema) in + let root = schema (f fake_self) in + let nsch, def = add_definition name root !sch in + sch := nsch ; def + | Array t -> + element (Monomorphic_array (schema t, array_specs)) + | Objs _ as o -> + begin match object_schema o with + | [ properties, ext ] -> + let additional_properties = if ext then Some (element Any) else None in + element (Object { object_specs with properties ; additional_properties }) + | more -> + let elements = + List.map + (fun (properties, ext) -> + let additional_properties = if ext then Some (element Any) else None in + element (Object { object_specs with properties ; additional_properties })) + more in + element (Combine (One_of, elements)) + end + | Obj _ as o -> + begin match object_schema o with + | [ properties, ext ] -> + let additional_properties = if ext then Some (element Any) else None in + element (Object { object_specs with properties ; additional_properties }) + | more -> + let elements = + List.map + (fun (properties, ext) -> + let additional_properties = if ext then Some (element Any) else None in + element (Object { object_specs with properties ; additional_properties })) + more in + element (Combine (One_of, elements)) + end + | Tup _ as t -> element (Array (array_schema t, array_specs)) + | Tups _ as t -> element (Array (array_schema t, array_specs)) + | Union cases -> (* FIXME: smarter merge *) + let elements = + List.map (fun (Case (encoding, _, _)) -> schema encoding) cases in + element (Combine (One_of, elements)) in + let schema = schema encoding in + update schema !sch + +(*-- utility wrappers over the GADT ------------------------------------------*) + +let req ?title ?description n t = Req (n, Describe (title, description, t)) +let opt ?title ?description n t = Opt (n, Describe (title, description, t)) +let dft ?title ?description n t d = Dft (n, Describe (title, description, t), d) + +let mu name self = Mu (name, self) +let null = Null +let int = + Int { int_name = "int" ; + of_float = int_of_float ; + to_float = float_of_int ; + (* cross-platform consistent OCaml ints *) + lower_bound = -(1 lsl 30) ; + upper_bound = (1 lsl 30) - 1 } +let ranged_int ~minimum:lower_bound ~maximum:upper_bound name = + if Sys.word_size = 64 + && (lower_bound < -(1 lsl 30) + || upper_bound > (1 lsl 30) - 1) then + invalid_arg "Json_encoding.ranged_int: bounds out of portable int31 range" ; + Int { int_name = name ; + of_float = int_of_float ; + to_float = float_of_int ; + lower_bound ; + upper_bound } + +let int53 = + Int { int_name = "int53" ; + of_float = Int64.of_float ; + to_float = Int64.to_float ; + lower_bound = Int64.neg (Int64.shift_left 1L 53) ; + upper_bound = Int64.shift_left 1L 53 } +let ranged_int53 ~minimum:lower_bound ~maximum:upper_bound name = + if lower_bound < Int64.neg (Int64.shift_left 1L 53) + || upper_bound > Int64.shift_left 1L 53 then + invalid_arg "Json_encoding.ranged_int53: bounds out of JSON-representable integers" ; + Int { int_name = name ; + of_float = Int64.of_float ; + to_float = Int64.to_float ; + lower_bound ; + upper_bound } + +let int32 = + Int { int_name = "int32" ; + of_float = Int32.of_float ; + to_float = Int32.to_float ; + lower_bound = Int32.min_int ; + upper_bound = Int32.max_int } +let ranged_int32 ~minimum:lower_bound ~maximum:upper_bound name = + Int { int_name = name ; + of_float = Int32.of_float ; + to_float = Int32.to_float ; + lower_bound ; + upper_bound } + +let ranged_float ~minimum ~maximum float_name = + Float (Some { minimum ; maximum ; float_name }) + +let float = Float None +let string = String +let conv ffrom fto ?schema t = + Conv (ffrom, fto, t, schema) +let bytes = Conv (Bytes.to_string, Bytes.of_string, string, None) +let bool = Bool +let array t = Array t +let obj1 f1 = Obj f1 +let obj2 f1 f2 = Objs (Obj f1, Obj f2) +let obj3 f1 f2 f3 = + conv + (fun (a, b, c) -> (a, (b, c))) + (fun (a, (b, c)) -> (a, b, c)) + (Objs (Obj f1, Objs (Obj f2, Obj f3))) +let obj4 f1 f2 f3 f4 = + conv + (fun (a, b, c, d) -> (a, (b, (c, d)))) + (fun (a, (b, (c, d))) -> (a, b, c, d)) + (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Obj f4)))) +let obj5 f1 f2 f3 f4 f5 = + conv + (fun (a, b, c, d, e) -> (a, (b, (c, (d, e))))) + (fun (a, (b, (c, (d, e)))) -> (a, b, c, d, e)) + (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Obj f5))))) +let obj6 f1 f2 f3 f4 f5 f6 = + conv + (fun (a, b, c, d, e, f) -> (a, (b, (c, (d, (e, f)))))) + (fun (a, (b, (c, (d, (e, f))))) -> (a, b, c, d, e, f)) + (Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, Obj f6)))))) +let obj7 f1 f2 f3 f4 f5 f6 f7 = + conv + (fun (a, b, c, d, e, f, g) -> (a, (b, (c, (d, (e, (f, g))))))) + (fun (a, (b, (c, (d, (e, (f, g)))))) -> (a, b, c, d, e, f, g)) + (let rest = Objs (Obj f6, Obj f7) in + Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) +let obj8 f1 f2 f3 f4 f5 f6 f7 f8 = + conv + (fun (a, b, c, d, e, f, g, h) -> (a, (b, (c, (d, (e, (f, (g, h)))))))) + (fun (a, (b, (c, (d, (e, (f, (g, h))))))) -> (a, b, c, d, e, f, g, h)) + (let rest = Objs (Obj f6, Objs (Obj f7, Obj f8)) in + Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) +let obj9 f1 f2 f3 f4 f5 f6 f7 f8 f9 = + conv + (fun (a, b, c, d, e, f, g, h, i) -> (a, (b, (c, (d, (e, (f, (g, (h, i))))))))) + (fun (a, (b, (c, (d, (e, (f, (g, (h, i)))))))) -> (a, b, c, d, e, f, g, h, i)) + (let rest = Objs (Obj f6, Objs (Obj f7, Objs (Obj f8, Obj f9))) in + Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) +let obj10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 = + conv + (fun (a, b, c, d, e, f, g, h, i, j) -> (a, (b, (c, (d, (e, (f, (g, (h, (i, j)))))))))) + (fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) -> (a, b, c, d, e, f, g, h, i, j)) + (let rest = Objs (Obj f6, Objs (Obj f7, Objs (Obj f8, Objs (Obj f9, Obj f10)))) in + Objs (Obj f1, Objs (Obj f2, Objs (Obj f3, Objs (Obj f4, Objs (Obj f5, rest)))))) +let tup1 f1 = Tup f1 +let tup2 f1 f2 = Tups (Tup f1, Tup f2) +let tup3 f1 f2 f3 = + conv + (fun (a, b, c) -> (a, (b, c))) + (fun (a, (b, c)) -> (a, b, c)) + (Tups (Tup f1, Tups (Tup f2, Tup f3))) +let tup4 f1 f2 f3 f4 = + conv + (fun (a, b, c, d) -> (a, (b, (c, d)))) + (fun (a, (b, (c, d))) -> (a, b, c, d)) + (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tup f4)))) +let tup5 f1 f2 f3 f4 f5 = + conv + (fun (a, b, c, d, e) -> (a, (b, (c, (d, e))))) + (fun (a, (b, (c, (d, e)))) -> (a, b, c, d, e)) + (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tup f5))))) +let tup6 f1 f2 f3 f4 f5 f6 = + conv + (fun (a, b, c, d, e, f) -> (a, (b, (c, (d, (e, f)))))) + (fun (a, (b, (c, (d, (e, f))))) -> (a, b, c, d, e, f)) + (Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, Tup f6)))))) +let tup7 f1 f2 f3 f4 f5 f6 f7 = + conv + (fun (a, b, c, d, e, f, g) -> (a, (b, (c, (d, (e, (f, g))))))) + (fun (a, (b, (c, (d, (e, (f, g)))))) -> (a, b, c, d, e, f, g)) + (let rest = Tups (Tup f6, Tup f7) in + Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) +let tup8 f1 f2 f3 f4 f5 f6 f7 f8 = + conv + (fun (a, b, c, d, e, f, g, h) -> (a, (b, (c, (d, (e, (f, (g, h)))))))) + (fun (a, (b, (c, (d, (e, (f, (g, h))))))) -> (a, b, c, d, e, f, g, h)) + (let rest = Tups (Tup f6, Tups (Tup f7, Tup f8)) in + Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) +let tup9 f1 f2 f3 f4 f5 f6 f7 f8 f9 = + conv + (fun (a, b, c, d, e, f, g, h, i) -> (a, (b, (c, (d, (e, (f, (g, (h, i))))))))) + (fun (a, (b, (c, (d, (e, (f, (g, (h, i)))))))) -> (a, b, c, d, e, f, g, h, i)) + (let rest = Tups (Tup f6, Tups (Tup f7, Tups (Tup f8, Tup f9))) in + Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) +let tup10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 = + conv + (fun (a, b, c, d, e, f, g, h, i, j) -> (a, (b, (c, (d, (e, (f, (g, (h, (i, j)))))))))) + (fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) -> (a, b, c, d, e, f, g, h, i, j)) + (let rest = Tups (Tup f6, Tups (Tup f7, Tups (Tup f8, Tups (Tup f9, Tup f10)))) in + Tups (Tup f1, Tups (Tup f2, Tups (Tup f3, Tups (Tup f4, Tups (Tup f5, rest)))))) + +let repr_agnostic_custom { write ; read } ~schema = + Custom ({ write ; read }, schema) + +let describe ?title ?description t = Describe (title, description, t) + +let constant s = Constant s + +let string_enum cases = + let schema = + let specs = Json_schema.({ pattern = None ; min_length = 0 ; max_length = None }) in + let enum = List.map (fun (s, _) -> Json_repr.(repr_to_any (module Ezjsonm)) (`String s)) cases in + Json_schema.(update { (element (String specs)) with enum = Some enum } any) in + let len = List.length cases in + let mcases = Hashtbl.create len + and rcases = Hashtbl.create len in + let cases_str = String.concat " " (List.map (fun x -> "'" ^ fst x ^ "'") cases) in + List.iter + (fun (s, c) -> + if Hashtbl.mem mcases s then + invalid_arg "Json_encoding.string_enum: duplicate case" ; + Hashtbl.add mcases s c ; + Hashtbl.add rcases c s) + cases ; + conv + (fun v -> try Hashtbl.find rcases v with Not_found -> + invalid_arg (Format.sprintf "Json_encoding.construct: consequence of non exhaustive Json_encoding.string_enum. Strings are: %s" cases_str)) + (fun s -> + (try Hashtbl.find mcases s with Not_found -> + let rec orpat ppf = function + | [] -> assert false + | [ last, _ ] -> Format.fprintf ppf "%S" last + | [ prev, _ ; last, _ ] -> Format.fprintf ppf "%S or %S" prev last + | (prev, _) :: rem -> Format.fprintf ppf "%S , %a" prev orpat rem in + let unexpected = Format.asprintf "string value %S" s in + let expected = Format.asprintf "%a" orpat cases in + raise (Cannot_destruct ([], Unexpected (unexpected, expected))))) + ~schema + string + +let def name encoding = + let schema = + let open Json_schema in + let sch = schema encoding in + let sch, def = add_definition name (root sch) sch in + update def sch in + conv (fun v -> v) (fun v -> v) ~schema encoding + +let assoc : type t. t encoding -> (string * t) list encoding = fun t -> + Ezjsonm_encoding.custom + (fun l -> `O (List.map (fun (n, v) -> n, Ezjsonm_encoding.construct t v) l)) + (fun v -> match v with + | `O l -> + let destruct n t v = try + Ezjsonm_encoding.destruct t v + with Cannot_destruct (p, exn) -> raise (Cannot_destruct (`Field n :: p, exn)) in + List.map (fun (n, v) -> n, destruct n t v) l + | #Json_repr.ezjsonm as k -> raise (unexpected k "asssociative object")) + ~schema:(let s = schema t in + Json_schema.(update (element (Object { object_specs with additional_properties = Some (root s)})) s)) + +let rec is_nullable: type t. t encoding -> bool = function + | Constant _ -> false + | Int _ -> false + | Float _ -> false + | Array _ -> false + | Empty -> false + | String -> false + | Bool -> false + | Obj _ -> false + | Tup _ -> false + | Objs _ -> false + | Tups _ -> false + | Null -> true + | Ignore -> true + | Option _ -> true + | Conv (_, _, t, _) -> is_nullable t + | Union cases -> + List.exists (fun (Case (t, _, _)) -> is_nullable t) cases + | Describe (_, _, t) -> is_nullable t + | Mu (_, f) as self -> is_nullable (f self) + | Custom (_, sch) -> Json_schema.is_nullable sch + +let option : type t. t encoding -> t option encoding = fun t -> + if is_nullable t then + invalid_arg "Json_encoding.option: cannot nest nullable encodings"; + Option t + +let any_value = + let read repr v = Json_repr.repr_to_any repr v in + let write repr v = Json_repr.any_to_repr repr v in + Custom ({ read ; write }, Json_schema.any) + +let any_ezjson_value = + let read repr v = Json_repr.convert repr (module Json_repr.Ezjsonm) v in + let write repr v = Json_repr.convert (module Json_repr.Ezjsonm) repr v in + Custom ({ read ; write }, Json_schema.any) + +let any_document = + let read + : type tt. (module Json_repr.Repr with type value = tt) -> tt -> Json_repr.any + = fun (module Repr) v -> + match Repr.view v with + | `A _ | `O _ -> + Json_repr.repr_to_any (module Repr) v + | k -> raise @@ unexpected k "array or object" in + let write repr v = Json_repr.any_to_repr repr v in + Custom ({ read ; write }, Json_schema.any) + +let any_schema = + Ezjsonm_encoding.custom + Json_schema.to_json + (fun j -> try Json_schema.of_json j with err -> + raise (Cannot_destruct ([], Bad_schema err))) + ~schema:Json_schema.self + +let merge_tups t1 t2 = + let rec is_tup : type t. t encoding -> bool = function + | Tup _ -> true + | Tups _ (* by construction *) -> true + | Conv (_, _, t, None) -> is_tup t + | Mu (_name, self) as mu -> is_tup (self mu) + | Describe (_, _, t) -> is_tup t + | _ -> false in + if is_tup t1 && is_tup t2 then + Tups (t1, t2) + else + invalid_arg "Json_encoding.merge_tups" + +let list t = + Conv (Array.of_list, Array.to_list, Array t, None) + +let merge_objs o1 o2 = + (* FIXME: check fields unicity *) + let rec is_obj : type t. t encoding -> bool = function + | Obj _ -> true + | Objs _ (* by construction *) -> true + | Conv (_, _, t, None) -> is_obj t + | Empty -> true + | Ignore -> true + | Union cases -> List.for_all (fun (Case (o, _, _)) -> is_obj o) cases + | Mu (_name, self) as mu -> is_obj (self mu) + | Describe (_, _, t) -> is_obj t + | _ -> false in + if is_obj o1 && is_obj o2 then + Objs (o1, o2) + else + invalid_arg "Json_encoding.merge_objs" + +let empty = + Empty + +let unit = + Ignore + +let case encoding fto ffrom = + Case (encoding, fto, ffrom) + +let union = function + | [] -> invalid_arg "Json_encoding.union" + | cases -> + (* FIXME: check mutual exclusion *) + Union cases + +let rec print_error ?print_unknown ppf = function + | Cannot_destruct ([], exn) -> + print_error ?print_unknown ppf exn + | Cannot_destruct (path, Unexpected (unex, ex)) -> + Format.fprintf ppf + "At %a, unexpected %s instead of %s" + (Json_query.print_path_as_json_path ~wildcards:true) path + unex ex + | Cannot_destruct (path, No_case_matched errs) -> + Format.fprintf ppf + "@[At %a, no case matched:@,%a@]" + (Json_query.print_path_as_json_path ~wildcards:true) path + (Format.pp_print_list (print_error ?print_unknown)) errs + | Cannot_destruct (path, Bad_array_size (unex, ex)) -> + Format.fprintf ppf + "At %a, unexpected array of size %d instead of %d" + (Json_query.print_path_as_json_path ~wildcards:true) path + unex ex + | Cannot_destruct (path, Missing_field n) -> + Format.fprintf ppf + "At %a, missing object field %s" + (Json_query.print_path_as_json_path ~wildcards:true) path + n + | Cannot_destruct (path, Unexpected_field n) -> + Format.fprintf ppf + "At %a, unexpected object field %s" + (Json_query.print_path_as_json_path ~wildcards:true) path + n + | Cannot_destruct (path, Bad_schema exn) -> + Format.fprintf ppf + "@[At %a, bad custom schema:@,%a@]" + (Json_query.print_path_as_json_path ~wildcards:true) path + (print_error ?print_unknown) exn + | Unexpected (unex, ex) -> + Format.fprintf ppf + "Unexpected %s instead of %s" unex ex + | No_case_matched errs -> + Format.fprintf ppf + "@[No case matched:@,%a@]" + (Format.pp_print_list (print_error ?print_unknown)) errs + | Bad_array_size (unex, ex) -> + Format.fprintf ppf + "Unexpected array of size %d instead of %d" unex ex + | Missing_field n -> + Format.fprintf ppf + "Missing object field %s" n + | Unexpected_field n -> + Format.fprintf ppf + "Unexpected object field %s" n + | Bad_schema exn -> + Format.fprintf ppf + "@[bad custom schema:@,%a@]" + (print_error ?print_unknown) exn + | Cannot_destruct (path, exn) -> + Format.fprintf ppf + "@[At %a:@,%a@]" + (Json_query.print_path_as_json_path ~wildcards:true) path + (print_error ?print_unknown) exn + | exn -> + Json_schema.print_error ?print_unknown ppf exn + +include Ezjsonm_encoding diff --git a/vendors/ocplib-json-typed/src/json_encoding.mli b/vendors/ocplib-json-typed/src/json_encoding.mli new file mode 100644 index 000000000..dffc00e94 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_encoding.mli @@ -0,0 +1,495 @@ +(** JSON structure description using dependently typed combinators. *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** {2 Dependent types describing JSON document structures} *) (***************) + +(** An encoding between an OCaml data type (the parameter) and a + JSON representation. To be built using the predefined + combinators provided by this module. + + For instance, here is an encoding, of type [(int * string) + encoding], mapping values of type [int * string] to JSON objects + with a field [code] of whose value is a number and a field + [message] whose value is a string. + + [let enc = obj2 (req "code" int) (req "message" string)] + + This encoding serves three purposes: + + 1. Output an OCaml value of type ['a] to an intermediate JSON + representation using {!construct}. To be printed to actual + JSON using an external library. + 2. Input a JSON intermediate structure (already parsed with an external + library) to produce an OCaml value of type ['a]. + 3. Describe this encoding in JSON-schema format for inter-operability: + you describe the encoding of your internal types, and obtain + machine-readable descriptions of the formats as a byproduct. + Specific documentation combinators are provided for that purpose. + + By default, this library provides functions that work on the + {!Json_repr.ezjsonm} data type, compatible with {!Ezjsonm.value}. + However, encodings are not tied with this representation. + See functor {!Make} and module {!Json_repr} for using another format. *) +type 'a encoding + +(** {2 Constructors and destructors for {!Json_repr.ezjsonm}} *) (***************) + +(** Builds a json value from an OCaml value and an encoding. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val construct : 't encoding -> 't -> Json_repr.ezjsonm + +(** Reads an OCaml value from a JSON value and an encoding. + May raise [Cannot_destruct]. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val destruct : 't encoding -> Json_repr.ezjsonm -> 't + +(** {2 JSON type combinators for simple immediates} *) (***********************) + +(** An encoding of an OCaml unit by any (ignored) JSON. *) +val unit : unit encoding + +(** An encoding of an OCaml unit by a JSON null. *) +val null : unit encoding + +(** An encoding of an OCaml unit by an empty JSON object. *) +val empty : unit encoding + +(** An encoding of an OCaml int by a JSON number. + + When destructing, the JSON number cannot have a fractional part, + and must be between [-2^30] and [2^30-1] (these bounds are chosen + to be compatible with both 32-bit and 64bit native OCaml compilers + as well as JavaScript). When constructing, the value coming from + the OCaml world is assumed to be valid, otherwise an + [Invalid_argument] will be raised (can only happen on 64-bit systems). + + Use {!int32} or {!int53} for a greater range. + Use {!ranged_int} to restrict to an interval. *) +val int : int encoding + +(** An encoding of an OCaml int32 by a JSON number. + + Must be a floating point without fractional part and between + [-2^31] and [2^31-1] when destructing. Never fails when + constructing, as all 32-bit integers are included in JSON numbers. *) +val int32 : int32 encoding + +(** An encoding of a JSON-representable OCaml int64 by a JSON number. + + Restricted to the [-2^53] to [2^53] range, as this is the limit of + representable integers in JSON numbers. Must be a floating point + without fractional part and in this range when destructing. When + constructing, the value coming from the OCaml world is assumed to + be in this range, otherwise an [Invalid_argument] will be raised. *) +val int53 : int64 encoding + +(** An encoding of an OCaml int by a JSON number restricted to a specific range. + + The bounds must be between [-2^30] and [2^30-1]. + + The inclusive bounds are checked when destructing. When + constructing, the value coming from the OCaml world is assumed to + be within the bounds, otherwise an [Invalid_argument] will be + raised. The string parameter is a name used to tweak the error + messages. *) +val ranged_int : minimum: int -> maximum: int -> string -> int encoding + +(** An encoding of an OCaml int32 by a JSON number restricted to a specific range. + + The bounds must be between [-2^31] and [2^31-1]. + + The inclusive bounds are checked when destructing. When + constructing, the value coming from the OCaml world is assumed to + be within the bounds, otherwise an [Invalid_argument] will be + raised. The string parameter is a name used to tweak the error + messages. *) +val ranged_int32 : minimum: int32 -> maximum: int32 -> string -> int32 encoding + +(** An encoding of an OCaml int64 by a JSON number restricted to a specific range. + + The bounds must be between [-2^53] and [2^53]. + + The inclusive bounds are checked when destructing. When + constructing, the value coming from the OCaml world is assumed to + be within the bounds, otherwise an [Invalid_argument] will be + raised. The string parameter is a name used to tweak the error + messages. *) +val ranged_int53 : minimum: int64 -> maximum: int64 -> string -> int64 encoding + +(** An encoding of an OCaml boolean by a JSON one. *) +val bool : bool encoding + +(** An encoding of an OCaml string by a JSON one. *) +val string : string encoding + +(** An encoding of a closed set of OCaml values by JSON strings. *) +val string_enum : (string * 'a) list -> 'a encoding + +(** An encoding of a constant string. *) +val constant : string -> unit encoding + +(** An encoding of an OCaml mutable string by a JSON string. *) +val bytes : bytes encoding + +(** An encoding of an OCaml float by a JSON number. *) +val float : float encoding + +(** An encoding of an OCaml float by a JSON number with range constraints *) +val ranged_float : minimum:float -> maximum:float -> string -> float encoding + +(** An encoding of an OCaml option by a nullable JSON value. Raises + [Invalid_argument] when nesting options – i.e., when building ['a option + option encoding]. Also raises [Invalid_argument] when used on the encoding + of [null]. *) +val option : 'a encoding -> 'a option encoding + +(** {2 JSON type combinators for objects} *) (*********************************) + +(** A first class handle to a JSON field. *) +type 'a field + +(** A required field of a given its type. *) +val req : ?title:string -> ?description:string -> string -> 't encoding -> 't field + +(** An optional field of a given type, using an OCaml [option]. *) +val opt : ?title:string -> ?description:string -> string -> 't encoding -> 't option field + +(** An optional field of a given type, ommited when equal to a default value. *) +val dft : ?title:string -> ?description:string -> string -> 't encoding -> 't -> 't field + +(** An encoding of an OCaml value by a singleton object. *) +val obj1 : + 'f1 field -> + 'f1 encoding + +(** An encoding of an OCaml pair by a JSON object with two fields. *) +val obj2 : + 'f1 field -> 'f2 field -> + ('f1 * 'f2) encoding + +(** An encoding of an OCaml triple by a JSON object with three fields. *) +val obj3 : + 'f1 field -> 'f2 field -> 'f3 field -> + ('f1 * 'f2 * 'f3) encoding + +(** An encoding of an OCaml quadruple by a JSON object with four fields. *) +val obj4 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> + ('f1 * 'f2 * 'f3 * 'f4) encoding + +(** An encoding of an OCaml quintuple by a JSON object with five fields. *) +val obj5 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding + +(** An encoding of an OCaml sextuple by a JSON object with six fields. *) +val obj6 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding + +(** An encoding of an OCaml septuple by a JSON object with seven fields. *) +val obj7 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding + +(** An encoding of an OCaml octuple by a JSON object with eight fields. *) +val obj8 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding + +(** An encoding of an OCaml nonuple by a JSON object with nine fields. *) +val obj9 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding + +(** An encoding of an OCaml decuple by a JSON object with ten fields. *) +val obj10 : + 'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field -> + 'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 'f10 field -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +(** Merge two object [encoding]s. For describing heavyweight objects with + a lot of fields. The ocaml type is a pair of tuples, but the JSON + object is flat. Both arguments must be object encodings, + otherwise a future {!construct}, {!destruct} or {!schema} will fail + with [Invalid_argument]. *) +val merge_objs : + 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding + +(** {2 JSON type combinators for arrays} *) (**********************************) + +(** An encoding of an OCaml array by a JSON one. *) +val array : + 'a encoding -> + 'a array encoding + +(** An encoding of an OCaml list by a JSON one. *) +val list : + 'a encoding -> + 'a list encoding + +(** An encoding of an OCaml associative list by a JSON object. *) +val assoc : + 'a encoding -> + (string * 'a) list encoding + +(** An encoding of an OCaml value by a singleton array. *) +val tup1 : + 'f1 encoding -> + 'f1 encoding + +(** An encoding of an OCaml pair by a JSON array with two cells. *) +val tup2 : + 'f1 encoding -> 'f2 encoding -> + ('f1 * 'f2) encoding + +(** An encoding of an OCaml triple by a JSON array with three cells. *) +val tup3 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> + ('f1 * 'f2 * 'f3) encoding + +(** An encoding of an OCaml quadruple by a JSON array with four cells. *) +val tup4 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> + ('f1 * 'f2 * 'f3 * 'f4) encoding + +(** An encoding of an OCaml quintuple by a JSON array with five cells. *) +val tup5 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding + +(** An encoding of an OCaml sextuple by a JSON array with six cells. *) +val tup6 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + 'f6 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding + +(** An encoding of an OCaml septuple by a JSON array with seven cells. *) +val tup7 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + 'f6 encoding -> 'f7 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding + +(** An encoding of an OCaml octuple by a JSON array with eight cells. *) +val tup8 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding + +(** An encoding of an OCaml nonuple by a JSON array with nine cells. *) +val tup9 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> 'f9 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding + +(** An encoding of an OCaml decuple by a JSON array with ten cells. *) +val tup10 : + 'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding -> 'f5 encoding -> + 'f6 encoding -> 'f7 encoding -> 'f8 encoding -> 'f9 encoding -> 'f10 encoding -> + ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding + +(** Merge two tuple [encoding]s. For describing heavyweight arrays with a + lot of cells. The ocaml type is a pair of tuples, but the JSON + array is flat, with the elements of the first tuple before the + ones of the second. Both arguments must be tuple encodings, + otherwise a future {!construct}, {!destruct} or {!schema} will fail + with [Invalid_argument]. *) +val merge_tups : + 'a1 encoding -> + 'a2 encoding -> + ('a1 * 'a2) encoding + +(** {2 JSON type combinators for unions} *) (**********************************) + +(** A case for describing union types using {!union} ans {!case}. *) +type 't case + +(** To be used inside a {!union}. Takes a [encoding] for a specific + case, and a converter to and from a type common to all cases + (['t]). Usually, it consists in boxing / deboxing the specific + data in an OCaml sum type contructor. *) +val case : 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case + +(** A utility to build destructors for custom encoded sum types. *) +val union : 't case list -> 't encoding + +(** {2 JSON generic type combinators} *) (*************************************) + +(** A simple custom encoding using the {!Json_repr.ezjsonm} + intermediate representation for the conversion functions. The + resulting encoding is usable with any other instanciation of + functor {!Make}, internal conversions may be performed needed. + The second transformer function can + [raise (Cannot_destruct ([ (* location *)], exn))] + to indicate an error, which will be relocated correctly. *) +val custom : + ('t -> Json_repr.ezjsonm) -> + (Json_repr.ezjsonm -> 't) -> + schema: Json_schema.schema -> + 't encoding + +(** An encoding adapter, with an optional handwritten schema. + The second transformer function can [raise (Cannot_destruct ([], exn))] + to indicate an error, which will be relocated correctly. *) +val conv : + ('a -> 'b) -> + ('b -> 'a) -> + ?schema: Json_schema.schema -> + 'b encoding -> + 'a encoding + +(** A fixpoint combinator. Links a recursive OCaml type to an internal + JSON schema reference, by allowing to use the encoding inside its + own definition. The first parameter is a path, that must be unique + and respect the format of {!Json_schema.add_definition}. It is + used to encode the recursivity as a named reference in the JSON + schema. + + Here is an example to turn a standard OCaml list into either + ["nil"] for [[]] or [{"hd":hd,"tl":tl}] for [hd::tl]. + + {[ let reclist itemencoding = + mu "list" @@ fun self -> + union + [ case (string_enum [ "nil", () ]) + (function [] -> Some () | _ :: _ -> None) + (fun () -> []) ; + case (obj2 (req "hd" itemencoding) (req "tl" self)) + (function hd :: tl -> Some (hd, tl) | [] -> None) + (fun (hd, tl) -> hd :: tl) ]) ]} *) +val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding + +(** A raw JSON value in ezjsonm representation. *) +val any_ezjson_value : Json_repr.ezjsonm encoding + +(** A valid JSON document (i.e. an array or object value). *) +val any_document : Json_repr.any encoding + +(** The encoding of a JSON schema, linked to its OCaml definiton. *) +val any_schema : Json_schema.schema encoding + +(** {2 Exporting [encoding]s as JSON schemas} *) (********************************) + +(** Describe an encoding in JSON schema format. + May raise {!Bad_schema}. *) +val schema : 't encoding -> Json_schema.schema + +(** Annotate a type with a title and description for the JSON schema. *) +val describe : + ?title:string -> + ?description:string -> + 't encoding -> + 't encoding + +(** Name a definition so its occurences can be shared in the JSON + schema. The first parameter is a path, that must be unique and + respect the format of {!Json_schema.add_definition}. *) +val def : string -> 't encoding -> 't encoding + +(** {2 Errors} *) (************************************************************) + +(** Exception raised by destructors, with the location in the original + JSON structure and the specific error. *) +exception Cannot_destruct of (Json_query.path * exn) + +(** Unexpected kind of data encountered (w/ the expectation). *) +exception Unexpected of string * string + +(** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *) +exception No_case_matched of exn list + +(** Array of unexpected size encountered (w/ the expectation). *) +exception Bad_array_size of int * int + +(** Missing field in an object. *) +exception Missing_field of string + +(** Supernumerary field in an object. *) +exception Unexpected_field of string + +(** Bad custom schema encountered. *) +exception Bad_schema of exn + +(** Produces a human readable version of an error. *) +val print_error + : ?print_unknown: (Format.formatter -> exn -> unit) -> + Format.formatter -> exn -> unit + +(** {2 Advanced interface for using a custom JSON representation} *) (**********) + +module Make (Repr : Json_repr.Repr) : sig + + (** Same as {!construct} for a custom JSON representation. *) + val construct : 't encoding -> 't -> Repr.value + + (** Same as {!destruct} for a custom JSON representation. *) + val destruct : 't encoding -> Repr.value -> 't + + (** Same as {!custom} for a custom JSON representation. *) + val custom : + ('t -> Repr.value) -> (Repr.value -> 't) -> + schema: Json_schema.schema -> + 't encoding + +end + +(** Custom encoders for an OCaml type, given both custom conversion + functions. The actual representation is not known in advance, so + the conversion functions have to examine / construct the JSON + value through the first class modules they are passed. The [read] + transformer function can [raise (Cannot_destruct ([], "message"))] + to indicate an error, which will be relocated correctly. + + Here is an example of how to build such a value for a type ['t]. + + {[ let read + : type tf. (module Json_repr.Repr with type value = tf) -> tf -> 't + = fun (module Repr_f) repr -> + match Repr_f.view repr with + | `Null (* destruct the JSON using [Repr_f.view] *) -> + (* create a value of type 't *) + | _ -> + (* or fail with this wrapping exception *) + raise (Cannot_destruct ([ (* location *) ], (* exn *))) in + let write + : type tf. (module Json_repr.Repr with type value = tf) -> 't -> tf + = fun (module Repr_f) v -> + (* examine the value and produce a JSON using [Repr_f.repr] *) + Repr_f.repr `Null in + { read ; write } ]} *) +type 't repr_agnostic_custom = + { write : 'rt. (module Json_repr.Repr with type value = 'rt) -> 't -> 'rt ; + read : 'rf. (module Json_repr.Repr with type value = 'rf) -> 'rf -> 't } + +(** A custom encoding, using custom encoders and a schema. *) +val repr_agnostic_custom : + 't repr_agnostic_custom -> + schema: Json_schema.schema -> + 't encoding + +(** A raw JSON value in its original representation. *) +val any_value : Json_repr.any encoding diff --git a/vendors/ocplib-json-typed/src/json_query.ml b/vendors/ocplib-json-typed/src/json_query.ml new file mode 100644 index 000000000..9faee5df8 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_query.ml @@ -0,0 +1,269 @@ +(* Queries in JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +type path = + path_item list + +and path_item = + [ `Field of string + | `Index of int + | `Star | `Next ] + +exception Illegal_pointer_notation of string * int * string +exception Unsupported_path_item of path_item * string +exception Cannot_merge of path + +(*-- path operations -------------------------------------------------------*) + +let print_path_as_json_path ?(wildcards = true) ppf = function + | [] -> Format.fprintf ppf "/" + | nonempty -> + let rec print ppf = function + | [] -> () + | `Field n :: rem -> Format.fprintf ppf "/%s%a" n print rem + | `Index n :: rem -> Format.fprintf ppf "[%d]%a" n print rem + | `Next :: rem when wildcards -> Format.fprintf ppf "-%a" print rem + | `Star :: rem when wildcards -> Format.fprintf ppf "*%a" print rem + | (`Next | `Star) :: _ -> + raise (Unsupported_path_item (`Star, "JSON path w/o wildcards")) in + print ppf nonempty + +let print_path_as_json_pointer ?(wildcards = true) ppf = function + | [] -> Format.fprintf ppf "/" + | nonempty -> + let rec print ppf = function + | [] -> () + | `Field n :: rem -> Format.fprintf ppf "/%s%a" n print rem + | `Index n :: rem -> Format.fprintf ppf "/%d%a" n print rem + | `Next :: rem when wildcards -> Format.fprintf ppf "/-%a" print rem + | `Next :: _ -> raise (Unsupported_path_item (`Star, "JSON pointer w/o wildcards")) + | `Star :: _ -> raise (Unsupported_path_item (`Star, "JSON pointer")) in + print ppf nonempty + +let json_pointer_of_path ?wildcards path = + Format.asprintf "%a" (print_path_as_json_pointer ?wildcards) path + +let path_of_json_pointer ?(wildcards = true) str = + let buf = Buffer.create 100 in + let len = String.length str in + let rec slashes acc i = + if i >= len then List.rev acc + else if String.get str i = '/' then slashes acc (i + 1) + else item acc i + and item acc i = + if i >= len then List.rev (interp () :: acc) + else match String.get str i with + | '/' -> slashes (interp () :: acc) i + | '~' -> + if i + 1 >= len then + raise (Illegal_pointer_notation (str, i, "Unterminated escape sequence")) ; + begin match String.get str i with + | '0' -> Buffer.add_char buf '~' + | '1' -> Buffer.add_char buf '/' + | _illegal -> + raise (Illegal_pointer_notation (str, i + 1, "Illegal escape character")) end ; + item acc (i + 1) + | unescaped -> + Buffer.add_char buf unescaped ; + item acc (i + 1) + and interp () = + let field = Buffer.contents buf in + Buffer.clear buf ; + if field = "-" then + if wildcards then + `Next + else + raise (Unsupported_path_item (`Next, "JSON pointer w/o wildcards")) + else try `Index (int_of_string field) with + | _ -> `Field field in + if len = 0 then [] + else if String.get str 0 <> '/' then + raise (Illegal_pointer_notation (str, 0, "Missing initial slash")) + else slashes [] 1 + +(*-- queries ---------------------------------------------------------------*) + +module Make (Repr : Json_repr.Repr) = struct + + let rec query path json = match path, Repr.view json with + | [], _ -> + json + | `Field n :: rempath, `O ((n', v) :: rem) -> + if n = n' then query rempath v else query path (Repr.repr (`O rem)) + | `Index i :: rempath, `A cells -> + let i = if i < 0 then List.length cells - i else i in + query rempath (List.nth cells i) + | `Star :: rempath, `O ((_, v) :: rem) -> + begin try query rempath v with Not_found -> query path (Repr.repr (`O rem)) end + | `Star :: rempath, `A (v :: rem) -> + begin try query rempath v with Not_found -> query path (Repr.repr (`A rem)) end + | _, _ -> raise Not_found + + let query_all path json = + let res = ref [] in + let rec query path json = match path, Repr.view json with + | [], _ -> + res := json :: !res + | `Field n :: rempath, `O ((n', v) :: rem) -> + if n = n' then query rempath v else query path (Repr.repr (`O rem)) + | `Index i :: rempath, `A cells -> + let i = if i < 0 then List.length cells - i else i in + query rempath (List.nth cells i) + | `Star :: rempath, `O fields -> + List.iter (fun (_, v) -> query rempath v) fields + | `Star :: rempath, `A cells -> + List.iter (query rempath) cells + | _, _ -> () in + query path json ; !res + + (*-- updates ---------------------------------------------------------------*) + + let sort_fields = + List.sort (fun (l, _) (r, _) -> compare l r) + + let equals l r = + let rec canon v = match Repr.view v with + | `O l -> Repr.repr (`O (List.map (fun (n, o) -> n, canon o) l |> sort_fields)) + | `A l -> Repr.repr (`A (List.map canon l)) + | _ -> v in + canon l = canon r + + let merge l r = + let rec merge path l r = + match Repr.view l, Repr.view r with + | `O l, `O r -> Repr.repr (`O (merge_fields path [] (sort_fields (l @ r)))) + | `Null, v | v, `Null -> Repr.repr v + | `A l, `A r -> Repr.repr (`A (merge_cells path 0 [] l r)) + | _ -> if equals l r then l else raise (Cannot_merge (List.rev path)) + and merge_cells path i acc l r = match l, r with + | [], rem | rem, [] -> List.rev_append acc rem + | l :: ls, r :: rs -> + let item = merge (`Index i :: path) l r in + merge_cells path (succ i) (item :: acc) ls rs + and merge_fields path acc = function + | (lf, lv) :: ((rf, rv) :: rem as rrem) -> + if lf = rf then + let item = merge (`Field lf :: path) lv rv in + merge_fields path ((lf, item) :: acc) rem + else + merge_fields path ((lf, lv) :: acc) rrem + | [ _ ] | [] as last -> last in + merge [] l r + + let insert ?(merge = merge) path value root = + let revpath sub = + let rec loop acc = function + | l when l == sub -> List.rev acc + | item :: items -> loop (item :: acc) items + | [] -> (* absurd *) assert false + in loop [] path in + let merge path l r = + try merge l r with + Cannot_merge sub -> raise (Cannot_merge (revpath path @ sub)) in + let rec nulls acc n last = + if n <= 0 then + List.rev (last :: acc) + else + nulls (Repr.repr `Null :: acc) (pred n) last in + let rec insert ?root path = + let root = match root with None -> None | Some repr -> Some (Repr.view repr) in + match path, root with + (* create objects *) + | `Field n :: rempath, None -> + Repr.repr (`O [ (n, insert rempath) ]) + | (`Index 0 | `Star | `Next) :: rempath, None -> + Repr.repr (`A [ insert rempath ]) + | `Index i :: rempath, None -> + if i < 0 then raise (Cannot_merge (revpath path)) ; + Repr.repr (`A (nulls [] (max 0 (pred i)) (insert rempath))) + | [], None -> value + (* insert in existing *) + | [], Some value' -> + merge path value (Repr.repr value') + | `Field n :: rempath, Some (`O fields) -> + Repr.repr (`O (insert_fields [] n rempath fields)) + | `Index i :: rempath, Some (`A cells) -> + let i = if i < 0 then List.length cells - i else i in + if i < 0 then raise (Cannot_merge (revpath path)) ; + Repr.repr (`A (insert_cells [] i rempath cells)) + | `Next :: rempath, Some (`A cells) -> + Repr.repr (`A (List.rev_append (List.rev cells) [ insert rempath ])) + (* multiple insertions *) + | `Star :: rempath, Some (`A cells) -> + Repr.repr (`A (List.map (fun root -> insert ~root rempath) cells)) + | `Star :: rempath, Some (`O fields) -> + Repr.repr (`O (List.map (fun (n, root) -> (n, insert ~root rempath)) fields)) + | [ `Star ], Some root -> + merge path value (Repr.repr root) + (* FIXME: make explicit unhandled cases *) + | _, Some _ -> raise (Cannot_merge (revpath path)) + and insert_fields acc n rempath fields = match fields with + | [] -> + List.rev ((n, insert rempath) :: acc) + | (n', root) :: rem when n = n' -> + List.rev_append ((n, insert ~root rempath) :: acc) rem + | other :: rem -> + insert_fields (other :: acc) n rempath rem + and insert_cells acc n rempath cells = + match cells, n with + | [], n -> + nulls acc n (insert rempath) + | root :: rem, 0 -> + List.rev_append ((insert ~root rempath) :: acc) rem + | other :: rem, n -> + insert_cells (other :: acc) (n - 1) rempath rem in + insert ~root path + + let replace path value root = + insert ~merge:(fun value _prev -> value) path value root + + let insert path value root = + insert path value root + +end + +let path_operator_name = function + | `Field _ -> "field access" + | `Index _ -> "array access" + | `Star -> "wildcard" + | `Next -> "array append" + +let print_error ?print_unknown ppf err = match err with + | Illegal_pointer_notation (notation, pos, msg) -> + Format.fprintf ppf + "@[Illegal pointer notation@,At character %d of %S@,%s@]" + pos notation msg + | Unsupported_path_item (item, msg) -> + Format.fprintf ppf + "Path operator %s unsupported by %s" + (path_operator_name item) msg + | Cannot_merge [] -> + Format.fprintf ppf + "Unmergeable objects" + | Cannot_merge path -> + Format.fprintf ppf + "Unmergeable objects, incompatibility at %a" + (print_path_as_json_path ~wildcards:true) path + | exn -> + match print_unknown with + | Some print_unknown -> print_unknown ppf exn + | None -> + Format.fprintf ppf "Unhandled error %s" (Printexc.to_string exn) + +include Make (Json_repr.Ezjsonm) diff --git a/vendors/ocplib-json-typed/src/json_query.mli b/vendors/ocplib-json-typed/src/json_query.mli new file mode 100644 index 000000000..a30bf7d2b --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_query.mli @@ -0,0 +1,155 @@ +(** Queries in JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** {2 Paths in JSON documents} *) (*****************************************) + +(** An abstract type for paths into a JSON document. + A sequence of sub-tree selectors to descend into a JSON tree. *) +type path = path_item list + +(** A JSON sub-tree selector. + Indendent from any concrete format (JSON pointer, JSON path, etc.) + The semantics depends on the use (selection, insertion, etc.) *) +and path_item = + [ `Field of string + (** A field in an object. *) + | `Index of int + (** An index in an array. *) + | `Star + (** Any / every field or index. *) + | `Next + (** The next element after an array. *) ] + +(** Pretty prints a path in JSON pointer format (RFC6901). May throw + {!Unsupported_path_item}. Use [~wildcards:false] to deactivate the + support of wildcard path items, which may lead to + {!Unsupported_path_item}. *) +val print_path_as_json_pointer : ?wildcards: bool -> Format.formatter -> path -> unit + +(** Pretty prints a path in JSON path format. Use [~wildcards:false] to + deactivate the support of wildcard path items, which may lead to + {!Unsupported_path_item}. *) +val print_path_as_json_path : ?wildcards: bool -> Format.formatter -> path -> unit + +(** Pretty prints a path in JSON pointer format into a fresh string. + May throw {!Unsupported_path_item}. Use [~wildcards:false] to + deactivate the support of wildcard path items, which may lead to + {!Unsupported_path_item}. *) +val json_pointer_of_path : ?wildcards: bool -> path -> string + +(** Parses a path from a string in JSON pointer format. May throw + {!Illegal_pointer_notation}. The string is expected to be ASCII + compatible, including UTF-8. Use [~wildcards:false] to deactivate + the support of wildcard path items, which may lead to + {!Unsupported_path_item}. *) +val path_of_json_pointer : ?wildcards: bool -> string -> path + +(** {2 Querying JSON documents} *) (*******************************************) + +(** Extracts the value located at a given path. If multiple locations + satisfy the path (in presence of wildcard path items), the chosen + one is unspecified. May throw [Not_found]. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val query : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm + +(** Extracts the values located at a given path (may be more than one + in presence of wildcard path items). The order is unspecified. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val query_all : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm list + +(** Insert a value at a given path. If multiple locations satisfy the + path (in presence of wildcard path items), the chosen one is + unspecified. Will create parent objects or arrays if needed, for + instance inserting [3] at [/a/b/c] in [{}] will result in + [{"a":{"b":{"c":3}}}]. Inserting in an array at an index bigger + than the previous size will expand the array, filling potential + missing cells with [`Null]. Inserting in an array at [`Index n] + where [n] is negative inserts from the last element of the + array. If a value is inserted at a location where there is already + one, both are merged as if with {!merge}. May throw + {!Cannot_merge} if the path is incompatible with the original + object (such as inserting in a field of something which is not an + object) or if the value is to be merged with an incompatible + existing value. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val insert : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm + +(** Same as {!insert}, except that if the path leads to a pre-existing + value, it is replaced with the new one instead of being merged. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val replace : path -> Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm + +(** Merges two compatible JSON values. Merges [`Null] with any JSON + value. Merges two deeply equal values together. Merges two objects + by merging their common fields and adding all the others. Merges + two arrays by merging their common cells pairwise and adding the + remaining ones if one array is bigger than the other. May throw + {!Cannot_merge}. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val merge : Json_repr.ezjsonm -> Json_repr.ezjsonm -> Json_repr.ezjsonm + +(** {2 Errors} *) (**********************************************************) + +(** When two incompatible objects are unsuccessfully merged. Comes + with the path to the first incompatibility encountered.*) +exception Cannot_merge of path + +(** An path litteral could not be parsed. Comes with the original + string, the position and an explanation. *) +exception Illegal_pointer_notation of string * int * string + +(** An operation was given a path containing an unsupported construct. + Comes with an explanation as its second argument. *) +exception Unsupported_path_item of path_item * string + +(** Produces a human readable version of an error. *) +val print_error + : ?print_unknown: (Format.formatter -> exn -> unit) -> + Format.formatter -> exn -> unit + +(** {2 Advanced interface for using a custom JSON representation} *) (**********) + +module Make (Repr : Json_repr.Repr) : sig + + (** Same as {!query} for a custom JSON representation. *) + val query : path -> Repr.value -> Repr.value + + (** Same as {!query_all} for a custom JSON representation. *) + val query_all : path -> Repr.value -> Repr.value list + + (** Same as {!insert} for a custom JSON representation. *) + val insert : path -> Repr.value -> Repr.value -> Repr.value + + (** Same as {!replace} for a custom JSON representation. *) + val replace : path -> Repr.value -> Repr.value -> Repr.value + + (** Same as {!merge} for a custom JSON representation. *) + val merge : Repr.value -> Repr.value -> Repr.value + +end diff --git a/vendors/ocplib-json-typed/src/json_repr.ml b/vendors/ocplib-json-typed/src/json_repr.ml new file mode 100644 index 000000000..8f7b003a4 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr.ml @@ -0,0 +1,250 @@ +(* Representations of JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +type 'a view = + [ `O of (string * 'a) list + | `A of 'a list + | `Bool of bool + | `Float of float + | `String of string + | `Null ] + +type 'a repr_uid = 'a option ref +(* This is used for limiting conversions. When a value is converted + from a representation to another, which mostly happens when using + the {!type:any} boxing, such as when writing custom encodings, the + original value is usually traversed using the [view] of the + original representation, and recreated using the [repr] of the + destination representation. When converting from a representation + to itself, we want to optimize out this transformation, that is a + deep copy, and just get the same value. For this, we have to prove + to OCaml that it is indeed a value from the same representation. + To do that, we use the following trick. Each representation has a + bucket, the uid below. When converting from the original + representation, we put the value in its bucket. Then, we check the + bucket of the destination, and if it happens to be occupied, we + find in it the original value, under the destination type. Voilà. *) +let repr_uid () = ref None +let eq_repr_uid + : 'a -> 'a repr_uid -> 'b repr_uid -> 'b option + = fun a ta tb -> tb := None ; ta := Some a ; !tb + +module type Repr = sig + type value + val view : value -> value view + val repr : value view -> value + val repr_uid : value repr_uid +end + +module Ezjsonm = struct + type value = + [ `O of (string * value) list + | `A of value list + | `Bool of bool + | `Float of float + | `String of string + | `Null ] + let view v = v + let repr v = v + let repr_uid = repr_uid () +end + +type ezjsonm = Ezjsonm.value + +module Yojson = struct + type value = + [ `Bool of bool + | `Assoc of (string * value) list + | `Float of float + | `Int of int + | `Intlit of string + | `List of value list + | `Null + | `String of string + | `Tuple of value list + | `Variant of string * value option ] + let view = function + | `Intlit i -> `String i + | `Tuple l -> `A l + | `Variant (label, Some x) -> `A [ `String label ; x ] + | `Variant (label, None) -> `String label + | `Assoc l -> `O l + | `List l -> `A l + | `Int i -> `Float (float i) + | `Float f -> `Float f + | `String s -> `String s + | `Null -> `Null + | `Bool b -> `Bool b + let repr = function + | `O l -> `Assoc l + | `A l -> `List l + | `Bool b -> `Bool b + | `Float f -> `Float f + | `String s -> `String s + | `Null -> `Null + let repr_uid = repr_uid () +end + +type yojson = Yojson.value + +let convert + : type tt tf. + (module Repr with type value = tf) -> + (module Repr with type value = tt) -> + tf -> tt + = fun (module Repr_f) (module Repr_t) v -> + match eq_repr_uid v Repr_f.repr_uid Repr_t.repr_uid with + | Some r -> r + | None -> + let rec conv v = match Repr_f.view v with + | `Float _ | `Bool _ | `String _ | `Null as v -> Repr_t.repr v + | `A values -> Repr_t.repr (`A (List.map conv values)) + | `O values -> Repr_t.repr (`O (List.map (fun (k, v) -> (k, conv v)) values)) in + conv v + +let pp_string ppf s = + Format.fprintf ppf "\"" ; + for i = 0 to String.length s - 1 do + match String.get s i with + | '\"' -> Format.fprintf ppf "\\\"" + | '\n' -> Format.fprintf ppf "\\n" + | '\r' -> Format.fprintf ppf "\\r" + | '\b' -> Format.fprintf ppf "\\b" + | '\t' -> Format.fprintf ppf "\\t" + | '\\' -> Format.fprintf ppf "\\\\" + | c -> Format.fprintf ppf "%c" c + done ; + Format.fprintf ppf "\"" + +let pp + ?(compact = false) ?(pp_string = pp_string) + (type value) (module Repr : Repr with type value = value) ppf (v : value) = + let rec pp_compact ppf v = match Repr.view v with + | `O l -> + let pp_sep ppf () = + Format.fprintf ppf "," in + let pp_field ppf (name, v) = + Format.fprintf ppf "%a:%a" + pp_string name + pp_compact v in + Format.fprintf ppf "{%a}" + (Format.pp_print_list ~pp_sep pp_field) + l + | `A l -> + let pp_sep ppf () = + Format.fprintf ppf "," in + Format.fprintf ppf "[%a]" + (Format.pp_print_list ~pp_sep pp_compact) l + | `Bool true -> Format.fprintf ppf "true" + | `Bool false -> Format.fprintf ppf "false" + | `Float f -> + let fract, intr = modf f in + if fract = 0.0 then + Format.fprintf ppf "%.0f" intr + else + Format.fprintf ppf "%g" f + | `String s -> pp_string ppf s + | `Null -> Format.fprintf ppf "null" in + let rec pp_box ppf v = match Repr.view v with + | `O [] -> Format.fprintf ppf "{}" + | `O l -> + let pp_sep ppf () = + Format.fprintf ppf ",@ " in + let pp_field ppf (name, v) = + Format.fprintf ppf "@[%a:@ %a@]" + pp_string name + pp_box v in + Format.fprintf ppf "@[{ %a }@]" + (Format.pp_print_list ~pp_sep pp_field) + l + | `A [] -> Format.fprintf ppf "[]" + | `A l -> + let pp_sep ppf () = + Format.fprintf ppf ",@ " in + Format.fprintf ppf "@[[ %a ]@]" + (Format.pp_print_list ~pp_sep pp_box) l + | _ -> pp_compact ppf v in + if compact then + pp_compact ppf v + else + pp_box ppf v + +let from_yojson non_basic = + (* Delete `Variant, `Tuple and `Intlit *) + let rec to_basic non_basic = match non_basic with + | `Intlit i -> `String i + | `Tuple l -> `List (List.map to_basic l) + | `Variant (label, Some x) -> `List [`String label; to_basic x] + | `Variant (label, None) -> `String label + | `Assoc l -> `Assoc (List.map (fun (key, value) -> (key, to_basic value)) l) + | `List l -> `List (List.map to_basic l) + | `Int i -> `Int i + | `Float f -> `Float f + | `String s -> `String s + | `Null -> `Null + | `Bool b -> `Bool b in + (* Rename `Assoc, `Int and `List *) + let rec to_value : 'a. _ -> ([> ezjsonm ] as 'a) = function + | `List l -> `A (List.map to_value l) + | `Assoc l -> `O (List.map (fun (key, value) -> (key, to_value value)) l) + | `Int i -> `Float (float_of_int i) + | `Float f -> `Float f + | `Null -> `Null + | `String s -> `String s + | `Bool b -> `Bool b in + to_basic (non_basic :> yojson) |> to_value + +let to_yojson json = + let rec aux : 'a. _ -> ([> yojson ] as 'a) = function + | `A values -> + `List (List.map aux values) + | `O values -> + `Assoc (List.map (fun (k, v) -> (k, aux v)) values) + | `Float f -> + let fract, intr = modf f in + let max_intf = float 0x3F_FF_FF_FF in + let min_intf = ~-. max_intf -. 1. in + if fract = 0.0 then + if intr >= min_intf && intr <= max_intf + then `Int (int_of_float intr) + else `Intlit (Printf.sprintf "%.0f" intr) + else `Float f + | `Bool b -> `Bool b + | `String s -> `String s + | `Null -> `Null + in aux (json :> ezjsonm) + +type any = Value_with_repr: (module Repr with type value = 'a) * 'a -> any + +let pp_any ?compact ?pp_string () ppf (Value_with_repr (repr, v)) = + pp ?compact ?pp_string repr ppf v + +let any_to_repr : + type tt. (module Repr with type value = tt) -> any -> tt = + fun repr_t (Value_with_repr (repr_f, v)) -> convert repr_f repr_t v + +let repr_to_any repr v = + Value_with_repr (repr, v) + +let from_any : 'a. any -> ([> ezjsonm] as 'a) = fun repr -> + let res = any_to_repr (module Ezjsonm) repr in + (res : ezjsonm :> [> ezjsonm]) + +let to_any v = + Value_with_repr ((module Ezjsonm), (v :> ezjsonm)) diff --git a/vendors/ocplib-json-typed/src/json_repr.mli b/vendors/ocplib-json-typed/src/json_repr.mli new file mode 100644 index 000000000..0a976f6bf --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr.mli @@ -0,0 +1,167 @@ +(** Representations of JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** {2 Abstraction over JSON representations} *) (*****************************) + +(** The internal format used by the library. A common format to view + JSON structures from different representations. It only shows the + head of structures, hiding the contents of fields, so that the + conversion from another format or a stream can be done lazily. *) +type 'a view = + [ `O of (string * 'a) list + (** An associative table (object). *) + | `A of 'a list + (** An (integer indexed) array. *) + | `Bool of bool + (** A JS boolean [true] or [false]. *) + | `Float of float + (** A floating point number (double precision). *) + | `String of string + (** An UTF-8 encoded string. *) + | `Null + (** The [null] constant. *) ] + +(** Each representation must provide a unique identifier, obtained via + the {!repr_uid} function. This identifier is used when converting + between representations, to optimize out a copy when converting + from a representation to itself. Beware that this optimization + relies only on this [uid] token. Converting between values of the + same type using two different representation modules with + different [uid]s will perform a copy. A practical way to ensure + that the optimization is made is to write your representations as + toplevel modules, and not inside functors. *) +type 'a repr_uid + +(** See {!type:repr_uid}. *) +val repr_uid : unit -> 'a repr_uid + +(** A view over a given implementation. *) +module type Repr = sig + + (** The implementation type. *) + type value + + (** View a value in the common format. *) + val view : value -> value view + + (** Builds a value from a view *) + val repr : value view -> value + + (** See {!type:repr_uid}. *) + val repr_uid : value repr_uid + +end + +(** Convert a JSON value from one representation to another. *) +val convert : + (module Repr with type value = 'tf) -> + (module Repr with type value = 'tt) -> + 'tf -> 'tt + +(** Generic pretty-printer. If [compact] is set (by default), then the + output is not really pretty (no space is output). Ascii-compatible + string encoding is expected, as printing only escapes double + quotes and control characters. Use [pp_string] for more advanced + escaping. This function does not claim to be the best JSON pretty + printer, it is mostly a small utility. *) +val pp : + ?compact: bool -> ?pp_string: (Format.formatter -> string -> unit) -> + (module Repr with type value = 'tf) -> + Format.formatter -> 'tf -> unit + + +(** {2 Third party in-memory JSON document representations} *) (****************) + +(** A JSON value compatible with {!Ezjsonm.value}. *) +type ezjsonm = + [ `O of (string * ezjsonm) list + (** An associative table (object). *) + | `A of ezjsonm list + (** An (integer indexed) array. *) + | `Bool of bool + (** A JS boolean [true] or [false]. *) + | `Float of float + (** A floating point number (double precision). *) + | `String of string + (** An UTF-8 encoded string. *) + | `Null + (** The [null] constant. *) ] + +(** A view over the {!type:ezjsonm} representation.*) +module Ezjsonm : Repr with type value = ezjsonm + +(** A JSON value compatible with {!Yojson.Safe.json}. *) +type yojson = + [ `Bool of bool + (** A JS boolean [true] of [false]. *) + | `Assoc of (string * yojson) list + (** JSON object. *) + | `Float of float + (** A floating point number (double precision). *) + | `Int of int + (** A number without decimal point or exponent. *) + | `Intlit of string + (** A number without decimal point or exponent, preserved as string. *) + | `List of yojson list + (** A JS array. *) + | `Null + (** The [null] constant. *) + | `String of string + (** An UTF-8 encoded string. *) + | `Tuple of yojson list + (** A tuple (non-standard). Syntax: ("abc", 123). *) + | `Variant of string * yojson option + (** A variant (non-standard). Syntax: <"Foo"> or <"Bar": 123>. *) ] + +(** A view over the {!yojson} representation.*) +module Yojson : Repr with type value = yojson + +(** {2 Representation-agnostic JSON format} *) (********************************) + +(** A meta-representation for JSON values that can unify values of + different representations by boxing them with their corresponding + {!Repr} modules. *) +type any = private Value_with_repr: (module Repr with type value = 'a) * 'a -> any + +(** Converts a boxed value from its intrinsic representation to the + one of the given {!Repr} module. Optimized if the internal + representation of the value actually is the requested one. *) +val any_to_repr : (module Repr with type value = 'a) -> any -> 'a + +(** Boxes a value with a compatible {!Repr} module. *) +val repr_to_any : (module Repr with type value = 'a) -> 'a -> any + +(** Pretty-printer for values of type {!any}. See {!pp} for details. *) +val pp_any : + ?compact: bool -> ?pp_string: (Format.formatter -> string -> unit) -> unit -> + Format.formatter -> any -> unit + +(** {2 Predefined converters for {!type:ezjsonm}} *) (********************************) + +(** Conversion helper. *) +val from_yojson : [< yojson ] -> [> ezjsonm ] + +(** Conversion helper. *) +val to_yojson : [< ezjsonm] -> [> yojson ] + +(** Converts a boxed value from its representation to {!ezjsonm}. *) +val from_any : any -> [> ezjsonm ] + +(** Boxes as {!ezjsonm} value. *) +val to_any : [< ezjsonm] -> any diff --git a/vendors/ocplib-json-typed/src/json_repr_browser.ml b/vendors/ocplib-json-typed/src/json_repr_browser.ml new file mode 100644 index 000000000..d5245825e --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr_browser.ml @@ -0,0 +1,103 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2016 OCamlPro. + * + * Learn-OCaml is free software: you can redistribute it and/or modify + * it under the terms of the GNU Affero General Public License as + * published by the Free Software Foundation, either version 3 of the + * License, or (at your option) any later version. + * + * Learn-OCaml is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Affero General Public License for more details. + * + * You should have received a copy of the GNU Affero General Public License + * along with this program. If not, see . *) + +module Repr = struct + + (* Not for the faint of heart. *) + + type value = unit Js.t + + let repr = function + | `String s -> Js.Unsafe.coerce (Js.string s) + | `Float f -> Js.Unsafe.coerce (Obj.magic f) + | `Bool true -> Js.Unsafe.coerce Js._true + | `Bool false -> Js.Unsafe.coerce Js._false + | `Null -> Obj.magic Js.null (* Oh, nom nom nom! *) + | `O fields -> + let obj = Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "Object") [||] in + List.iter + (fun (n, v) -> Js.Unsafe.set obj (Js.string n) v) + fields ; + obj + | `A cells -> + Js.Unsafe.coerce (Js.array (Array.of_list cells)) + + let view v = + match Js.to_string (Js.typeof v) with + | "string" -> `String (Js.to_string (Js.Unsafe.coerce v)) + | "number" -> `Float (Obj.magic v) + | "boolean" -> `Bool (Js.to_bool (Obj.magic v)) + | "undefined" -> `Null (* Oh yeah! *) + | "object" -> + if v == Js.Unsafe.pure_js_expr "null" then + `Null + else if Js.instanceof v (Js.Unsafe.pure_js_expr "Array") then + let rec loop acc n = + if n < 0 then + `A acc + else + loop (Js.Unsafe.get v n :: acc) (n - 1) + in + loop [] (Js.Unsafe.get v (Js.string "length") - 1) + else + let fields : Js.js_string Js.t list = + Array.to_list @@ Js.to_array + (Js.Unsafe.fun_call + (Js.Unsafe.js_expr + "(function(o){\ + \ var p=[];\ + \ for(var n in o){if(o.hasOwnProperty(n)){p.push(n);}}\ + \ return p;\ + })") + [| Js.Unsafe.inject v |]) in + `O (List.map + (fun f -> Js.to_string f, Js.Unsafe.get v f) + fields) + | _ -> invalid_arg "Json_repr_browser.Repr.view" + + let repr_uid = Json_repr.repr_uid () + +end + +type value = Repr.value + +let js_stringify ?indent obj = + Js.Unsafe.meth_call + (Js.Unsafe.variable "JSON") + "stringify" + (match indent with + | None -> + [| Js.Unsafe.inject obj |] + | Some indent -> + [| Js.Unsafe.inject obj ; + Js.Unsafe.inject Js.null ; + Js.Unsafe.inject indent |]) + +let parse_js_string jsstr = + Js.Unsafe.meth_call + (Js.Unsafe.variable "JSON") + "parse" + [| Js.Unsafe.inject jsstr |] + +let stringify ?indent obj = + Js.to_string (js_stringify ?indent obj) + +let parse str = + parse_js_string (Js.string str) + +module Json_encoding = Json_encoding.Make (Repr) +module Json_query = Json_query.Make (Repr) diff --git a/vendors/ocplib-json-typed/src/json_repr_browser.mli b/vendors/ocplib-json-typed/src/json_repr_browser.mli new file mode 100644 index 000000000..daaa21454 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr_browser.mli @@ -0,0 +1,46 @@ +(** Native browser representation of JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** An abstract type for native browser objects. *) +type value + +(** A view over the browser representation.*) +module Repr : Json_repr.Repr with type value = value + +(** Pre-instanciated {!Json_encoding.Make}. *) +module Json_encoding : module type of Json_encoding.Make (Repr) + +(** Pre-instanciated {!Json_encoding.Make}. *) +module Json_query : module type of Json_query.Make (Repr) + +(** Parse a JSON string using the native browser parser. *) +val parse : string -> value + +(** Produce a JSON string using the native browser printer. + + If indent is not present, everything is printed on a single line. + Otherwise, it is the number (up to 10) of spaces inserted at + beginning of lines for each indentation level. *) +val stringify : ?indent: int -> value -> string + +(** Same as {!parse} with native browser strings. *) +val parse_js_string : Js.js_string Js.t -> value + +(** Same as {!stringify} with native browser strings. *) +val js_stringify : ?indent: int -> value -> Js.js_string Js.t diff --git a/vendors/ocplib-json-typed/src/json_repr_bson.ml b/vendors/ocplib-json-typed/src/json_repr_bson.ml new file mode 100644 index 000000000..6c7a0bb7d --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr_bson.ml @@ -0,0 +1,390 @@ +(* Representations of JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +open Json_repr + +module Repr = struct + type serialized = + { buffer : bytes ; + offset : int ; + length : int ; + array_field : bool } + and deserialized = + [ `O of (string * value) list + | `A of value list + | `Bool of bool + | `Float of float + | `String of string + | `Null ] + and node = + | Deserialized of deserialized + | Serialized of serialized + | Both of deserialized * serialized + and value = + { mutable node : node ; + conforming : bool ; (* when lazily deserializing the root *) + cache : bool (* when lazily deserializing *) } + + module LEB = EndianBytes.LittleEndian_unsafe + + exception Bson_decoding_error of string * bytes * int + + let view root = + match root.node with + | Deserialized deserialized + | Both (deserialized, _) -> deserialized + | Serialized ({ buffer ; offset ; length ; array_field } as serialized) -> + let offset = ref offset in + let length = ref length in + let error fmt = + Format.ksprintf + (fun msg -> raise (Bson_decoding_error (msg, buffer, !offset))) + fmt in + let box node = + { node ; conforming = false ; cache = root.cache } in + let skip n = + offset := !offset + n ; + length := !length - n in + let read_float () = + if !length < 8 then + error "not enough data, double expected (8 bytes)" ; + let res = LEB.get_double buffer !offset in + skip 8 ; + res in + let read_string () = + if !length < 4 then + error "not enough data, string size tag expected (4 bytes)" ; + let strlen = Int32.to_int (LEB.get_int32 buffer !offset) - 1 in + skip 4 ; + if !length < strlen then + error "not enough data, string expected (%d bytes)" strlen ; + let res = Bytes.sub_string buffer !offset strlen in + skip strlen ; + if !length < 1 then + error "not enough data, string terminator expected (0x00)" ; + if LEB.get_int8 buffer !offset <> 0x00 then + error "string terminator expected (0x00)" ; + skip 1 ; + res in + let read_bool () = + if !length < 1 then + error "not enough data, bool expected (1 byte)" ; + let res = match LEB.get_int8 buffer !offset with + | 0x00 -> false + | 0x01 -> true + | byte -> error "invalid bool value (0x%02X)" byte in + skip 1 ; + res in + let read_field_name () = + let rec find_terminator len = + if !length = 0 then + error "not enough data, field name terminator expected (0x00)" ; + match LEB.get_int8 buffer !offset with + | 0x00 -> + skip (-len) ; + len + | _ -> + skip 1 ; + find_terminator (len + 1) in + let fieldlen = find_terminator 0 in + let res = Bytes.sub_string buffer !offset fieldlen in + skip (fieldlen + 1) ; + res in + let deserialized = + if !length < 5 then + error "not enough data for size and terminator" ; + let size = Int32.to_int (LEB.get_int32 buffer !offset) in + if size <> !length then + error "size tag inconsistent with actual data" ; + skip 4 ; + let tag = LEB.get_int8 buffer !offset in + if tag = 0x00 then begin + if !length = 1 then + `O [] + else + error "early terminator" ; + end else if not root.conforming && tag land 0xF0 = 0x80 then begin + skip 1 ; + let res = match tag land 0x0F with + | 0x01 -> `Float (read_float ()) + | 0x02 -> `String (read_string ()) + | 0x08 -> `Bool (read_bool ()) + | 0x0A -> `Null + | tag -> + error "unknown immediate tag (0x%02X)" tag in + if !length <> 1 then + error "not enough data, terminator expected (0x00)" ; + if LEB.get_int8 buffer !offset <> 0x00 then + error "terminator expected (0x00)" ; + skip 1 ; + res + end else begin + let rec loop acc = + let tag = LEB.get_int8 buffer !offset in + if tag = 0x00 then + if !length = 1 then + if array_field then + try + let rec to_array acc i = function + | [] -> `A (List.rev acc) + | (name, bson) :: rest -> + if name = string_of_int i then + to_array (bson :: acc) (i + 1) rest + else raise Exit in + to_array [] 0 (List.rev acc) + with Exit -> + error "invalid field names for array field" + else + `O (List.rev acc) + else + error "early terminator" + else begin + skip 1 ; + match tag with + | 0x01 -> + let name = read_field_name () in + loop ((name, box (Deserialized (`Float (read_float ())))) :: acc) + | 0x02 -> + let name = read_field_name () in + loop ((name, box (Deserialized (`String (read_string ())))) :: acc) + | 0x08 -> + let name = read_field_name () in + loop ((name, box (Deserialized (`Bool (read_bool ())))) :: acc) + | 0x0A -> + let name = read_field_name () in + loop ((name, box (Deserialized (`Null))) :: acc) + | 0x03 | 0x04 -> + let name = read_field_name () in + if !length < 4 then + error "not enough data, subdocument size tag expected (4 bytes)" ; + let doclen = Int32.to_int (LEB.get_int32 buffer !offset) in + if !length < doclen then + error "not enough data, subdocument expected (%d bytes)" doclen ; + let serialized = + { buffer ; length = doclen ; offset = !offset ; + array_field = (tag = 0x04) } in + skip doclen ; + loop ((name, box (Serialized serialized)) :: acc) + | tag -> + error "unknown tag (0x%02X)" tag + end in + loop [] + end in + if root.cache then begin + root.node <- Both (deserialized, serialized) + end else begin + root.node <- Deserialized deserialized + end ; + deserialized + + let repr deserialized = + { node = (Deserialized deserialized) ; + conforming = false ; + cache = true } + + let to_bytes ~cache ~conforming root = + match root.node with + | Serialized serialized + | Both (_, serialized) -> + if serialized.offset = 0 + && serialized.length = Bytes.length serialized.buffer then + serialized.buffer + else + Bytes.sub serialized.buffer serialized.offset serialized.length + | Deserialized _ -> + let rec compute_size bson = + match bson.node with + | Serialized { length } + | Both (_, { length }) -> + length + | Deserialized deserialized -> + match deserialized with + | `Float _ -> 4 + 1 + 8 + 1 + | `String str -> 4 + 1 + 4 + String.length str + 1 + 1 + | `Bool _ -> 4 + 1 + 1 + 1 + | `Null -> 4 + 1 + 1 + | `O fields -> + let acc = List.fold_left + (fun acc (name, bson) -> + let self = match view bson with + | `Float _ -> 8 + | `String str -> 4 + String.length str + 1 + | `Bool _ -> 1 + | `Null -> 0 + | `O _ | `A _ -> compute_size bson in + acc + 1 + String.length name + 1 + self) + 0 fields in + 4 + acc + 1 + | `A cells -> + let acc, _ = List.fold_left + (fun (acc, i) bson -> + let self = match view bson with + | `Float _ -> 8 + | `String str -> 4 + String.length str + 1 + | `Bool _ -> 1 + | `Null -> 0 + | `O _ | `A _ -> compute_size bson in + let rec digits acc i = + if i <= 9 then (1 + acc) + else digits (1 + acc) (i / 10) in + (acc + 1 + digits 0 i + 1 + self, i + 1)) + (0, 0) cells in + 4 + acc + 1 in + let computed_size = compute_size root in + let result = Bytes.create computed_size in + let pos = ref 0 in + let (+=) r i = r := !r + i in + let reserve_size_stamp () = + let offset = !pos in + pos += 4 ; + fun () -> + LEB.set_int8 result !pos 0x00 ; + pos += 1 ; + let size = Int32.of_int (!pos - offset) in + LEB.set_int32 result offset size in + let rec serialize_toplevel conforming = function + | `Float _ | `String _ | `Bool _ | `Null | `A _ when conforming -> + raise (Invalid_argument "Json_repr.bson_to_bytes") + | `Float f -> + let update_size_stamp = reserve_size_stamp () in + LEB.set_int8 result !pos 0x81 ; + pos += 1 ; + LEB.set_double result !pos f ; + pos += 8 ; + update_size_stamp () + | `String str -> + let update_size_stamp = reserve_size_stamp () in + LEB.set_int8 result !pos 0x82 ; + pos += 1 ; + let strlen = String.length str in + LEB.set_int32 result !pos Int32.(of_int (strlen + 1)) ; + pos += 4 ; + Bytes.blit_string str 0 result !pos strlen ; + pos += strlen ; + LEB.set_int8 result !pos 0x00 ; + pos += 1 ; + update_size_stamp () + | `Bool b -> + let update_size_stamp = reserve_size_stamp () in + LEB.set_int8 result !pos 0x88 ; + pos += 1 ; + LEB.set_int8 result !pos (if b then 0x01 else 0x00) ; + pos += 1 ; + update_size_stamp () + | `Null -> + let update_size_stamp = reserve_size_stamp () in + LEB.set_int8 result !pos 0x8A ; + pos += 1 ; + update_size_stamp () + | `O _ | `A _ as fields_or_cells -> + let fields = match fields_or_cells with + | `O fields -> fields + | `A cells -> List.mapi (fun i v -> string_of_int i, v) cells in + let update_size_stamp = reserve_size_stamp () in + serialize_fields fields ; + update_size_stamp () + and serialize_fields fields = + List.iter + (fun (name, bson) -> + LEB.set_int8 result !pos + (match view bson with + | `Float _ -> 0x01 + | `String _ -> 0x02 + | `Bool _ -> 0x08 + | `Null -> 0x0A + | `O _ -> 0x03 ; + | `A _ -> 0x04) ; + pos += 1 ; + let strlen = String.length name in + Bytes.blit_string name 0 result !pos strlen ; + pos += strlen ; + LEB.set_int8 result !pos 0x00 ; + pos += 1 ; + begin match view bson with + | `Float f -> + LEB.set_double result !pos f ; + pos += 8 ; + | `String str -> + let strlen = String.length str in + LEB.set_int32 result !pos Int32.(of_int (strlen + 1)) ; + pos += 4 ; + Bytes.blit_string str 0 result !pos strlen ; + pos += strlen ; + LEB.set_int8 result !pos 0x00 ; + pos += 1 ; + | `Bool b -> + LEB.set_int8 result !pos (if b then 0x01 else 0x00) ; + pos += 1 ; + | `Null -> () + | `O _ | `A _ -> serialize false bson + end) + fields + and serialize conforming bson = + match bson.node with + | Serialized { buffer ; offset ; length } + | Both (_, { buffer ; offset ; length }) -> + Bytes.blit buffer offset result !pos length ; + pos := !pos + length + | Deserialized deserialized -> + let offset = !pos in + serialize_toplevel conforming deserialized ; + let length = !pos - offset in + if cache then begin + let serialized = + let array_field = + match deserialized with `A _ -> true | _ -> false in + { buffer = result ; offset ; length ; array_field } in + bson.node <- Both (deserialized, serialized) + end in + serialize conforming root ; + result + + let from_bytes ~laziness ~cache ~conforming buffer = + let serialized = + { offset = 0 ; length = Bytes.length buffer ; buffer ; + array_field = false } in + let root = + { node = Serialized serialized ; conforming ; cache } in + let rec traverse bson = match view bson with + | `O fields -> List.iter (fun (_, bson) -> traverse bson) fields + | `A cells -> List.iter traverse cells + | `Float _ | `String _ | `Bool _ | `Null -> () in + if not laziness then begin + (* a simple traversal will expand the structure as a side effect *) + traverse root + end ; + root + + let repr_uid : value Json_repr.repr_uid = repr_uid () + +end + +type bson = Repr.value + +exception Bson_decoding_error = Repr.Bson_decoding_error + +let bson_to_bytes ?(cache = true) ?(conforming = false) bson = + Repr.to_bytes ~cache ~conforming bson + +let bytes_to_bson ?(laziness = true) ?(cache = true) ?(conforming = false) ~copy buffer = + let buffer = if copy then Bytes.copy buffer else buffer in + Repr.from_bytes ~laziness ~cache ~conforming buffer + +module Json_encoding = Json_encoding.Make (Repr) +module Json_query = Json_query.Make (Repr) diff --git a/vendors/ocplib-json-typed/src/json_repr_bson.mli b/vendors/ocplib-json-typed/src/json_repr_bson.mli new file mode 100644 index 000000000..592565cd0 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_repr_bson.mli @@ -0,0 +1,100 @@ +(** BSON representation of JSON documents *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** A intermediate representation for BSON, a binary encoding for JSON. + + Decoding and encoding is (optionally) done as lazily as possible. + First, the [view] function is able to unfold only one + level and not the whole structure. Also, serialized versions are + cached, so that later serializations of the same object are faster. + + Notes: + + 1. Only JSON compatible BSON documents are supported. + BSON extensions are not supported (int32, int64, timestamp, etc.). + 2. Arrays in BSON are stored inefficiently. + Prefer another binary format if you manipulate lots of arrays. + 3. We differ from BSON to allow toplevel immediates. + For this, we produce a document with only one byte indicating + the kind of immediate followed by the immediate. + The byte is [0x80 lor (the corresponding BSON field kind)]. + 4. We differ from BSON to allow unambiguous toplevel arrays. + As with (3), the subdocument to be decoded as an array is + preceded with a 0x84. + + Use the [conforming] flag to deactivates the extension from notes (3) + and (4). In this case, the toplevel value must be an object. *) +type bson + +(** A view over the {!bson} representation.*) +module Repr : Json_repr.Repr with type value = bson + +(** Pre-instanciated {!Json_encoding.Make}. *) +module Json_encoding : module type of Json_encoding.Make (Repr) + +(** Pre-instanciated {!Json_encoding.Make}. *) +module Json_query : module type of Json_query.Make (Repr) + + +(** Serializes the intermediate BSON representation to actual BSON. + + By default, [conforming] is [false], so that any value can be serialized, + including immediates (see {!type:bson}). + + By default, [cache] is [true], so a future serialization of the + same data will be faster. The resulting bytes are stored in the + value. You may want to turn this off if these values have a long + lifespan, and that you care more about memory consumption than + serialization speed. + + Will raise [Invalid_argument "Json_repr.bson_to_bytes"] when + [conforming] and trying to serialize a toplevel array or immediate. *) +val bson_to_bytes : + ?cache: bool -> ?conforming: bool -> + bson -> bytes + +(** Bson decoding error, with a message, the BSON and an offset. *) +exception Bson_decoding_error of string * bytes * int + +(** Creates a lazily unfolded representation for some BSON. + Because of the mutability of [bytes] and this laziness, + set the copy parameter to [true] if you are not sure that the + [bytes] will not be mutated in the future. + + By default, [conforming] is [false], so that any value can be serialized, + including immediates (see {!type:bson}). + + By default, [cache] is [true], so a future serialization of the + same data will be faster. The input bytes are stored in the + value. You may want to turn this off if these values have a long + lifespan, and that you care more about memory consumption than + serialization speed. + + By default, [laziness] is [true]. If the data is a serialized + object, it means that only the field names are read, the field + values are eluded, and will be deserialized on demand when calling + [Repr.view]. This implies that {!Bson_decoding_error} may be + raised later. If set to [false], the whole structure is decoded + upfront, so any decoding error will happen at this point. This may + be preferable mostly when reading from untusted sources. + + May raise {!Bson_decoding_error}. *) +val bytes_to_bson : + ?laziness: bool -> ?cache: bool -> ?conforming: bool -> + copy: bool -> bytes -> bson diff --git a/vendors/ocplib-json-typed/src/json_schema.ml b/vendors/ocplib-json-typed/src/json_schema.ml new file mode 100644 index 000000000..334de2da3 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_schema.ml @@ -0,0 +1,1215 @@ +(* Abstract representation of JSON schemas. *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(* TODO: validator *) + +open Json_query + +(* The currently handled version *) +let version = "http://json-schema.org/draft-04/schema#" + +(*-- types -----------------------------------------------------------------*) + +(* The root of a schema with the named definitions, + a precomputed ID-element map and a cache for external documents. *) +type schema = + { root : element ; + source : Uri.t (* whose fragment should be empty *) ; + definitions : (path * element) list ; + ids : (string * element) list ; + world : schema list } + +and element = + { title : string option ; + description : string option ; + default : Json_repr.any option ; + enum : Json_repr.any list option ; + kind : element_kind ; + format : string option ; + id : string option } + +and element_kind = + | Object of object_specs + | Array of element list * array_specs + | Monomorphic_array of element * array_specs + | Combine of combinator * element list + | Def_ref of path + | Id_ref of string + | Ext_ref of Uri.t + | String of string_specs + | Integer of numeric_specs + | Number of numeric_specs + | Boolean | Null | Any + | Dummy + +and combinator = + | Any_of | One_of | All_of | Not + +and array_specs = + { min_items : int ; + max_items : int option ; + unique_items : bool ; + additional_items : element option } + +and numeric_specs = + { multiple_of : float option ; + minimum : (float * [ `Inclusive | `Exclusive ]) option ; + maximum : (float * [ `Inclusive | `Exclusive ]) option } + +and object_specs = + { properties : (string * element * bool * Json_repr.any option) list ; + pattern_properties : (string * element) list ; + additional_properties : element option ; + min_properties : int ; + max_properties : int option ; + schema_dependencies : (string * element) list ; + property_dependencies : (string * string list) list } + +and string_specs = + { pattern : string option ; + min_length : int ; + max_length : int option } + +(* box an element kind without any optional field *) +let element kind = + { title = None ; description = None ; default = None ; kind ; + format = None ; enum = None ; id = None } + +(*-- equality --------------------------------------------------------------*) + +let option_map f = function None -> None | Some v -> Some (f v) + +let rec eq_element a b = + a.title = b.title && + a.description = b.description && + option_map Json_repr.from_any a.default = + option_map Json_repr.from_any b.default && + option_map (List.map Json_repr.from_any) a.enum = + option_map (List.map Json_repr.from_any) b.enum && + eq_kind a.kind b.kind && + a.format = b.format && + a.id = b.id + +and eq_kind a b = match a, b with + | Object aa, Object ab -> eq_object_specs aa ab + | Array (esa, sa), Array (esb, sb) -> + List.length esa = List.length esb && + List.for_all2 eq_element esa esb && + eq_array_specs sa sb + | Monomorphic_array (ea, sa), Monomorphic_array (eb, sb) -> + eq_element ea eb && + eq_array_specs sa sb + | Combine (ca, esa), Combine (cb, esb) -> + ca = cb && + List.length esa = List.length esb && + List.for_all2 eq_element esa esb + | Def_ref pa, Def_ref pb -> pa = pb + | Id_ref ra, Id_ref rb -> ra = rb + | Ext_ref ra, Ext_ref rb -> ra = rb + | String sa, String sb -> sa = sb + | Integer na, Integer nb -> na = nb + | Number na, Number nb -> na = nb + | Boolean, Boolean -> true + | Null, Null -> true + | Any, Any -> true + | Dummy, Dummy -> true + | _ -> false + +and eq_object_specs a b = + a.min_properties = b.min_properties && + a.max_properties = b.max_properties && + List.sort compare a.property_dependencies = + List.sort compare b.property_dependencies && + begin match a.additional_properties, b.additional_properties with + | Some a, Some b -> eq_element a b + | None, None -> true + | _, _ -> false + end && + List.length a.pattern_properties = + List.length b.pattern_properties && + List.for_all2 + (fun (na, ea) (nb, eb) -> na = nb && eq_element ea eb) + (List.sort (fun (x, _) (y, _) -> compare x y) a.pattern_properties) + (List.sort (fun (x, _) (y, _) -> compare x y) b.pattern_properties) && + List.length a.schema_dependencies = + List.length b.schema_dependencies && + List.for_all2 + (fun (na, ea) (nb, eb) -> na = nb && eq_element ea eb) + (List.sort (fun (x, _) (y, _) -> compare x y) a.schema_dependencies) + (List.sort (fun (x, _) (y, _) -> compare x y) b.schema_dependencies) && + List.length a.properties = + List.length b.properties && + List.for_all2 + (fun (na, ea, ra, da) (nb, eb, rb, db) -> + na = nb && eq_element ea eb && ra = rb && + option_map Json_repr.from_any da = option_map Json_repr.from_any db) + (List.sort (fun (x, _, _, _) (y, _, _, _) -> compare x y) a.properties) + (List.sort (fun (x, _, _, _) (y, _, _, _) -> compare x y) b.properties) + +and eq_array_specs a b = + a.min_items = b.min_items && + a.max_items = b.max_items && + a.unique_items = b.unique_items && + match a.additional_items, b.additional_items with + | Some a, Some b -> eq_element a b + | None, None -> true + | _, _ -> false + +(*-- human readable output -------------------------------------------------*) + +let pp_string ppf s = + Json_repr.(pp (module Ezjsonm)) ppf (`String s) +let pp_num ppf m = + if abs_float m < 1000. then + Format.fprintf ppf "%g" m + else + let pos, m = + if m < 0. then (false, ~-. m) else (true, m) in + if List.fold_left (fun acc d -> + if acc then acc else + let v = log (m +. d) /. log 2. in + if abs_float (ceil v -. v) < 0.00001 then begin + Format.fprintf ppf "%s2^%g" (if pos then "" else "-") v ; + if (pos && d < 0.) || (not pos && d > 0.) then + Format.fprintf ppf "+%g" (abs_float d) ; + if (pos && d > 0.) || (not pos && d < 0.) then + Format.fprintf ppf "-%g" (abs_float d) ; + true + end else false) + false [ -2. ; -1. ; 0. ; 1. ; 2. ] then () else + Format.fprintf ppf "%f" m +let pp_numeric_specs ppf { multiple_of ; minimum ; maximum } = + Format.fprintf ppf "%a%a%a" + (fun ppf -> function None -> () | Some v -> Format.fprintf ppf "multiple of %g" v) + multiple_of + (fun ppf -> function + | (None, _, _) | (_, None, None) -> () + | _ -> Format.fprintf ppf ", ") + (multiple_of, minimum, maximum) + (fun ppf -> function + | None, None -> () + | minimum, maximum -> + Format.fprintf ppf "∈ %a, %a" + (fun ppf -> function + | None -> Format.fprintf ppf "]∞" + | Some (m, `Exclusive) -> Format.fprintf ppf "]%a" pp_num m + | Some (m, `Inclusive) -> Format.fprintf ppf "[%a" pp_num m) + minimum + (fun ppf -> function + | None -> Format.fprintf ppf "∞[" + | Some (m, `Exclusive) -> Format.fprintf ppf "%a[" pp_num m + | Some (m, `Inclusive) -> Format.fprintf ppf "%a]" pp_num m) + maximum) + (minimum, maximum) +let pp_path ppf = function + | [ `Field "definitions" ; `Field name ] -> Format.fprintf ppf "%s" name + | path -> Json_query.(print_path_as_json_path ~wildcards:true) ppf path +let pp_desc element = match element with + | { title = None ; description = None } -> None + | { title = Some text ; description = None } + | { title = None ; description = Some text } -> + Some begin fun ppf () -> + Format.fprintf ppf "/* @[%a@] */" + Format.pp_print_text text + end + | { title = Some title ; description = Some description } -> + Some begin fun ppf () -> + Format.fprintf ppf "/* @[@[%a@]@,@[%a@]@] */" + Format.pp_print_text title + Format.pp_print_text description + end +let rec pp_element ppf element = + match element.id with + | Some id -> + Format.fprintf ppf "#%s" id + | None -> + match element.format with + | Some format -> + Format.fprintf ppf "%s" format + | None -> + match element.enum with + | Some cases -> + let pp_sep ppf () = + Format.fprintf ppf "@ | " in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep (Json_repr.pp_any ~compact: false ())) + cases + | None -> + match pp_desc element with + | Some pp_desc -> + let stripped = + { element with title = None ; description = None } in + begin match element.kind with + | Combine _ -> + Format.fprintf ppf "%a@,%a" + pp_desc () pp_element stripped + | Object specs -> + Format.fprintf ppf "@[{ %a@,%a }@]" + pp_desc () pp_object_contents specs + | _ -> + Format.fprintf ppf "%a@ %a" pp_element stripped pp_desc () + end + | None -> + begin match element.kind with + | String { pattern = None ; min_length = 0 ; max_length = None} -> + Format.fprintf ppf "string" + | String { pattern = Some pat ; min_length = 0 ; max_length = None} -> + Format.fprintf ppf "/%s/" pat + | String { pattern ; min_length ; max_length } -> + Format.fprintf ppf "%a (%alength%a)" + (fun ppf -> function + | None -> Format.fprintf ppf "string" + | Some pat -> Format.fprintf ppf "/%s/" pat) + pattern + (fun ppf n -> if n > 0 then Format.fprintf ppf "%d <= " n) + min_length + (fun ppf -> function None -> () | Some m -> Format.fprintf ppf "<= %d" m) + max_length + | Integer { multiple_of = None ; minimum = None ; maximum = None } -> + Format.fprintf ppf "integer" + | Integer specs -> + Format.fprintf ppf "integer %a" pp_numeric_specs specs + | Number { multiple_of = None ; minimum = None ; maximum = None } -> + Format.fprintf ppf "number" + | Number specs -> + Format.fprintf ppf "number %a" pp_numeric_specs specs + | Id_ref id -> + Format.fprintf ppf "#%s" id + | Def_ref path -> + Format.fprintf ppf "$%a" pp_path path + | Ext_ref uri -> + Format.fprintf ppf "$%a" Uri.pp_hum uri + | Boolean -> + Format.fprintf ppf "boolean" + | Null -> + Format.fprintf ppf "null" + | Any -> + Format.fprintf ppf "any" + | Dummy -> assert false + | Combine (Not, [ elt ]) -> + Format.fprintf ppf "! %a" pp_element elt + | Combine (c, elts) -> + let pp_sep ppf () = match c with + | Any_of -> Format.fprintf ppf "@ | " + | One_of -> Format.fprintf ppf "@ || " + | All_of -> Format.fprintf ppf "@ && " + | _ -> assert false in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep pp_element) + elts + | Object { properties = [] ; + pattern_properties = [] ; + additional_properties = None ; + min_properties = 0 ; + max_properties = Some 0 ; + schema_dependencies = [] ; + property_dependencies = [] } -> + Format.fprintf ppf "{}" + | Object specs -> + Format.fprintf ppf "@[{ %a }@]" + pp_object_contents specs + | Array (_, { max_items = Some 0 }) + | Monomorphic_array (_, { max_items = Some 0 }) -> + Format.fprintf ppf "[]" + | Array (elements, { additional_items }) -> + let pp_sep = + let first = ref true in + fun ppf () -> + if !first then + first := false + else + Format.fprintf ppf ",@ " in + Format.fprintf ppf "@[[ " ; + List.iter (fun elt -> + Format.fprintf ppf "%a%a" + pp_sep () + pp_element elt) + elements ; + begin match additional_items with + | None -> () + | Some { kind = Any } -> + Format.fprintf ppf "%a,@ ..." pp_sep () + | Some elt -> + Format.fprintf ppf "%a,@ %a ..." + pp_sep () + pp_element elt + end ; + Format.fprintf ppf " ]@]" + | Monomorphic_array (elt, { additional_items = None }) -> + Format.fprintf ppf "[ %a ... ]" + pp_element elt + | Monomorphic_array (elt, { additional_items = Some { kind = Any } }) -> + Format.fprintf ppf "@[[ %a ...,@ ... ]@]" + pp_element elt + | Monomorphic_array (elt, { additional_items = Some add_elt }) -> + (* TODO: find a good way to print length *) + Format.fprintf ppf "@[[ %a ...,@ %a ... ]@]" + pp_element elt pp_element add_elt + end +and pp_object_contents ppf + { properties ; pattern_properties ; additional_properties } = + (* TODO: find a good way to print length / dependencies *) + let pp_sep = + let first = ref true in + fun ppf () -> + if !first then + first := false + else + Format.fprintf ppf ",@ " in + List.iter (fun (name, elt, req, _) -> + Format.fprintf ppf "%a@[%a%s:@ %a@]" + pp_sep () + pp_string name (if req then "" else "?") + pp_element elt) + properties ; + List.iter (fun (name, elt) -> + Format.fprintf ppf "%a@[/%s/:@ %a@]" + pp_sep () + name + pp_element elt) + pattern_properties ; + begin match additional_properties with + | None -> () + | Some { kind = Any } -> + Format.fprintf ppf "%a..." pp_sep () + | Some elt -> + Format.fprintf ppf "%a@[*:@ %a@]" + pp_sep () + pp_element elt + end +let pp ppf schema = + Format.fprintf ppf "@[" ; + pp_element ppf schema.root ; + List.iter (fun (path, elt) -> + match pp_desc elt with + | None -> + Format.fprintf ppf "@,@[$%a:@ %a@]" + pp_path path + pp_element elt + | Some pp_desc -> + let stripped = + { elt with title = None ; description = None } in + Format.fprintf ppf "@,@[$%a:@,%a@,%a@]" + pp_path path + pp_desc () + pp_element stripped) + schema.definitions ; + List.iter (fun (id, elt) -> + match pp_desc elt with + | None -> + Format.fprintf ppf "@,@[#%s:@ %a@]" + id + pp_element { elt with id = None } + | Some pp_desc -> + let stripped = + { elt with title = None ; description = None ; id = None } in + Format.fprintf ppf "@,@[#%s:@,%a@,%a@]" + id + pp_desc () + pp_element stripped) + schema.ids ; + Format.fprintf ppf "@]" + +(*-- errors ----------------------------------------------------------------*) + +exception Cannot_parse of path * exn +exception Dangling_reference of Uri.t +exception Bad_reference of string +exception Unexpected of string * string +exception Duplicate_definition of path * element * element + +let rec print_error ?print_unknown ppf = function + | Cannot_parse (path, exn) -> + Format.fprintf ppf + "@[Schema parse error:@,At %a@,%a@]" + (Json_query.print_path_as_json_path ~wildcards:true) path + (print_error ?print_unknown) exn + | Dangling_reference uri -> + Format.fprintf ppf + "Dangling reference %s" (Uri.to_string uri) + | Bad_reference str -> + Format.fprintf ppf + "Illegal reference notation %s" str + | Unexpected (unex, ex) -> + Format.fprintf ppf + "Unexpected %s instead of %s" unex ex + | Duplicate_definition (name, elt, defelt) -> + Format.fprintf ppf + "@[Duplicate definition %a@,\ + To be inserted:@,\ + \ @[%a@]@,\ + Already present:@,\ + \ @[%a@]@]" + (Json_query.print_path_as_json_pointer ~wildcards:false) name + pp_element elt + pp_element defelt + | exn -> + Json_query.print_error ?print_unknown ppf exn + +(*-- internal definition table handling ------------------------------------*) + +let find_definition name defs = + List.assoc name defs + +let definition_exists name defs = + List.mem_assoc name defs + +let insert_definition name elt defs = + let rec insert = function + | [] -> + [ (name, elt) ] + | (defname, _) as def :: rem when defname <> name -> + def :: insert rem + | (_, { kind = Dummy }) :: rem -> + (name, elt) :: rem + | (_, defelt) :: rem -> + if not (eq_element elt defelt) then + raise (Duplicate_definition (name, elt, defelt)) ; + (name, elt) :: rem in + insert defs + +module Make (Repr : Json_repr.Repr) = struct + + module Query = Json_query.Make (Repr) + open Query + + (*-- printer ---------------------------------------------------------------*) + + let to_json schema = + (* functional JSON building combinators *) + let obj l = Repr.repr (`O l) in + let set_always f v = + [ f, Repr.repr v ] in + let set_if_some f v cb = + match v with None -> [] | Some v -> [ f, Repr.repr (cb v) ] in + let set_if_cons f v cb = + match v with [] -> [] | v -> [ f, Repr.repr (cb v) ] in + let set_if_neq f v v' cb = + if v <> v' then [ f, Repr.repr (cb v) ] else [] in + (* recursive encoder *) + let rec format_element + { title ; description ; default ; enum ; kind ; format } = + set_if_some "title" title (fun s -> `String s) @ + set_if_some "description" description (fun s -> `String s) @ + begin match kind with + | Object specs -> + let required = List.fold_left + (fun r (n, _, p, _) -> if p then Repr.repr (`String n) :: r else r) + [] specs.properties in + let properties = + List.map + (fun (n, elt, _, _) -> n, obj (format_element elt)) + specs.properties in + set_always "type" (`String "object") @ + set_always "properties" (`O properties) @ + set_if_cons "required" required (fun l -> `A l) @ + set_if_cons "patternProperties" specs.pattern_properties + (fun fs -> `O (List.map (fun (n, elt) -> n, obj (format_element elt)) fs)) @ + set_if_neq "additionalProperties" specs.additional_properties (Some (element Any)) + (function + | None -> `Bool false + | Some elt -> `O (format_element elt)) @ + set_if_neq "minProperties" specs.min_properties 0 + (fun i -> `Float (float i)) @ + set_if_some "maxProperties" specs.max_properties + (fun i -> `Float (float i)) @ + set_if_cons "schemaDependencies" specs.schema_dependencies + (fun fs -> `O (List.map (fun (n, elt) -> n, obj (format_element elt)) fs)) @ + set_if_cons "propertyDependencies" specs.property_dependencies + (fun fs -> + let property_dependencies = + let strings ls = List.map (fun s -> Repr.repr (`String s)) ls in + List.map (fun (n, ls) -> n, Repr.repr (`A (strings ls))) fs in + `O property_dependencies) + | Array (elts, specs) -> + set_always "type" (`String "array") @ + set_always "items" (`A (List.map (fun elt -> obj (format_element elt)) elts)) @ + set_if_neq "minItems" specs.min_items 0 (fun i -> `Float (float i)) @ + set_if_some "maxItems" specs.max_items (fun i -> `Float (float i)) @ + set_if_neq "uniqueItems" specs.unique_items false (fun b -> `Bool b) @ + set_if_neq "additionalItems" + specs.additional_items (Some (element Any)) + (function + | None -> `Bool false + | Some elt -> `O (format_element elt)) + | Monomorphic_array (elt, {min_items ; max_items ; unique_items }) -> + set_always "type" (`String "array") @ + set_always "items" (`O (format_element elt)) @ + set_if_neq "minItems" + min_items 0 + (fun i -> `Float (float i)) @ + set_if_some "maxItems" + max_items + (fun i -> `Float (float i)) @ + set_if_neq "uniqueItems" + unique_items false + (fun b -> `Bool b) + | Combine (c, elts) -> + let combinator = function + | Any_of -> "anyOf" + | One_of -> "oneOf" + | All_of -> "allOf" + | Not -> "not" in + set_always (combinator c) (`A (List.map (fun elt -> obj (format_element elt)) elts)) + | Def_ref path -> + set_always "$ref" (`String ("#" ^ (json_pointer_of_path path))) + | Id_ref name -> + set_always "$ref" (`String ("#" ^ name)) + | Ext_ref uri -> + set_always "$ref" (`String (Uri.to_string uri)) + | Integer specs -> + set_always "type" (`String "integer") @ + set_if_some "multipleOf" + specs.multiple_of (fun v -> `Float v) @ + (match specs.minimum with + | None -> [] + | Some (v, `Inclusive) -> + [ "minimum", Repr.repr (`Float v) ] + | Some (v, `Exclusive) -> + [ "minimum", Repr.repr (`Float v) ; + "exclusiveMinimum", Repr.repr (`Bool true) ] ) @ + (match specs.maximum with + | None -> [] + | Some (v, `Inclusive) -> + [ "maximum", Repr.repr (`Float v) ] + | Some (v, `Exclusive) -> + [ "maximum", Repr.repr (`Float v) ; + "exclusiveMaximum", Repr.repr (`Bool true) ] ) + | Number specs -> + set_always "type" (`String "number") @ + set_if_some "multipleOf" specs.multiple_of (fun v -> `Float v) @ + (match specs.minimum with + | None -> [] + | Some (v, `Inclusive) -> + [ "minimum", Repr.repr (`Float v) ] + | Some (v, `Exclusive) -> + [ "minimum", Repr.repr (`Float v) ; + "exclusiveMinimum", Repr.repr (`Bool true) ] ) @ + (match specs.maximum with + | None -> [] + | Some (v, `Inclusive) -> + [ "maximum", Repr.repr (`Float v) ] + | Some (v, `Exclusive) -> + [ "maximum", Repr.repr (`Float v) ; + "exclusiveMaximum", Repr.repr (`Bool true) ] ) + | String { pattern ; min_length ; max_length } -> + set_always "type" (`String "string") @ + set_if_neq "minLength" min_length 0 (fun i -> `Float (float i)) @ + set_if_some "maxLength" max_length (fun i -> `Float (float i)) @ + set_if_some "pattern" pattern (fun s -> `String s) + | Boolean -> + set_always "type" (`String "boolean") + | Null -> + set_always "type" (`String "null") + | Dummy -> + invalid_arg "Json_schema.to_json: remaining dummy element" + | Any -> [] end @ + set_if_some "default" default (fun j -> + Repr.view (Json_repr.any_to_repr (module Repr) j)) @ + set_if_some "enum" enum (fun js -> + `A (List.map (Json_repr.any_to_repr (module Repr)) js)) @ + set_if_some "format" format (fun s -> `String s) in + List.fold_left + (fun acc (n, elt) -> insert n (obj (format_element elt)) acc) + (obj (set_always "$schema" (`String version) @ + format_element schema.root)) + schema.definitions + + let unexpected kind expected = + let kind =match kind with + | `O [] -> "empty object" + | `A [] -> "empty array" + | `O _ -> "object" + | `A _ -> "array" + | `Null -> "null" + | `String "" -> "empty string" + | `String _ -> "string" + | `Float _ -> "number" + | `Bool _ -> "boolean" in + Cannot_parse ([], Unexpected (kind, expected)) + + (*-- parser ----------------------------------------------------------------*) + + let at_path p = function Cannot_parse (l, err) -> Cannot_parse (p @ l, err) | exn -> exn + let at_field n = at_path [ `Field n ] + let at_index i = at_path [ `Index i ] + + let of_json json = + (* parser combinators *) + let opt_field obj n = match Repr.view obj with + | `O ls -> (try Some (List.assoc n ls) with Not_found -> None) + | _ -> None in + let opt_field_view obj n = match Repr.view obj with + | `O ls -> (try Some (Repr.view (List.assoc n ls)) with Not_found -> None) + | _ -> None in + let opt_string_field obj n = match opt_field_view obj n with + | Some (`String s) -> Some s + | Some k -> raise (at_field n @@ unexpected k "string") + | None -> None in + let opt_bool_field def obj n = match opt_field_view obj n with + | Some (`Bool b) -> b + | Some k -> raise (at_field n @@ unexpected k "bool") + | None -> def in + let opt_int_field obj n = match opt_field_view obj n with + | Some (`Float f) when (fst (modf f) = 0. + && f <= 2. ** 53. + && f >= -2. ** 53.) -> + Some f + | Some k -> raise (at_field n @@ unexpected k "integer") + | None -> None in + let opt_length_field obj n = match opt_field_view obj n with + | Some (`Float f) when (fst (modf f) = 0. + && f <= 2. ** 30. + && f >= 0.) -> + Some (int_of_float f) + | Some k -> raise (at_field n @@ unexpected k "length") + | None -> None in + let opt_float_field obj n = match opt_field_view obj n with + | Some (`Float f) -> Some f + | Some k -> raise (at_field n @@ unexpected k "number") + | None -> None in + let opt_array_field obj n = match opt_field_view obj n with + | Some (`A s) -> Some s + | Some k -> raise (at_field n @@ unexpected k "array") + | None -> None in + let opt_uri_field obj n = match opt_string_field obj n with + | None -> None + | Some uri -> + match Uri.canonicalize (Uri.of_string uri) with + | exception _ -> raise (Cannot_parse ([], Bad_reference (uri ^ " is not a valid URI"))) + | uri -> Some uri in + (* local resolution of definitions *) + let schema_source = match opt_uri_field json "id" with + | Some uri -> Uri.with_fragment uri None + | None -> Uri.empty in + let collected_definitions = ref [] in + let collected_id_defs = ref [] in + let collected_id_refs = ref [] in + let rec collect_definition : Uri.t -> element_kind = fun uri -> + match Uri.host uri, Uri.fragment uri with + | Some _ (* Actually means: any of host, user or port is defined. *), _ -> + Ext_ref uri + | None, None -> + raise (Cannot_parse ([], Bad_reference (Uri.to_string uri ^ " has no fragment"))) + | None, Some fragment when not (String.contains fragment '/') -> + collected_id_refs := fragment :: !collected_id_refs ; + Id_ref fragment + | None, Some fragment -> + let path = + try path_of_json_pointer ~wildcards:false fragment + with err -> raise (Cannot_parse ([], err)) in + try + let raw = query path json in + if not (definition_exists path !collected_definitions) then begin + (* dummy insertion so we don't recurse and we support cycles *) + collected_definitions := insert_definition path (element Dummy) !collected_definitions ; + let elt = try parse_element schema_source raw + with err -> raise (at_path path err) in + (* actual insertion *) + collected_definitions := insert_definition path elt !collected_definitions + end ; + Def_ref path + with Not_found -> raise (Cannot_parse ([], Dangling_reference uri)) + (* recursive parser *) + and parse_element : Uri.t -> Repr.value -> element = fun source json -> + let id = opt_uri_field json "id" in + let id, source = match id with + | None -> None, source + | Some uri -> + let uri = Uri.canonicalize (Uri.resolve "http" source uri) in + Uri.fragment uri, Uri.with_fragment uri None in + (* We don't support inlined schemas, so we just drop elements with + external sources and replace them with external references. *) + if source <> schema_source then + element (Ext_ref (Uri.with_fragment source id)) + else + let id = match id with + | None -> None + | Some id when String.contains id '/' -> + raise (at_field "id" @@ Cannot_parse ([], Bad_reference (id ^ " is not a valid ID"))) + | Some id -> Some id in + (* We parse the various element syntaxes and combine them afterwards. *) + (* 1. An element with a known type field and associated fields. *) + let as_kind = + match opt_field_view json "type" with + | Some (`String name) -> + Some (element (parse_element_kind source json name)) + | Some (`A [] as k) -> + raise (at_field "type" @@ unexpected k "type, type array or operator") + | Some (`A l) -> + let rec items i acc = function + | [] -> + let kind = Combine (Any_of, List.rev acc) in + Some (element kind) + | `String name :: tl -> + let kind = parse_element_kind source json name in + let case = element kind in + items (succ i) (case :: acc) tl + | k :: _ -> + raise (at_field "type" @@ at_index i @@ unexpected k "type") + in items 0 [] (List.map Repr.view l) + | Some k -> + raise (at_field "type" @@ unexpected k "type, type array or operator") + | None -> None in + (* 2. A reference *) + let as_ref = + match opt_uri_field json "$ref" with + | Some uri -> + let path = collect_definition uri in + Some (element path) + | None -> None in + (* 3. Combined schemas *) + let as_nary name combinator others = + let build = function + | [] -> None (* not found and no auxiliary case *) + | [ case ] -> Some case (* one case -> simplify *) + | cases -> (* several cases build the combination node with empty options *) + let kind = Combine (combinator, cases) in + Some (element kind) in + match opt_field_view json name with + | Some (`A (_ :: _ as cases)) (* list of schemas *) -> + let rec items i acc = function + | elt :: tl -> + let elt = try parse_element source elt + with err -> raise (at_field name @@ at_index i @@ err) in + items (succ i) (elt :: acc) tl + | [] -> + build (others @ List.rev acc) + in items 0 [] cases + | None -> build others + | Some k -> raise (at_field name @@ unexpected k "a list of elements") in + (* 4. Negated schema *) + let as_not = + match opt_field_view json "not" with + | None -> None + | Some elt -> + let elt = try parse_element source (Repr.repr elt) + with err -> raise (at_field "not" err) in + let kind = Combine (Not, [ elt ]) in + Some (element kind) in + (* parse optional fields *) + let title = opt_string_field json "title" in + let description = opt_string_field json "description" in + let default = match opt_field json "default" with + | Some v -> Some (Json_repr.repr_to_any (module Repr) v) + | None -> None in + let enum =match opt_array_field json "enum" with + | Some v -> Some (List.map (Json_repr.repr_to_any (module Repr)) v) + | None -> None in + let format = opt_string_field json "format" in (* TODO: check format ? *) + (* combine all specifications under a big conjunction *) + let as_one_of = as_nary "oneOf" One_of [] in + let as_any_of = as_nary "anyOf" Any_of [] in + let all = [ as_kind ; as_ref ; as_not ; as_one_of ; as_any_of ] in + let cases = List.flatten (List.map (function None -> [] | Some e -> [ e ]) all) in + let kind = match as_nary "allOf" All_of cases with + | None -> Any (* no type, ref or logical combination found *) + | Some { kind } -> kind in + (* add optional fields *) + { title ; description ; default ; format ; kind ; enum ; id } + and parse_element_kind source json name = + let integer_specs json = + let multiple_of = opt_int_field json "multipleOf" in + let minimum = + if opt_bool_field false json "exclusiveMinimum" then + match opt_int_field json "minimum" with + | None -> + let err = + "minimum field required when exclusiveMinimum is true" in + raise (Failure err) + | Some v -> Some (v, `Inclusive) + else + match opt_int_field json "minimum" with + | None -> None + | Some v -> Some (v, `Exclusive) in + let maximum = + if opt_bool_field false json "exclusiveMaximum" then + match opt_int_field json "maximum" with + | None -> + let err = + "maximum field required when exclusiveMaximum is true" in + raise (Failure err) + | Some v -> Some (v, `Inclusive) + else + match opt_int_field json "maximum" with + | None -> None + | Some v -> Some (v, `Exclusive) in + { multiple_of ; minimum ; maximum} in + let numeric_specs json = + let multiple_of = opt_float_field json "multipleOf" in + let minimum = + if opt_bool_field false json "exclusiveMinimum" then + match opt_float_field json "minimum" with + | None -> + let err = + "minimum field required when exclusiveMinimum is true" in + raise (Failure err) + | Some v -> Some (v, `Inclusive) + else + match opt_float_field json "minimum" with + | None -> None + | Some v -> Some (v, `Exclusive) in + let maximum = + if opt_bool_field false json "exclusiveMaximum" then + match opt_float_field json "maximum" with + | None -> + let err = + "maximum field required when exclusiveMaximum is true" in + raise (Failure err) + | Some v -> Some (v, `Inclusive) + else + match opt_float_field json "maximum" with + | None -> None + | Some v -> Some (v, `Exclusive) in + { multiple_of ; minimum ; maximum} in + match name with + | "integer" -> + Integer (integer_specs json) + | "number" -> + Number (numeric_specs json) + | "boolean" -> Boolean + | "null" -> Null + | "string" -> + let specs = + let pattern = opt_string_field json "pattern" in + let min_length = opt_length_field json "minLength" in + let max_length = opt_length_field json "maxLength" in + let min_length = match min_length with None -> 0 | Some l -> l in + { pattern ; min_length ; max_length } in + String specs + | "array" -> + let specs = + let unique_items = opt_bool_field false json "uniqueItems" in + let min_items = opt_length_field json "minItems" in + let max_items = opt_length_field json "maxItems" in + let min_items = match min_items with None -> 0 | Some l -> l in + match opt_field_view json "additionalItems" with + | Some (`Bool true) -> + { min_items ; max_items ; unique_items ; additional_items = Some (element Any) } + | None | Some (`Bool false) -> + { min_items ; max_items ; unique_items ; additional_items = None } + | Some elt -> + let elt = try parse_element source (Repr.repr elt) + with err -> raise (at_field "additionalItems" err) in + { min_items ; max_items ; unique_items ; additional_items = Some elt } in + begin match opt_field_view json "items" with + | Some (`A elts) -> + let rec elements i acc = function + | [] -> + Array (List.rev acc, specs) + | elt :: tl -> + let elt = try parse_element source elt + with err -> raise (at_field "items" @@ at_index i err) in + elements (succ i) (elt :: acc) tl + in elements 0 [] elts + | Some elt -> + let elt = try parse_element source (Repr.repr elt) + with err -> raise (at_field "items" err) in + Monomorphic_array (elt, specs) + | None -> + Monomorphic_array (element Any, specs) end + | "object" -> + let required = + match opt_array_field json "required" with + | None -> [] + | Some l -> + let rec items i acc = function + | `String s :: tl -> items (succ i) (s :: acc) tl + | [] -> List.rev acc + | k :: _ -> raise (at_field "required" @@ at_index i @@ unexpected k "string") + in items 0 [] (List.map Repr.view l) in + let properties = + match opt_field_view json "properties" with + | Some (`O props) -> + let rec items acc = function + | [] -> List.rev acc + | (n, elt) :: tl -> + let elt = try parse_element source elt + with err -> raise (at_field "properties" @@ at_field n @@ err) in + let req = List.mem n required in + items ((n, elt, req, None) :: acc) tl (* XXX: fixme *) + in items [] props + | None -> [] + | Some k -> raise (at_field "properties" @@ unexpected k "object") in + let additional_properties = + match opt_field_view json "additionalProperties" with + | Some (`Bool false) -> None + | None | Some (`Bool true) -> Some (element Any) + | Some elt -> + let elt = try parse_element source (Repr.repr elt) + with err -> raise (at_field "additionalProperties" err) in + Some elt in + let property_dependencies = + match opt_field_view json "propertyDependencies" with + | None -> [] + | Some (`O l) -> + let rec sets sacc = function + | (n, `A l) :: tl -> + let rec strings j acc = function + | [] -> sets ((n, List.rev acc) :: sacc) tl + | `String s :: tl -> strings (succ j) (s :: acc) tl + | k :: _ -> + raise (at_field "propertyDependencies" @@ + at_field n @@ + at_index j @@ + unexpected k "string") + in strings 0 [] (List.map Repr.view l) + | (n, k) :: _ -> + raise (at_field "propertyDependencies" @@ + at_field n @@ + unexpected k "string array") + | [] -> List.rev sacc + in sets [] (List.map (fun (n, v) -> (n, Repr.view v)) l) + | Some k -> + raise (at_field "propertyDependencies" @@ + unexpected k "object") in + let parse_element_assoc field = + match opt_field_view json field with + | None -> [] + | Some (`O props) -> + let rec items acc = function + | [] -> List.rev acc + | (n, elt) :: tl -> + let elt = try parse_element source elt + with err -> raise (at_field field @@ + at_field n err) in + items ((n, elt) :: acc) tl + in items [] props + | Some k -> raise (at_field field @@ unexpected k "object") in + let pattern_properties = parse_element_assoc "patternProperties" in + let schema_dependencies = parse_element_assoc "schemaDependencies" in + let min_properties = + match opt_length_field json "minProperties" with + | None -> 0 + | Some l -> l in + let max_properties = opt_length_field json "maxProperties" in + Object { properties ; pattern_properties ; + additional_properties ; + min_properties ; max_properties ; + schema_dependencies ; property_dependencies } + | n -> raise (Cannot_parse ([], Unexpected (n, "a known type"))) in + (* parse recursively from the root *) + let root = parse_element Uri.empty json in + (* force the addition of everything inside /definitions *) + (match Repr.view (query [ `Field "definitions" ] json) with + | `O all -> + let all = List.map (fun (n, _) -> Uri.of_string ("#/definitions/" ^ n)) all in + List.iter (fun uri -> collect_definition uri |> ignore) all + | _ -> () + | exception Not_found -> ()) ; + (* check the domain of IDs *) + List.iter + (fun id -> + if not (List.mem_assoc id !collected_id_defs) then + raise (Cannot_parse ([], Dangling_reference (Uri.(with_fragment empty (Some id)))))) + !collected_id_refs ; + let ids = !collected_id_defs in + let source = schema_source in + let world = [] in + let definitions = !collected_definitions in + { root ; definitions ; source ; ids ; world } + + (*-- creation and update ---------------------------------------------------*) + + (* Checks that all local refs and ids are defined *) + let check_definitions root definitions = + let collected_id_defs = ref [] in + let collected_id_refs = ref [] in + let rec check ({ kind ; id } as elt) = + begin match id with + | None -> () + | Some id -> collected_id_defs := (id, elt) :: !collected_id_defs end ; + begin match kind with + | Object { properties ; pattern_properties ; + additional_properties ; schema_dependencies } -> + List.iter (fun (_, e, _, _) -> check e) properties ; + List.iter (fun (_, e) -> check e) pattern_properties ; + List.iter (fun (_, e) -> check e) schema_dependencies ; + (match additional_properties with Some e -> check e | None -> ()) + | Array (es, { additional_items }) -> + List.iter check es ; + (match additional_items with Some e -> check e | None -> ()) + | Monomorphic_array (e, { additional_items }) -> + check e ; + (match additional_items with Some e -> check e | None -> ()) + | Combine (_, es) -> + List.iter check es + | Def_ref path -> + if not (definition_exists path definitions) then + let path = json_pointer_of_path path in + raise (Dangling_reference (Uri.(with_fragment empty) (Some path))) + | Id_ref id -> + collected_id_refs := id :: !collected_id_refs ; + | Ext_ref _ | String _ | Integer _ | Number _ | Boolean | Null | Any | Dummy -> () + end in + (* check the root and definitions *) + check root ; + List.iter (fun (_, root) -> check root) definitions ; + (* check the domain of IDs *) + List.iter + (fun id -> + if not (List.mem_assoc id !collected_id_defs) then + raise (Dangling_reference (Uri.(with_fragment empty (Some id))))) + !collected_id_refs ; + !collected_id_defs + + let create root = + let ids = check_definitions root [] in + { root ; definitions = [] ; world = [] ; ids ; source = Uri.empty } + + let root { root } = + root + + let update root sch = + let ids = check_definitions root sch.definitions in + { sch with root ; ids } + + let any = + create (element Any) + + let self = + { root = element (Ext_ref (Uri.of_string version)) ; + definitions = [] ; ids = [] ; world = [] ; source = Uri.empty } + + (* remove unused definitions from the schema *) + let simplify schema = + let res = ref [] (* collected definitions *) in + let rec collect { kind } = match kind with + | Object { properties ; pattern_properties ; + additional_properties ; schema_dependencies } -> + List.iter (fun (_, e, _, _) -> collect e) properties ; + List.iter (fun (_, e) -> collect e) pattern_properties ; + List.iter (fun (_, e) -> collect e) schema_dependencies ; + (match additional_properties with Some e -> collect e | None -> ()) + | Array (es, { additional_items }) -> + List.iter collect es ; + (match additional_items with Some e -> collect e | None -> ()) + | Monomorphic_array (e, { additional_items }) -> + collect e ; + (match additional_items with Some e -> collect e | None -> ()) + | Combine (_, es) -> + List.iter collect es + | Def_ref path -> + let def = find_definition path schema.definitions in + res := insert_definition path def !res + | Ext_ref _ | Id_ref _ | String _ | Integer _ | Number _ | Boolean | Null | Any | Dummy -> () + in + collect schema.root ; + { schema with definitions = !res } + + let definition_path_of_name name = + path_of_json_pointer ~wildcards:false @@ + match String.get name 0 with + | exception _ -> raise (Bad_reference name) + | '/' -> name + | _ -> "/definitions/" ^ name + + let find_definition name schema = + let path = definition_path_of_name name in + find_definition path schema.definitions + + let definition_ref name = + let path = definition_path_of_name name in + element (Def_ref path) + + let definition_exists name schema = + let path = definition_path_of_name name in + definition_exists path schema.definitions + + let add_definition name elt schema = + let path = definition_path_of_name name in + (* check inside def *) + let definitions = insert_definition path elt schema.definitions in + { schema with definitions }, element (Def_ref path) + + let merge_definitions (sa, sb) = + let rec sorted_merge = function + | ((na, da) as a) :: ((nb, db) as b) :: tl -> + if na = nb then + if da.kind = Dummy || db.kind = Dummy || eq_element da db then + (na, da) :: sorted_merge tl + else + raise (Duplicate_definition (na, da, db)) + else + a :: sorted_merge (b :: tl) + | [] | [ _ ] as rem -> rem + in + let definitions = + sorted_merge (List.sort compare (sa.definitions @ sb.definitions)) in + { sa with definitions }, { sb with definitions } + + let combine op schemas = + let rec combine sacc eacc = function + | [] -> update (element (Combine (op, eacc))) sacc + | s :: ss -> + let sacc, s = merge_definitions (sacc, s) in + combine sacc (s.root :: eacc) ss + in combine any [] schemas + + let is_nullable { ids ; definitions ; root } = + let rec nullable { kind } = match kind with + | Null | Any -> true + | Object _ + | Array _ + | Monomorphic_array _ + | Ext_ref _ + | String _ + | Integer _ + | Number _ + | Boolean -> false + | Combine (Not, [ elt ]) -> + not (nullable elt) + | Combine (All_of, elts) -> + List.for_all nullable elts + | Combine ((Any_of | One_of), elts) -> + List.exists nullable elts + | Def_ref path -> + nullable (List.assoc path definitions) + | Id_ref id -> + nullable (List.assoc id ids) + | Combine (Not, _) | Dummy -> assert false in + nullable root + + + (*-- default specs ---------------------------------------------------------*) + + let array_specs = + { min_items = 0 ; + max_items = None ; + unique_items = false ; + additional_items = None } + let object_specs = + { properties = [] ; + pattern_properties = [] ; + additional_properties = Some (element Any) ; + min_properties = 0 ; + max_properties = None ; + schema_dependencies = [] ; + property_dependencies = [] } + let string_specs = + { pattern = None ; + min_length = 0 ; + max_length = None } + let numeric_specs = + { multiple_of = None ; + minimum = None ; + maximum = None } +end + +include Make (Json_repr.Ezjsonm) diff --git a/vendors/ocplib-json-typed/src/json_schema.mli b/vendors/ocplib-json-typed/src/json_schema.mli new file mode 100644 index 000000000..08ae8d863 --- /dev/null +++ b/vendors/ocplib-json-typed/src/json_schema.mli @@ -0,0 +1,258 @@ +(** Abstract representation of JSON schemas as of version + [http://json-schema.org/draft-04/schema#]. *) + +(************************************************************************) +(* ocplib-json-typed *) +(* *) +(* Copyright 2014 OCamlPro *) +(* *) +(* This file is distributed under the terms of the GNU Lesser General *) +(* Public License as published by the Free Software Foundation; either *) +(* version 2.1 of the License, or (at your option) any later version, *) +(* with the OCaml static compilation exception. *) +(* *) +(* ocplib-json-typed is distributed in the hope that it will be useful,*) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(************************************************************************) + +(** {2 Abstract representation of schemas} *) (******************************) + +(** A JSON schema root. *) +type schema + +(** A node in the schema, embeds all type-agnostic specs. *) +and element = + { title : string option ; + (** An optional short description. *) + description : string option ; + (** An optional long description. *) + default : Json_repr.any option ; + (** A default constant to be substituted in case of a missing value. *) + enum : Json_repr.any list option ; + (** A valid value must equal one of these constants. *) + kind : element_kind ; + (** The type-specific part. *) + format : string option ; + (** predefined formats such as [date-time], [email], [ipv4], [ipv6], [uri]. *) + id : string option + (** An optional ID. *) } + +(** The type-specific part of schema nodes. *) +and element_kind = + | Object of object_specs + (** The type of an object. *) + | Array of element list * array_specs + (** An fixed-length array with the types of its elements (a tuple). *) + | Monomorphic_array of element * array_specs + (** A variable-length array with the type of its children. *) + | Combine of combinator * element list + (** A mix of schemas using logical combinators. *) + | Def_ref of Json_query.path + (** A ref to an element from its path in the JSON representation. *) + | Id_ref of string + (** A ref to an element from its ID. *) + | Ext_ref of Uri.t + (** A ref to an external element. *) + | String of string_specs + (** A string (with optional characteristics). *) + | Integer of numeric_specs + (** An int (with optional characteristics). *) + | Number of numeric_specs + (** A float (with optional characteristics). *) + | Boolean (** Any boolean. *) + | Null (** The null value. *) + | Any (** Any JSON value. *) + | Dummy + (** For building cyclic definitions, a definition bound to a dummy + will be considered absent for {!add_definition} but present + for {!update}. The idea is to insert a dummy definition, build a + cyclic structure using it for recursion, and finally update the + definition with the structure. *) + +(** Grammar combinators. *) +and combinator = + | Any_of (** Logical OR n-ary combinator. *) + | One_of (** Logical XOR n-ary combinator. *) + | All_of (** Logical AND n-ary combinator. *) + | Not (** Logical NOT unary combinator. *) + +(** Parameters of the [Array] and [MonomorphicArray] type specifiers. *) +and array_specs = + { min_items : int ; + (** The minimum number of elements. *) + max_items : int option ; + (** The maximum number of elements. *) + unique_items : bool ; + (** Teels if all elements must be different. *) + additional_items : element option ; + (** The type of additional items, if allowed. *) } + +(** Parameters of the [Integer] and [Number] type specifiers. *) +and numeric_specs = + { multiple_of : float option ; + (** An optional divisor of valid values *) + minimum : (float * [ `Inclusive | `Exclusive ]) option ; + (** The optional lower bound of the numeric range *) + maximum : (float * [ `Inclusive | `Exclusive ]) option + (** The optional upper bound of the numeric range *) } + +(** Parameters of the [Object] type specifier. *) +and object_specs = + { properties : (string * element * bool * Json_repr.any option) list ; + (** The names and types of properties, with a flag to indicate if + they are required ([true]) or optional. *) + pattern_properties : (string * element) list ; + (** Alternative definition of properties, matching field names + using regexps instead of constant strings. *) + additional_properties : element option ; + (** The type of additional properties, if allowed. *) + min_properties : int ; + (** The minimum number of properties. *) + max_properties : int option ; + (** The maximum number of properties. *) + schema_dependencies : (string * element) list ; + (** Additional schemas the value must verify if a property is + present (property, additional schema). *) + property_dependencies : (string * string list) list + (** Additional properties required whenever some property is + present (property, additional properties). *) } + +(** Parameters of the [String] type specifier. *) +and string_specs = + { pattern : string option ; + (** A regexp the string must conform to. *) + min_length : int ; + (** The minimum string length. *) + max_length : int option + (** The maximum string length. *) } + +(** {2 Combinators to build schemas and elements} *) (*************************) + +(** Construct a naked element (all optional properties to None). *) +val element : element_kind -> element + +(** Construct a schema from its root, without any definition ; the + element is checked not to contain any [Def] element. *) +val create : element -> schema + +(** Extract the root element from an existing schema. *) +val root : schema -> element + +(** Update a schema from its root, using the definitions from an + existing schema ; the element is checked to contain only valid + [Def] elements ; unused definitions are kept, see {!simplify}. *) +val update : element -> schema -> schema + +(** Describes the implemented schema specification as a schema. *) +val self : schema + +(** A completely generic schema, without any definition. *) +val any : schema + +(** Combines several schemas. *) +val combine : combinator -> schema list -> schema + +(** Tells is a schema accepts null. *) +val is_nullable : schema -> bool + +(** {2 Named definitions} *) (***********************************************) + +(** Merges the definitions of two schemas if possible and returns the + updated schemas, so that their elements can be mixed without + introducing dangling references ; if two different definitions are + bound to the same path, {!Duplicate_definition} will be raised. *) +val merge_definitions : schema * schema -> schema * schema + +(** Remove the definitions that are not present in the schema. *) +val simplify : schema -> schema + +(** Adds a definition by its path. If the path is absolute (starting + with a ['/']), it is untouched. Otherwise, it is considered + relative to ["#/definitions"] as recommended by the standard. May + raise {!Duplicate_definition} if this path is already used or any + error raised by {!Json_repr.path_of_json_pointer} with + [~wildcards:false]. Returns the modified schema and the [Def_ref] + node that references this definition to be used in the schema. *) +val add_definition : string -> element -> schema -> schema * element + +(** Finds a definition by its path, may raise [Not_found]. + See {!add_definition} for the name format.*) +val find_definition : string -> schema -> element + +(** Tells if a path leads to a definition. + See {!add_definition} for the name format. *) +val definition_exists : string -> schema -> bool + +(** Build a reference to a definition. + See {!add_definition} for the name format. *) +val definition_ref : string -> element + +(** {2 Predefined values} *) (***********************************************) + +(** Default Parameters of the [Array] and [MonomorphicArray] type specifiers. *) +val array_specs : array_specs + +(** Default parameters of the [Object] type specifier. *) +val object_specs : object_specs + +(** Default parameters of the [String] type specifier. *) +val string_specs : string_specs + +(** Default parameters of the [Integer] and [Number] type specifiers. *) +val numeric_specs : numeric_specs + +(** {2 JSON Serialization} *) (*********************************************) + +(** Formats a JSON schema as its JSON representation. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val to_json : schema -> Json_repr.ezjsonm + +(** Parse a JSON structure as a JSON schema, if possible. + May throw {!Cannot_parse}. + + This function works with JSON data represented in the {!Json_repr.ezjsonm} + format. See functor {!Make} for using another representation. *) +val of_json : Json_repr.ezjsonm -> schema + +(** Formats a JSON schema in human readable format. *) +val pp : Format.formatter -> schema -> unit + +(** {2 Errors} *) (**********************************************************) + +(** An error happened during parsing. + May box one of the following exceptions, among others.. *) +exception Cannot_parse of Json_query.path * exn + +(** A reference to a non-existent location was detected. *) +exception Dangling_reference of Uri.t + +(** A reference litteral could not be understood. *) +exception Bad_reference of string + +(** An unexpected kind of JSON value was encountered. *) +exception Unexpected of string * string + +(** A non-[Dummy] definition appeared twice on insertion or merge. *) +exception Duplicate_definition of Json_query.path * element * element + +(** Produces a human readable version of an error. *) +val print_error + : ?print_unknown: (Format.formatter -> exn -> unit) -> + Format.formatter -> exn -> unit + +(** {2 Advanced interface for using a custom JSON representation} *) (**********) + +module Make (Repr : Json_repr.Repr) : sig + + (** Same as {!to_json} for a custom JSON representation. *) + val to_json : schema -> Repr.value + + (** Same as {!of_json} for a custom JSON representation. *) + val of_json : Repr.value -> schema + +end