balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Import ocplib-json-typed in vendors

Browse Source
This commit is contained in:
Benjamin Canou 2018-05-03 16:26:00 +02:00
parent c92860df1c
commit 68f5c92c1e
19 changed files with 5324 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

859
vendors/ocplib-json-typed/LICENSE vendored Normal file
View File

@ -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. <http://fsf.org/>
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. <http://fsf.org/>
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.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
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 <http://www.gnu.org/licenses/>.
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:
<program> Copyright (C) <year> <name of author>
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
<http://www.gnu.org/licenses/>.
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
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

11
vendors/ocplib-json-typed/Makefile vendored Normal file
View File

@ -0,0 +1,11 @@
all:
jbuilder build @install @runtest --dev
install:
jbuilder install
uninstall:
jbuilder uninstall
clean:
rm -rf _build *~ */*~

35
vendors/ocplib-json-typed/README.md vendored Normal file
View File

@ -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.

18
vendors/ocplib-json-typed/ocplib-json-typed-browser.opam vendored Normal file
View File

@ -0,0 +1,18 @@
opam-version: "1.2"
name: "ocplib-json-typed-browser"
version: "0.6"
maintainer: "Benjamin Canou <benjamin@ocamlpro.com>"
authors: "Benjamin Canou <benjamin@ocamlpro.com>"
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"}
]

18
vendors/ocplib-json-typed/ocplib-json-typed-bson.opam vendored Normal file
View File

@ -0,0 +1,18 @@
opam-version: "1.2"
name: "ocplib-json-typed-bson"
version: "0.6"
maintainer: "Benjamin Canou <benjamin@ocamlpro.com>"
authors: "Benjamin Canou <benjamin@ocamlpro.com>"
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"}
]

17
vendors/ocplib-json-typed/ocplib-json-typed.opam vendored Normal file
View File

@ -0,0 +1,17 @@
opam-version: "1.2"
name: "ocplib-json-typed"
version: "0.6"
maintainer: "Benjamin Canou <benjamin@ocamlpro.com>"
authors: "Benjamin Canou <benjamin@ocamlpro.com>"
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" }
]

28
vendors/ocplib-json-typed/src/jbuild vendored Normal file
View File

@ -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)))

890
vendors/ocplib-json-typed/src/json_encoding.ml vendored Normal file
View File

@ -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
"@[<v 2>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
"@[<v 2>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
"@[<v 2>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
"@[<v 2>bad custom schema:@,%a@]"
(print_error ?print_unknown) exn
| Cannot_destruct (path, exn) ->
Format.fprintf ppf
"@[<v 2>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

495
vendors/ocplib-json-typed/src/json_encoding.mli vendored Normal file
View File

@ -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

269
vendors/ocplib-json-typed/src/json_query.ml vendored Normal file
View File

@ -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
"@[<v 2>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)

155
vendors/ocplib-json-typed/src/json_query.mli vendored Normal file
View File

@ -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

250
vendors/ocplib-json-typed/src/json_repr.ml vendored Normal file
View File

@ -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 "@[<hov 2>%a:@ %a@]"
pp_string name
pp_box v in
Format.fprintf ppf "@[<hov 2>{ %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 "@[<hov 2>[ %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))

167
vendors/ocplib-json-typed/src/json_repr.mli vendored Normal file
View File

@ -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

103
vendors/ocplib-json-typed/src/json_repr_browser.ml vendored Normal file
View File

@ -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 <http://www.gnu.org/licenses/>. *)
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)

46
vendors/ocplib-json-typed/src/json_repr_browser.mli vendored Normal file
View File

@ -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

390
vendors/ocplib-json-typed/src/json_repr_bson.ml vendored Normal file
View File

@ -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)

100
vendors/ocplib-json-typed/src/json_repr_bson.mli vendored Normal file
View File

@ -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

1215
vendors/ocplib-json-typed/src/json_schema.ml vendored Normal file
View File

File diff suppressed because it is too large Load Diff

258
vendors/ocplib-json-typed/src/json_schema.mli vendored Normal file
View File

@ -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