diff --git a/HsYAML.cabal b/HsYAML.cabal new file mode 100644 --- /dev/null +++ b/HsYAML.cabal @@ -0,0 +1,94 @@ +cabal-version: 1.14 +name: HsYAML +version: 0.1.0.0 + +synopsis: Pure Haskell YAML 1.2 parser +homepage: https://github.com/hvr/HsYAML +license: GPL-3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +copyright: 2015-2018 Herbert Valerio Riedel + , 2007-2008 Oren Ben-Kiki +category: Text +build-type: Simple +tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + +description: + @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) parser for Haskell. + . + Features include: + . + * Pure Haskell implementation with small dependency footprint and emphasis on strict compliance with the [YAML 1.2 specification](http://yaml.org/spec/1.2/spec.html) + * Low-level API access to lexical token-based scanner ("Data.YAML.Token") + * Event-based API resembling LibYAML's Event-based API ("Data.YAML.Event") + * Support for constructing custom YAML node graph representation (including support for cyclic YAML data structures) + * Direct decoding via typeclass-based API similiar to @aeson@ ("Data.YAML") + * Support for /Failsafe/, /JSON/ and /Core/ schemas as defined in the YAML 1.2 specification (including support for user-defined custom schemas) + +source-repository head + type: git + location: https://github.com/hvr/HsYAML.git + +flag exe + description: Enable @exe:yaml-test@ component + manual: True + default: False + +library + hs-source-dirs: src + exposed-modules: Data.YAML + , Data.YAML.Event + , Data.YAML.Token + other-modules: Data.YAML.Loader + , Data.YAML.Schema + , Util + + default-language: Haskell2010 + other-extensions: FlexibleContexts + FlexibleInstances + FunctionalDependencies + MultiParamTypeClasses + OverloadedStrings + PostfixOperators + RecordWildCards + RecursiveDo + Safe + ScopedTypeVariables + Trustworthy + TypeSynonymInstances + + build-depends: base >=4.5 && <4.12 + , bytestring >=0.9 && <0.11 + , dlist >=0.8 && <0.9 + , containers >=0.4.2 && <0.6 + , text >=1.2.3 && <1.3 + , mtl >=2.2.1 && <2.3 + , parsec >=3.1.13.0 && < 3.2 + + ghc-options: -Wall + +executable yaml-test + hs-source-dirs: src-test + main-is: Main.hs + other-modules: TML + + default-language: Haskell2010 + + if flag(exe) + build-depends: HsYAML + -- inherited constraints + , bytestring >= 0.10.8.0 + , base + , text + , containers + , mtl + -- non-inherited + , megaparsec >= 6.5.0 && < 6.6 + , microaeson == 0.1.* + , filepath == 1.4.* + , directory >= 1.2 && < 1.4 + else + buildable: False + + ghc-options: -rtsopts diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src-test/Main.hs b/src-test/Main.hs new file mode 100644 --- /dev/null +++ b/src-test/Main.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +module Main where + +import Control.Monad +import Control.Monad.Identity +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BS.L +import Data.Int (Int64) +import Data.Maybe +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO +import Text.Read + +import qualified Data.Aeson.Micro as J +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T + +import Data.YAML as Y +import Data.YAML.Event as YE +import qualified Data.YAML.Token as YT + +import qualified TML + +main :: IO () +main = do + args <- getArgs + + case args of + ("yaml2event":args') + | null args' -> cmdYaml2Event + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" + exitFailure + + ("yaml2json":args') + | null args' -> cmdYaml2Json + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2json sub-command" + exitFailure + + ("run-tml":args') -> cmdRunTml args' + + ("testml-compiler":args') -> cmdTestmlCompiler args' + + _ -> do + hPutStrLn stderr "usage: yaml-test []" + hPutStrLn stderr "" + hPutStrLn stderr "Commands:" + hPutStrLn stderr "" + hPutStrLn stderr " yaml2event reads YAML stream from STDIN and dumps events to STDOUT" + hPutStrLn stderr " yaml2json reads YAML stream from STDIN and dumps JSON to STDOUT" + hPutStrLn stderr " run-tml run/validate YAML-specific .tml file(s)" + hPutStrLn stderr " testml-compiler emulate testml-compiler" + + exitFailure + + +cmdYaml2Event :: IO () +cmdYaml2Event = do + inYamlDat <- BS.L.getContents + forM_ (parseEvents inYamlDat) $ \ev -> case ev of + Left (ofs,msg) -> do + case msg of + "" -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs) + _ -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")") + exitFailure + Right event -> do + hPutStrLn stdout (ev2str event) + hFlush stdout + +-- | 'J.Value' look-alike +data Value' = Object' (Map Text Value') + | Array' [Value'] + | String' !Text + | NumberD' !Double + | NumberI' !Integer + | Bool' !Bool + | Null' + deriving Show + +toProperValue :: Value' -> J.Value +toProperValue v = case v of + Null' -> J.Null + String' t -> J.String t + NumberD' x -> J.Number x + NumberI' x -> J.Number (fromInteger x) + Bool' b -> J.Bool b + Array' xs -> J.Array (map toProperValue xs) + Object' xs -> J.Object (fmap toProperValue xs) + +instance FromYAML Value' where + parseYAML (Y.Scalar s) = case s of + SNull -> pure Null' + SBool b -> pure (Bool' b) + SFloat x -> pure (NumberD' x) + SInt x -> pure (NumberI' x) + SStr t -> pure (String' t) + SUnknown _ t -> pure (String' t) -- HACK + + parseYAML (Y.Sequence _ xs) = Array' <$> mapM parseYAML xs + + parseYAML (Y.Mapping _ m) = Object' . Map.fromList <$> mapM parseKV (Map.toList m) + where + parseKV :: (Y.Node,Y.Node) -> Parser (Text,Value') + parseKV (k,v) = (,) <$> parseK k <*> parseYAML v + + -- for numbers and !!null we apply implicit conversions + parseK n = do + k <- parseYAML n + case k of + NumberI' t -> pure (T.pack (show t)) + NumberD' t -> pure (T.pack (show t)) + String' t -> pure t + Null' -> pure "" + _ -> fail ("dictionary entry had non-string key " ++ show k) + +decodeAeson :: BS.L.ByteString -> Either String [J.Value] +decodeAeson = fmap (map toProperValue) . decode + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + + +decodeNumber :: T.Text -> Maybe Double +decodeNumber = readMaybe . T.unpack -- fixme + +cmdYaml2Json :: IO () +cmdYaml2Json = do + inYamlDat <- BS.L.getContents + + case decodeAeson inYamlDat of + Left e -> fail e + Right vs -> do + forM_ vs $ \v -> BS.L.putStrLn (J.encode v) + + return () + +unescapeSpcTab :: T.Text -> T.Text +unescapeSpcTab = T.replace "" " " . T.replace "" "\t" + +cmdRunTml :: [FilePath] -> IO () +cmdRunTml args = do + results <- forM args $ \fn -> do + tml <- BS.readFile fn + + hPutStr stdout (fn ++ " : ") + hFlush stdout + + TML.Document _ blocks <- either (fail . T.unpack) pure $ TML.parse fn (T.decodeUtf8 tml) + + forM blocks $ \(TML.Block label points) -> do + + let dats = [ (k,v) | TML.PointStr k v <- points ] + + let isErr = isJust (lookup "error" dats) + + Just inYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "in-yaml" dats + Just testEvDat = lines . T.unpack . unescapeSpcTab <$> lookup "test-event" dats + + mInJsonDat :: Maybe [J.Value] + mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats + + case sequence (parseEvents inYamlDat) of + Left err + | isErr -> do + putStrLn "OK! (error)" + pure True + | otherwise -> do + putStrLn "FAIL!" + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn' (T.unpack label) + putStrLn "" + putStrLn' (show err) + putStrLn "" + putStrLn' (show testEvDat) + putStrLn "" + BS.L.putStr inYamlDat + putStrLn "" + testParse inYamlDat + putStrLn "" + -- forM_ (parseEvents inYamlDat) (putStrLn' . show) + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn "" + pure False + + Right evs' -> do + let evs'' = map ev2str evs' + if evs'' == testEvDat + then do + + case mInJsonDat of + Nothing -> do + putStrLn "OK!" + pure True + Just inJsonDat -> do + iutJson <- either fail pure $ decodeAeson inYamlDat + + if iutJson == inJsonDat + then do + putStrLn "OK! (+JSON)" + pure True + else do + putStrLn "FAIL! (bad JSON)" + + putStrLn' ("ref = " ++ show inJsonDat) + putStrLn' ("iut = " ++ show iutJson) + + pure False + + else do + if isErr + then putStrLn "FAIL! (unexpected parser success)" + else putStrLn "FAIL!" + + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn' (T.unpack label) + putStrLn "" + putStrLn' ("ref = " ++ show testEvDat) + putStrLn' ("iut = " ++ show evs'') + putStrLn "" + BS.L.putStr inYamlDat + putStrLn "" + testParse inYamlDat + putStrLn "" + -- forM_ (parseEvents inYamlDat) (putStrLn' . show) + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn "" + pure False + + putStrLn "" + + let ok = length (filter id results') + nok = length (filter not results') + results' = concat results + + putStrLn ("done (passed: " ++ show ok ++ " / failed: " ++ show nok ++ ")") + + +-- | Incomplete proof-of-concept 'testml-compiler' operation +cmdTestmlCompiler :: [FilePath] -> IO () +cmdTestmlCompiler [fn0] = do + (fn,raw) <- case fn0 of + "-" -> (,) "" <$> T.getContents + _ -> (,) fn0 <$> T.readFile fn0 + + case TML.parse fn raw of + Left e -> T.hPutStrLn stderr e >> exitFailure + Right doc -> BS.putStrLn (J.encodeStrict doc) +cmdTestmlCompiler _ = do + hPutStrLn stderr ("Usage: yaml-test testml-compiler [ | - ]") + exitFailure + + +putStrLn' :: String -> IO () +putStrLn' msg = putStrLn (" " ++ msg) + + +ev2str :: Event -> String +ev2str StreamStart = "+STR" +ev2str (DocumentStart True) = "+DOC ---" +ev2str (DocumentStart False) = "+DOC" +ev2str MappingEnd = "-MAP" +ev2str (MappingStart manc mtag) = "+MAP" ++ ancTagStr manc mtag +ev2str SequenceEnd = "-SEQ" +ev2str (SequenceStart manc mtag) = "+SEQ" ++ ancTagStr manc mtag +ev2str (DocumentEnd True) = "-DOC ..." +ev2str (DocumentEnd False) = "-DOC" +ev2str StreamEnd = "-STR" +ev2str (Alias a) = "=ALI *" ++ T.unpack a +ev2str (YE.Scalar manc mtag sty v) = "=VAL" ++ ancTagStr manc mtag ++ v' + where + v' = case sty of + Plain -> " :" ++ quote2 v + DoubleQuoted -> " \"" ++ quote2 v + Literal -> " |" ++ quote2 v + Folded -> " >" ++ quote2 v + SingleQuoted -> " '" ++ quote2 v + +ancTagStr manc mtag = anc' ++ tag' + where + anc' = case manc of + Nothing -> "" + Just anc -> " &" ++ T.unpack anc + + tag' = case tagToText mtag of + Nothing -> "" + Just t -> " <" ++ T.unpack t ++ ">" + + +quote2 :: T.Text -> String +quote2 = concatMap go . T.unpack + where + go c | c == '\n' = "\\n" + | c == '\t' = "\\t" + | c == '\b' = "\\b" + | c == '\r' = "\\r" + | c == '\\' = "\\\\" + | otherwise = [c] + + + +testParse :: BS.L.ByteString -> IO () +testParse bs0 = mapM_ (putStrLn' . showT) $ YT.tokenize bs0 False + where + showT :: YT.Token -> String + showT t = replicate (YT.tLineChar t) ' ' ++ show (YT.tText t) ++ " " ++ show (YT.tCode t) diff --git a/src-test/TML.hs b/src-test/TML.hs new file mode 100644 --- /dev/null +++ b/src-test/TML.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- Incomplete TestML 0.3.0 parser +module TML + ( TML.parse + + , Document(..) + , Block(..) + + , Point(..) + , PseudoId(..) + + , Code(..) + , AssertOp(..) + , CodeExpr(..) + , CodeObject(..) + , FunCall(..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B + +import Control.Applicative hiding (many, some) +import Control.Monad +import qualified Data.Aeson.Micro as J +import qualified Data.ByteString as BS +import qualified Data.Char as C +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Void +import System.Environment +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Expr + +type Parser = Parsec Void T.Text + +parse :: String -> T.Text -> Either T.Text Document +parse fn raw = either (Left . T.pack . parseErrorPretty' raw) + (Right .process_pseudo) + (Text.Megaparsec.parse testml_document fn raw) + + +---------------------------------------------------------------------------- + +data Document = Document [Code] [Block] + deriving Show + +instance J.ToJSON Document where + toJSON (Document code dat) + = J.object [ "testml" J..= ("0.3.0" :: T.Text) + , "code" J..= code + , "data" J..= dat + ] + +data Block = Block !T.Text [Point] + deriving Show + +instance J.ToJSON Block where + toJSON (Block label points) + = J.object [ "label" J..= label + , "point" J..= J.object (map f points) + ] + where + f (PointStr k v) = k J..= v + f (PointPseudo k) = (T.pack (show k)) J..= True + f (PointInt k v) = k J..= v + +data Point = PointStr !T.Text !T.Text + | PointInt !T.Text !Integer + | PointPseudo !PseudoId + deriving Show + +instance J.ToJSON Code where + toJSON (CodeAssignmentStmt lhs rhs) + = J.Array [J.String "=", J.String lhs, J.toJSON rhs] + toJSON stmt@(CodeExpressionStmt lhs massert) + | pobjs@(_:_) <- pointObjsInExpr stmt + = J.Array [ J.String "%()" + , J.Array [ J.String ("*" `mappend` p) | p <- pobjs ] + , expr' + ] + | otherwise = expr' + where + expr' = case massert of + Just (op,rhs) -> J.toJSON (op,lhs,rhs) + Nothing -> J.toJSON lhs + +data Code = CodeAssignmentStmt !T.Text !CodeExpr + | CodeExpressionStmt !CodeExpr !(Maybe (AssertOp,CodeExpr)) + | CodeImportStmt [T.Text] + deriving Show + +instance J.ToJSON AssertOp where + toJSON AssertEq = J.String "==" + toJSON AssertHas = J.String "~~" + toJSON AssertLike = J.String "=~" + +data AssertOp = AssertEq | AssertHas | AssertLike + deriving Show + +instance J.ToJSON CodeExpr where + toJSON (CodeExpr obj []) = J.toJSON obj + toJSON (CodeExpr obj fns) = J.Array $ [J.String ".", J.toJSON obj] ++ map J.toJSON fns + +data CodeExpr = CodeExpr !CodeObject [FunCall] + deriving Show + +instance J.ToJSON CodeObject where + toJSON (StrObj s) = J.String s + toJSON (NumObj n) = J.Number n + toJSON (PointObj j) = J.Array [J.String "*", J.String j] + toJSON (CallObj fn) = J.toJSON fn + +data CodeObject = StrObj !T.Text + | CallObj !FunCall + | NumObj !Double + | PointObj !T.Text + deriving Show + +instance J.ToJSON FunCall where + toJSON (FunCall fn args) = J.Array (J.String fn : map J.toJSON args) + +data FunCall = FunCall !T.Text [CodeExpr] + deriving Show + + + +pointObjsInExpr :: Code -> [T.Text] +pointObjsInExpr co = nub $ case co of + CodeAssignmentStmt _ expr -> goExpr expr + CodeExpressionStmt e1 Nothing -> goExpr e1 + CodeExpressionStmt e1 (Just (_,e2)) -> goExpr e1 ++ goExpr e2 + where + goExpr (CodeExpr obj fns) = goObj obj ++ concatMap goFun fns + + goFun (FunCall _ exprs) = concatMap goExpr exprs + + goObj (PointObj j) = [j] + goObj (CallObj fn) = goFun fn + goObj (StrObj _) = [] + goObj (NumObj _) = [] + + +testml_document :: Parser Document +testml_document = Document <$> code_section <*> data_section <* eof + +pseudo_point_name :: Parser PseudoId +pseudo_point_name + = choice [ HEAD <$ string "HEAD" + , LAST <$ string "LAST" + , ONLY <$ string "ONLY" + , SKIP <$ string "SKIP" + , TODO <$ string "TODO" + , DIFF <$ string "DIFF" + ] + +data PseudoId = HEAD + | LAST + | ONLY + | SKIP + | TODO + | DIFF + deriving (Eq,Show) + +process_pseudo :: Document -> Document +process_pseudo (Document code bs0) = Document code (go bs0) + where + go blocks + | Just b <- find isOnly blocks' = [b] + | Just bs <- goHead blocks' = bs + | Just bs <- goLast [] blocks' = bs + | otherwise = blocks' + where + blocks' = filter (not . isSkip) blocks + + isOnly b = ONLY `elem` pseudos b + isSkip b = SKIP `elem` pseudos b + isHead b = HEAD `elem` pseudos b + isLast b = LAST `elem` pseudos b + + pseudos (Block _ ps) = [ k | PointPseudo k <- ps ] + + goHead [] = Nothing + goHead (b:bs) + | isHead b = Just (b:bs) + | otherwise = goHead bs + + goLast acc [] = Nothing + goLast acc (b:bs) + | isLast b = Just $ reverse (b:bs) + | otherwise = goLast (b:acc) bs + +code_section :: Parser [Code] +code_section = do + xs <- many code_statement + pure (catMaybes xs) + where + code_statement = choice + [ Nothing <$ comment_lines + , Just <$> import_directive + , Just <$> assignment_statement + , Just <$> expression_statement + ] + + import_directive = do + string "%Import" + ws + mods <- module_name `sepBy1` ws + ws0 + eol + pure $! CodeImportStmt mods + + module_name :: Parser T.Text + module_name = T.pack <$> some alphaNumChar + + assignment_statement = do + v <- try $ do + v' <- identifier_name + ws + void (char '=') <|> void (string "||=") -- FIXME + ws + pure v' + e <- code_expression + eol + pure (CodeAssignmentStmt v e) + + expression_statement = do + -- TODO: expression-label + -- optional (double_string >> char ':' >> ws0) + + -- TODO: pick-expression + + lhs <- code_expression + ws + op <- choice + [ AssertEq <$ string "==" + , AssertHas <$ string "~~" + , AssertLike <$ string "=~" + ] + ws + rhs <- code_expression + + optional $ do + ws0 + char ':' + double_string + + eol + + pure (CodeExpressionStmt lhs (Just (op,rhs))) + + +code_expression :: Parser CodeExpr +code_expression = CodeExpr <$> code_object <*> many function_call + + +-- quoted string +double_string :: Parser T.Text +double_string = do + char '"' + str <- many (noneOf ("\n\"\\" :: [Char]) <|> (char '\\' >> (unesc <$> oneOf ("\\\"0nt" :: [Char])))) + char '"' + pure $! (T.pack str) + where + unesc '0' = '\0' + unesc 'n' = '\n' + unesc 't' = '\t' + unesc c = c + +single_string :: Parser T.Text +single_string = do + char '\'' + str <- many (noneOf ("\n'\\" :: [Char]) <|> (char '\\' >> (oneOf ("\\'" :: [Char])))) + char '\'' + pure $! (T.pack str) + +function_call :: Parser FunCall +function_call = do + char '.' + call_object + +call_object :: Parser FunCall +call_object = FunCall <$> identifier_name + <*> optional' [] (between (char '(') (char ')') $ code_expression `sepBy1` (char ',' >> ws0)) + +optional' def p = do + x <- optional p + case x of + Nothing -> pure def + Just y -> pure y + +code_object :: Parser CodeObject +code_object + = choice + [ mkPoint <$> char '*' <*> lowerChar <*> many (lowerChar <|> digitChar <|> char '-' <|> char '_') + , mkNum <$> optional (char '-') <*> some digitChar <*> optional (char '.' >> some digitChar) + , CallObj <$> call_object + , StrObj <$> single_string + , StrObj <$> double_string + ] "code-object" + where + mkPoint _ c cs = PointObj $! (T.pack (c:cs)) + mkNum msign ds1 mds2 = NumObj $! (read $ (maybe id (:) msign) ds1 ++ (maybe "" ('.':) mds2)) + +data_section :: Parser [Block] +data_section = many block_definition + where + block_definition = do + -- block_heading + string "===" *> ws + l <- T.pack <$> manyTill anyChar eol + + -- TODO: user_defined + ps <- many point_definition + pure (Block l ps) + + point_definition = do + string "---" *> ws + + j <- eitherP identifier_user pseudo_point_name + + filters <- maybe [] id <$> optional filter_spec + + let single = do + _ <- char ':' *> ws + x <- T.pack <$> manyTill anyChar eol + -- consume and ignore any point_lines + _ <- point_lines + pure $! case j of + Left j' -> mkSinglePointVal j' (transformPoint True filters x) + Right j' -> PointPseudo j' -- is this allowed? + + multi = do + ws0 *> eol + x <- point_lines + pure $! case j of + Left j' -> PointStr j' (transformPoint False filters x) + Right j' -> PointPseudo j' + + single <|> multi + + filter_spec = between (char '(') (char ')') $ many (oneOf ("<#+-~/@" :: [Char])) + + mkSinglePointVal k v + | T.all C.isDigit v = PointInt k (read (T.unpack v)) + | otherwise = PointStr k v + +point_lines :: Parser T.Text +point_lines = T.pack . unlines <$> go + where + go = many (notFollowedBy point_boundary *> manyTill anyChar eol) + + point_boundary :: Parser () + point_boundary = void (string "---") <|> void (string "===") <|> eof + +identifier_user :: Parser T.Text +identifier_user = do + x <- (:) <$> lowerChar <*> many alphaNumChar + xs <- many ((:) <$> char '-' <*> some alphaNumChar) + + pure $! T.pack (concat (x:xs)) + +identifier_name :: Parser T.Text +identifier_name = do + x <- (:) <$> letterChar <*> many alphaNumChar + xs <- many ((:) <$> char '-' <*> some alphaNumChar) + + pure $! T.pack (concat (x:xs)) + + +ws :: Parser () +ws = void $ takeWhile1P (Just "BLANK") (\c -> c == ' ' || c == '\t') + +ws0 :: Parser () +ws0 = void $ takeWhileP (Just "BLANK") (\c -> c == ' ' || c == '\t') + +blank_line :: Parser () +blank_line = (try (ws0 <* eol) <|> try (ws <* eof)) "blank-line" + +comment_line :: Parser () +comment_line = (char '#' *> takeWhileP Nothing (/= '\n') *> void eol) "comment-line" + +comment_lines :: Parser () +comment_lines = void (some (comment_line <|> blank_line)) + +stripTrailEols :: T.Text -> T.Text +stripTrailEols = go + where + go t | T.isSuffixOf "\n\n" t = go (T.init t) + | T.isSuffixOf "\r\n\r\n" t = go (T.init (T.init t)) + | t == "\n" = "" + | otherwise = t + +-- 'undent' +stripPrefixInd :: T.Text -> T.Text +stripPrefixInd = T.unlines . map go . T.lines + where + go t | T.isPrefixOf " " t = T.drop 4 t + | T.isPrefixOf " " t = T.drop 3 t + | T.isPrefixOf " " t = T.drop 2 t + | T.isPrefixOf " " t = T.drop 1 t + | otherwise = t + +stripComments :: T.Text -> T.Text +stripComments = T.unlines . filter (not . T.isPrefixOf "#") . T.lines + +transformPoint :: Bool -> [Char] -> T.Text -> T.Text +transformPoint single mods0 -- TODO: backslash + = go mods0 . + (if keepBlanks then id else stripTrailEols) . + (if keepComments then id else stripComments) + where + keepBlanks = single || ('+' `elem` mods0) + keepComments = single || ('#' `elem` mods0) + + go [] = id + go ('<':xs) + | single = error "invalid filter for point-single" + | otherwise = go xs . stripPrefixInd + go ('+':xs) = go xs -- negative flag + go ('#':xs) = go xs -- negative flag + go ('-':xs) = go xs . T.dropWhileEnd C.isSpace + go (c:_) = error ("unknown filter " ++ show c) diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- Document oriented YAML parsing API inspired by [aeson](http://hackage.haskell.org/package/aeson). +-- +-- === Usage Example +-- +-- Let's assume we want to decode a simple YAML document +-- +-- > - name: Erik Weisz +-- > age: 52 +-- > magic: True +-- > - name: Mina Crandon +-- > age: 53 +-- +-- into a Haskell list of person records, i.e. a value of type @[Person]@. +-- +-- The code below shows how to manually define a @Person@ record type together with a 'FromYAML' instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.YAML +-- > +-- > data Person = Person +-- > { name :: Text +-- > , age :: Int +-- > , magic :: Bool +-- > } deriving Show +-- > +-- > instance FromYAML Person where +-- > parseYAML = withMap "Person" $ \m -> Person +-- > <$> m .: "name" +-- > <*> m .: "age" +-- > <*> m .:? "magic" .!= False +-- +-- And now we can 'decode' the YAML document like so: +-- +-- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: 53" :: Either String [[Person]] +-- Right [[Person {name = "Erik Weisz", age = 52, magic = True},Person {name = "Mina Crandon", age = 53, magic = False}]] +-- +-- +module Data.YAML + ( + -- * Typeclass-based resolving/decoding + decode + , FromYAML(..) + , Parser + , parseEither + + -- ** Accessors for YAML 'Mapping's + , Mapping + , (.:), (.:?), (.:!), (.!=) + + -- ** Prism-style parsers + , withSeq + , withBool + , withFloat + , withInt + , withNull + , withStr + , withMap + + -- * \"Concrete\" AST + , decodeNode + , decodeNode' + , Doc(..) + , Node(..) + , Scalar(..) + + -- * YAML 1.2 Schema resolvers + , SchemaResolver(..) + , failsafeSchemaResolver + , jsonSchemaResolver + , coreSchemaResolver + + -- * Generalised AST construction + , decodeLoader + , Loader(..) + , NodeId + + ) where + +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Map as Map +import qualified Data.Text as T + +import Data.YAML.Event (Tag, isUntagged, tagToText) +import Data.YAML.Loader +import Data.YAML.Schema + +import Util + +-- | YAML Document tree/graph +newtype Doc n = Doc n deriving (Eq,Ord,Show) + +-- | YAML Document node +data Node = Scalar !Scalar + | Mapping !Tag Mapping + | Sequence !Tag [Node] + | Anchor !NodeId !Node + deriving (Eq,Ord,Show) + +-- | YAML mapping +type Mapping = Map Node Node + +-- | Retrieve value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- +-- This parser fails if the key doesn't exist. +(.:) :: FromYAML a => Mapping -> Text -> Parser a +m .: k = maybe (fail $ "key " ++ show k ++ " not found") parseYAML (Map.lookup (Scalar (SStr k)) m) + +-- | Retrieve optional value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- +-- 'Nothing' is returned if the key is missing or points to a @tag:yaml.org,2002:null@ node. +-- This combinator only fails if the key exists but cannot be converted to the required type. +-- +-- See also '.:!'. +(.:?) :: FromYAML a => Mapping -> Text -> Parser (Maybe a) +m .:? k = maybe (pure Nothing) parseYAML (Map.lookup (Scalar (SStr k)) m) + +-- | Retrieve optional value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- +-- 'Nothing' is returned if the key is missing. +-- This combinator only fails if the key exists but cannot be converted to the required type. +-- +-- __NOTE__: This is a variant of '.:?' which doesn't map a @tag:yaml.org,2002:null@ node to 'Nothing'. +(.:!) :: FromYAML a => Mapping -> Text -> Parser (Maybe a) +m .:! k = maybe (pure Nothing) (fmap Just . parseYAML) (Map.lookup (Scalar (SStr k)) m) + +-- | Defaulting helper to be used with '.:?' or '.:!'. +(.!=) :: Parser (Maybe a) -> a -> Parser a +mv .!= def = fmap (maybe def id) mv + + +-- | Parse and decode YAML document(s) into 'Node' graphs +-- +-- This is a convenience wrapper over `decodeNode'` +-- +-- > decodeNode = decodeNode' coreSchemaResolver False False +-- +-- In other words, +-- +-- * Use the YAML 1.2 Core schema for resolving +-- * Don't create 'Anchor' nodes +-- * Disallow cyclic anchor references +-- +decodeNode :: BS.L.ByteString -> Either String [Doc Node] +decodeNode = decodeNode' coreSchemaResolver False False + + +-- | Customizable variant of 'decodeNode' +-- +decodeNode' :: SchemaResolver -- ^ YAML Schema resolver to use + -> Bool -- ^ Whether to emit anchor nodes + -> Bool -- ^ Whether to allow cyclic references + -> BS.L.ByteString -- ^ YAML document to parse + -> Either String [Doc Node] +decodeNode' SchemaResolver{..} anchorNodes allowCycles bs0 + = map Doc <$> runIdentity (decodeLoader failsafeLoader bs0) + where + failsafeLoader = Loader { yScalar = \t s v -> pure $ fmap Scalar (schemaResolverScalar t s v) + , ySequence = \t vs -> pure $ schemaResolverSequence t >>= \t' -> Right (Sequence t' vs) + , yMapping = \t kvs -> pure $ schemaResolverMapping t >>= \t' -> Right (Mapping t' (Map.fromList kvs)) + , yAlias = if allowCycles + then \_ _ n -> pure $ Right n + else \_ c n -> pure $ if c then Left "cycle detected" else Right n + , yAnchor = if anchorNodes + then \j n -> pure $ Right (Anchor j n) + else \_ n -> pure $ Right n + } + + +---------------------------------------------------------------------------- + +-- | YAML Parser 'Monad' used by 'FromYAML' +-- +-- See also 'parseEither' or 'decode' +newtype Parser a = P { unP :: Either String a } + deriving (Functor,Applicative) + +-- TODO: MonadFail +instance Monad Parser where + return = pure + P m >>= k = P (m >>= unP . k) + (>>) = (*>) + fail = P . Left + +-- | Run 'Parser' +-- +-- A common use-case is 'parseEither' 'parseYAML'. +parseEither :: Parser a -> Either String a +parseEither = unP + +-- helper +failTypeMismatch :: String -> Node -> Parser a +failTypeMismatch expected node = fail ("expected " ++ expected ++ " instead of " ++ got) + where + got = case node of + Scalar (SBool _) -> "!!bool" + Scalar (SInt _) -> "!!int" + Scalar SNull -> "!!null" + Scalar (SStr _) -> "!!str" + Scalar (SFloat _) -> "!!float" + Scalar (SUnknown t v) + | isUntagged t -> tagged t ++ show v + | otherwise -> "(unsupported) " ++ tagged t ++ "scalar" + (Anchor _ _) -> "anchor" + (Mapping t _) -> tagged t ++ " mapping" + (Sequence t _) -> tagged t ++ " sequence" + + tagged t0 = case tagToText t0 of + Nothing -> "non-specifically ? tagged (i.e. unresolved) " + Just t -> T.unpack t ++ " tagged" + +-- | A type into which YAML nodes can be converted/deserialized +class FromYAML a where + parseYAML :: Node -> Parser a + +-- | Operate on @tag:yaml.org,2002:null@ node (or fail) +withNull :: String -> Parser a -> Node -> Parser a +withNull _ f (Scalar SNull) = f +withNull expected _ v = failTypeMismatch expected v + + +-- | Trivial instance +instance FromYAML Node where + parseYAML = pure + +instance FromYAML Bool where + parseYAML = withBool "!!bool" pure + +-- | Operate on @tag:yaml.org,2002:bool@ node (or fail) +withBool :: String -> (Bool -> Parser a) -> Node -> Parser a +withBool _ f (Scalar (SBool b)) = f b +withBool expected _ v = failTypeMismatch expected v + +instance FromYAML Text where + parseYAML = withStr "!!str" pure + +-- | Operate on @tag:yaml.org,2002:str@ node (or fail) +withStr :: String -> (Text -> Parser a) -> Node -> Parser a +withStr _ f (Scalar (SStr b)) = f b +withStr expected _ v = failTypeMismatch expected v + +instance FromYAML Integer where + parseYAML = withInt "!!int" pure + +-- | Operate on @tag:yaml.org,2002:int@ node (or fail) +withInt :: String -> (Integer -> Parser a) -> Node -> Parser a +withInt _ f (Scalar (SInt b)) = f b +withInt expected _ v = failTypeMismatch expected v + +instance FromYAML Double where + parseYAML = withFloat "!!float" pure + +-- | Operate on @tag:yaml.org,2002:float@ node (or fail) +withFloat :: String -> (Double -> Parser a) -> Node -> Parser a +withFloat _ f (Scalar (SFloat b)) = f b +withFloat expected _ v = failTypeMismatch expected v + +-- signed fixed-width integers + +instance FromYAML Int where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Int8 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int8'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Int16 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int16'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Int32 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int32'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Int64 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int64'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + + +instance FromYAML Word where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Word8 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word8'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Word16 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word16'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Word32 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word32'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance FromYAML Word64 where + parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word64'") pure $ fromIntegerMaybe b + parseYAML n = failTypeMismatch "!!int" n + +instance (Ord k, FromYAML k, FromYAML v) => FromYAML (Map k v) where + parseYAML = withMap "!!map" $ \xs -> Map.fromList <$> mapM (\(a,b) -> (,) <$> parseYAML a <*> parseYAML b) (Map.toList xs) + +-- | Operate on @tag:yaml.org,2002:seq@ node (or fail) +withMap :: String -> (Mapping -> Parser a) -> Node -> Parser a +withMap _ f (Mapping tag xs) + | tag == tagMap = f xs +withMap expected _ v = failTypeMismatch expected v + +instance FromYAML v => FromYAML [v] where + parseYAML = withSeq "!!seq" (mapM parseYAML) + +-- | Operate on @tag:yaml.org,2002:seq@ node (or fail) +withSeq :: String -> ([Node] -> Parser a) -> Node -> Parser a +withSeq _ f (Sequence tag xs) + | tag == tagSeq = f xs +withSeq expected _ v = failTypeMismatch expected v + +instance FromYAML a => FromYAML (Maybe a) where + parseYAML (Scalar SNull) = pure Nothing + parseYAML j = Just <$> parseYAML j + +---------------------------------------------------------------------------- + +instance (FromYAML a, FromYAML b) => FromYAML (a,b) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b] -> (,) <$> parseYAML a + <*> parseYAML b + _ -> fail ("expected 2-sequence but got " ++ show (length xs) ++ "-sequence instead") + +instance (FromYAML a, FromYAML b, FromYAML c) => FromYAML (a,b,c) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b,c] -> (,,) <$> parseYAML a + <*> parseYAML b + <*> parseYAML c + _ -> fail ("expected 3-sequence but got " ++ show (length xs) ++ "-sequence instead") + + +instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d) => FromYAML (a,b,c,d) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b,c,d] -> (,,,) <$> parseYAML a + <*> parseYAML b + <*> parseYAML c + <*> parseYAML d + _ -> fail ("expected 4-sequence but got " ++ show (length xs) ++ "-sequence instead") + + +instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e) => FromYAML (a,b,c,d,e) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b,c,d,e] -> (,,,,) <$> parseYAML a + <*> parseYAML b + <*> parseYAML c + <*> parseYAML d + <*> parseYAML e + _ -> fail ("expected 5-sequence but got " ++ show (length xs) ++ "-sequence instead") + + +instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e, FromYAML f) => FromYAML (a,b,c,d,e,f) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b,c,d,e,f] -> (,,,,,) <$> parseYAML a + <*> parseYAML b + <*> parseYAML c + <*> parseYAML d + <*> parseYAML e + <*> parseYAML f + _ -> fail ("expected 6-sequence but got " ++ show (length xs) ++ "-sequence instead") + + +instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d, FromYAML e, FromYAML f, FromYAML g) => FromYAML (a,b,c,d,e,f,g) where + parseYAML = withSeq "!!seq" $ \xs -> + case xs of + [a,b,c,d,e,f,g] -> (,,,,,,) <$> parseYAML a + <*> parseYAML b + <*> parseYAML c + <*> parseYAML d + <*> parseYAML e + <*> parseYAML f + <*> parseYAML g + _ -> fail ("expected 7-sequence but got " ++ show (length xs) ++ "-sequence instead") + + +-- | Decode YAML document(s) using the YAML 1.2 Core schema +-- +-- Each document contained in the YAML stream produce one element of +-- the response list. Here's an example of decoding two concatenated +-- YAML documents: +-- +-- >>> decode "Foo\n---\nBar" :: Either String [Text] +-- Right ["Foo","Bar"] +-- +-- Note that an empty stream doesn't contain any (non-comment) +-- document nodes, and therefore results in an empty result list: +-- +-- >>> decode "# just a comment" :: Either String [Text] +-- Right [] +-- +-- 'decode' uses the same settings as 'decodeNode' for tag-resolving. If +-- you need a different custom parsing configuration, you need to +-- combine 'parseEither' and `decodeNode'` yourself. +decode :: FromYAML v => BS.L.ByteString -> Either String [v] +decode bs0 = decodeNode bs0 >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) + diff --git a/src/Data/YAML/Event.hs b/src/Data/YAML/Event.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Event.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- Event-stream oriented YAML parsing API +module Data.YAML.Event + ( parseEvents + , EvStream + , Event(..) + , Style(..) + , Tag, untagged, isUntagged, tagToText, mkTag + , Anchor + , Pos(..) + ) where + +import qualified Data.ByteString.Lazy as BS.L +import Data.Char +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.YAML.Token as Y +import Numeric (readHex) + +import Util + +-- TODO: consider also non-essential attributes + +-- | YAML Event Types +-- +-- The events correspond to the ones from [LibYAML](http://pyyaml.org/wiki/LibYAML) +-- +-- The grammar below defines well-formed streams of 'Event's: +-- +-- @ +-- stream ::= 'StreamStart' document* 'StreamEnd' +-- document ::= 'DocumentStart' node 'DocumentEnd' +-- node ::= 'Alias' +-- | 'Scalar' +-- | sequence +-- | mapping +-- sequence ::= 'SequenceStart' node* 'SequenceEnd' +-- mapping ::= 'MappingStart' (node node)* 'MappingEnd' +-- @ +data Event + = StreamStart + | StreamEnd + | DocumentStart !Bool + | DocumentEnd !Bool + | Alias !Anchor + | Scalar !(Maybe Anchor) !Tag !Style !Text + | SequenceStart !(Maybe Anchor) !Tag + | SequenceEnd + | MappingStart !(Maybe Anchor) !Tag + | MappingEnd + deriving (Show, Eq) + +-- | YAML Anchor identifiers +type Anchor = Text + +-- | YAML Tags +newtype Tag = Tag (Maybe Text) + deriving (Eq,Ord) + +instance Show Tag where + show (Tag x) = show x + +-- | Convert 'Tag' to its string representation +-- +-- Returns 'Nothing' for 'untagged' +tagToText :: Tag -> Maybe T.Text +tagToText (Tag x) = x + +-- | An \"untagged\" YAML tag +untagged :: Tag +untagged = Tag Nothing + +-- | Equivalent to @(== 'untagged')@ +isUntagged :: Tag -> Bool +isUntagged (Tag Nothing) = True +isUntagged _ = False + +-- | Construct YAML tag +mkTag :: String -> Tag +mkTag "" = error "mkTag" +mkTag "!" = Tag (Just $! T.pack "!") +mkTag s = Tag (Just $! tagUnescape s) + where + tagUnescape = T.pack . go + where + go [] = [] + go ('%':h:l:cs) + | Just c <- decodeL1 [h,l] = c : go cs + go (c:cs) = c : go cs + + +mkTag' :: String -> Tag +mkTag' "" = error "mkTag'" +mkTag' s = Tag (Just $! T.pack s) + +mkTag'' :: String -> Tag +mkTag'' "" = error "mkTag''" +mkTag'' s = Tag (Just $! T.pack ("tag:yaml.org,2002:" ++ s)) + + + +-- | Event stream produced by 'parseEvents' +-- +-- A 'Left' value denotes parsing errors. The event stream ends +-- immediately once a 'Left' value is returned. +type EvStream = [Either (Pos,String) Event] + +-- | Position in parsed YAML source +data Pos = Pos + { posByteOffset :: !Int -- ^ 0-based byte offset + , posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset + , posLine :: !Int -- ^ 1-based line number + , posColumn :: !Int -- ^ 0-based character (Unicode code-point) column number + } deriving Show + +tok2pos :: Y.Token -> Pos +tok2pos Y.Token { Y.tByteOffset = posByteOffset, Y.tCharOffset = posCharOffset, Y.tLine = posLine, Y.tLineChar = posColumn } = Pos {..} + +-- | 'Scalar' node style +data Style = Plain + | SingleQuoted + | DoubleQuoted + | Literal + | Folded + deriving (Eq,Ord,Show) + +-- internal +type TagHandle = Text +type Props = (Maybe Text,Tag) + +getHandle :: [Y.Token] -> Maybe (TagHandle,[Y.Token]) +getHandle toks0 = do + Y.Token { Y.tCode = Y.BeginHandle } : toks1 <- Just toks0 + (hs,Y.Token { Y.tCode = Y.EndHandle } : toks2) <- Just $ span (\Y.Token { Y.tCode = c } -> c `elem` [Y.Indicator,Y.Meta]) toks1 + pure (T.pack $ concatMap Y.tText hs, toks2) + +getUriTag :: [Y.Token] -> Maybe (Text,[Y.Token]) +getUriTag toks0 = do + Y.Token { Y.tCode = Y.BeginTag } : toks1 <- Just toks0 + (hs,Y.Token { Y.tCode = Y.EndTag } : toks2) <- Just $ span (\Y.Token { Y.tCode = c } -> c `elem` [Y.Indicator,Y.Meta]) toks1 + pure (T.pack $ concatMap Y.tText hs, toks2) + +{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit. + + _ + _._ _..._ .-', _.._(`)) +'-. ` ' /-._.-' ',/ + ) \ '. + / _ _ | \ + | a a / | + \ .-. ; + '-('' ).-' ,' ; + '-; | .' + \ \ / + | 7 .__ _.-\ \ + | | | ``/ /` / + /,_| | /,_/ / + /,_/ '`-' + +-} + +-- | Parse YAML 'Event's from a lazy 'BS.L.ByteString'. +parseEvents :: BS.L.ByteString -> EvStream +parseEvents = \bs0 -> Right StreamStart : (go0 mempty $ stripComments $ filter (not . isWhite) (Y.tokenize bs0 False)) + where + isTCode tc = (== tc) . Y.tCode + skipPast tc (t : ts) + | isTCode tc t = ts + | otherwise = skipPast tc ts + skipPast _ [] = error "the impossible happened" + + + isWhite :: Y.Token -> Bool + isWhite (Y.Token { Y.tCode = Y.White }) = True + isWhite (Y.Token { Y.tCode = Y.Indent }) = True + isWhite (Y.Token { Y.tCode = Y.Break }) = True + isWhite _ = False + + goDir :: Map TagHandle Text -> [Y.Token] -> EvStream + goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = "YAML" } : + Y.Token { Y.tCode = Y.Meta } : + Y.Token { Y.tCode = Y.EndDirective } : + rest) = go0 m rest + + goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = "TAG" } : + rest) + | Just (h, rest') <- getHandle rest + , Just (t, rest'') <- getUriTag rest' = go0 (Map.insert h t m) (skipPast Y.EndDirective rest'') + + goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = l } : + rest) | l `notElem` ["TAG","YAML"] = go0 m (skipPast Y.EndDirective rest) + goDir _ xs = err xs + + go0 :: Map.Map TagHandle Text -> Tok2EvStream + go0 _ [] = [Right StreamEnd] + go0 _ (Y.Token { Y.tCode = Y.White } : _) = error "the impossible happened" + go0 m (Y.Token { Y.tCode = Y.Indicator } : rest) = go0 m rest -- ignore indicators here + go0 m (Y.Token { Y.tCode = Y.DirectivesEnd } : rest) = go0 m rest + go0 m (Y.Token { Y.tCode = Y.BeginDocument } : Y.Token { Y.tCode = Y.DirectivesEnd } : rest) = Right (DocumentStart True) : go0 m rest -- hack + go0 m (Y.Token { Y.tCode = Y.BeginDocument } : rest@(Y.Token { Y.tCode = Y.BeginDirective } : _)) = Right (DocumentStart True) : go0 m rest -- hack + go0 m (Y.Token { Y.tCode = Y.BeginDocument } : rest) = Right (DocumentStart False) : go0 m rest + go0 _ (Y.Token { Y.tCode = Y.EndDocument } : Y.Token { Y.tCode = Y.DocumentEnd } : rest) = Right (DocumentEnd True) : go0 mempty rest + go0 _ (Y.Token { Y.tCode = Y.EndDocument } : rest) = Right (DocumentEnd False) : go0 mempty rest + go0 m (Y.Token { Y.tCode = Y.DocumentEnd } : rest) = go0 m rest -- should not occur + go0 m (Y.Token { Y.tCode = Y.BeginNode } : rest) = goNode0 m rest (go0 m) + go0 m (Y.Token { Y.tCode = Y.BeginDirective } : rest) = goDir m rest + go0 _ xs = err xs + +err :: Tok2EvStream +err (tok@Y.Token { Y.tCode = Y.Error, Y.tText = msg } : _) = [Left (tok2pos tok, msg)] +err (tok@Y.Token { Y.tCode = Y.Unparsed, Y.tText = txt } : _) = [Left (tok2pos tok, ("Lexical error near " ++ show txt))] +err (tok@Y.Token { Y.tCode = code } : _) = [Left (tok2pos tok, ("Parse failure near " ++ show code ++ " token"))] +err [] = [Left ((Pos (-1) (-1) (-1) (-1)), "Unexpected end of token stream")] + +goNode0 :: Map TagHandle Text -> Tok2EvStreamCont +goNode0 tagmap = goNode + where + goNode :: Tok2EvStreamCont + goNode (Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (mempty,untagged) rest (flip goNodeEnd cont) + goNode (Y.Token { Y.tCode = Y.BeginSequence } : rest) cont = Right (SequenceStart Nothing untagged) : goSeq rest (flip goNodeEnd cont) + goNode (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart Nothing untagged) : goMap rest (flip goNodeEnd cont) + goNode (Y.Token { Y.tCode = Y.BeginProperties } : rest) cont = goProp (mempty,untagged) rest (\p rest' -> goNode' p rest' cont) + goNode (Y.Token { Y.tCode = Y.BeginAlias } : + Y.Token { Y.tCode = Y.Indicator } : + Y.Token { Y.tCode = Y.Meta, Y.tText = anchor } : + Y.Token { Y.tCode = Y.EndAlias } : + Y.Token { Y.tCode = Y.EndNode } : + rest) cont = Right (Alias (T.pack anchor)) : cont rest + goNode xs _cont = err xs + + goNode' :: Props -> Tok2EvStreamCont + goNode' props (Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar props rest (flip goNodeEnd cont) + goNode' (manchor,mtag) (Y.Token { Y.tCode = Y.BeginSequence } : rest) cont = Right (SequenceStart manchor mtag) : goSeq rest (flip goNodeEnd cont) + goNode' (manchor,mtag) (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart manchor mtag) : goMap rest (flip goNodeEnd cont) + goNode' _ xs _cont = err xs + + goNodeEnd :: Tok2EvStreamCont + goNodeEnd (Y.Token { Y.tCode = Y.EndNode } : rest) cont = cont rest + goNodeEnd xs _cont = err xs + + goProp :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream + goProp props (Y.Token { Y.tCode = Y.EndProperties } : rest) cont = cont props rest + goProp props (Y.Token { Y.tCode = Y.BeginAnchor } : rest) cont = goAnchor props rest (\x y -> goProp x y cont) + goProp props (Y.Token { Y.tCode = Y.BeginTag } : rest) cont = goTag props rest (\x y -> goProp x y cont) + goProp _props xs _cont = err xs + + goAnchor :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream + goAnchor props (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goAnchor props rest cont + goAnchor (_,tag) (Y.Token { Y.tCode = Y.Meta, Y.tText = anchor } : rest) cont = goAnchor (Just $! T.pack anchor,tag) rest cont + goAnchor props (Y.Token { Y.tCode = Y.EndAnchor } : rest) cont = cont props rest + goAnchor _ xs _ = err xs + + goTag :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream + + goTag (anchor,_) (Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.EndTag } : rest) + cont = cont (anchor,mkTag' "!") rest + + goTag (anchor,_) (Y.Token { Y.tCode = Y.BeginHandle } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.EndHandle } : + Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : + Y.Token { Y.tCode = Y.EndTag } : rest) + cont + | Just t' <- Map.lookup (T.pack ("!!")) tagmap + = cont (anchor,mkTag (T.unpack t' ++ tag)) rest + | otherwise = cont (anchor,mkTag'' tag) rest + + goTag (anchor,_) (Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "<" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = ">" } : + Y.Token { Y.tCode = Y.EndTag } : rest) + cont = cont (anchor,mkTag tag) rest + + goTag (anchor,_) xs@(Y.Token { Y.tCode = Y.BeginHandle } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = h } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.EndHandle } : + Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : + Y.Token { Y.tCode = Y.EndTag } : rest) + cont + | Just t' <- Map.lookup (T.pack ("!" ++ h ++ "!")) tagmap + = cont (anchor,mkTag (T.unpack t' ++ tag)) rest + | otherwise = err xs + + goTag (anchor,_) (Y.Token { Y.tCode = Y.BeginHandle } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } : + Y.Token { Y.tCode = Y.EndHandle } : + Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : + Y.Token { Y.tCode = Y.EndTag } : rest) + cont + | Just t' <- Map.lookup (T.pack ("!")) tagmap + = cont (anchor,mkTag (T.unpack t' ++ tag)) rest + | otherwise = cont (anchor,mkTag' ('!' : tag)) rest -- unresolved + goTag _ xs _ = err xs + + goScalar :: Props -> Tok2EvStreamCont + goScalar (manchor,tag) toks0 cont = go' "" Plain toks0 + where + go' acc sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' (acc ++ t) sty rest + go' acc sty (Y.Token { Y.tCode = Y.LineFold } : rest) = go' (acc ++ " ") sty rest + go' acc sty (Y.Token { Y.tCode = Y.LineFeed } : rest) = go' (acc ++ "\n") sty rest + + go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "'" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = "'" } : + Y.Token { Y.tCode = Y.EndEscape } : + rest) = go' (acc ++ "'") sty rest + + go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : +-- Y.Token { Y.tCode = Y.Break } : + Y.Token { Y.tCode = Y.EndEscape } : + rest) = go' acc sty rest -- end-line + + go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = t } : + Y.Token { Y.tCode = Y.EndEscape } : + rest) + | t == "n" = go' (acc ++ "\n") sty rest + | t == "r" = go' (acc ++ "\r") sty rest + | t == "t" = go' (acc ++ "\t") sty rest + | t == "b" = go' (acc ++ "\b") sty rest + | t == "/" = go' (acc ++ t) sty rest + | t == " " = go' (acc ++ t) sty rest + | t == "\\" = go' (acc ++ t) sty rest + | t == "\"" = go' (acc ++ t) sty rest + + go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : + Y.Token { Y.tCode = Y.Indicator, Y.tText = pfx } : + Y.Token { Y.tCode = Y.Meta, Y.tText = ucode } : + Y.Token { Y.tCode = Y.EndEscape } : + rest) + | pfx == "u", Just c <- decodeCP ucode = go' (acc ++ [c]) sty rest + | pfx == "x", Just c <- decodeL1 ucode = go' (acc ++ [c]) sty rest + + go' acc sty (Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) + | "'" <- ind = go' acc SingleQuoted rest + | "\"" <- ind = go' acc DoubleQuoted rest + | "|" <- ind = go' acc Literal rest + | ">" <- ind = go' acc Folded rest + | otherwise = go' acc sty rest + go' acc sty (Y.Token { Y.tCode = Y.EndScalar } : rest) = Right (Scalar manchor tag sty (T.pack acc)) : cont rest + go' _ _ xs | False = error (show xs) + go' _ _ xs = err xs + + goSeq :: Tok2EvStreamCont + goSeq (Y.Token { Y.tCode = Y.EndSequence } : rest) cont = Right SequenceEnd : cont rest + goSeq (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goSeq cont) + goSeq (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart Nothing untagged) : goMap rest (flip goSeq cont) + goSeq (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goSeq rest cont +-- goSeq xs _cont = error (show xs) + goSeq xs _cont = err xs + + goMap :: Tok2EvStreamCont + goMap (Y.Token { Y.tCode = Y.EndMapping } : rest) cont = Right MappingEnd : cont rest + goMap (Y.Token { Y.tCode = Y.BeginPair } : rest) cont = goPair1 rest (flip goMap cont) + goMap (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goMap rest cont + goMap xs _cont = err xs + + goPair1 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPair2 cont) + goPair1 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair1 rest cont + goPair1 xs _cont = err xs + + goPair2 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPairEnd cont) + goPair2 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair2 rest cont + goPair2 xs _cont = err xs + + goPairEnd (Y.Token { Y.tCode = Y.EndPair } : rest) cont = cont rest + goPairEnd xs _cont = err xs + + +stripComments :: [Y.Token] -> [Y.Token] +stripComments (Y.Token { Y.tCode = Y.BeginComment } : rest) = skip rest + where + skip (Y.Token { Y.tCode = Y.EndComment } : rest') = stripComments rest' + skip (_ : rest') = skip rest' + skip [] = error "the impossible happened" +stripComments (t : rest) = t : stripComments rest +stripComments [] = [] + +type Tok2EvStream = [Y.Token] -> EvStream + +type Tok2EvStreamCont = [Y.Token] -> Cont EvStream [Y.Token] + +type Cont r a = (a -> r) -> r + + +-- decode 4-hex-digit unicode code-point +decodeCP :: String -> Maybe Char +decodeCP s = case s of + [_,_,_,_] | all isHexDigit s + , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) + _ -> Nothing + +-- decode 2-hex-digit latin1 code-point +decodeL1 :: String -> Maybe Char +decodeL1 s = case s of + [_,_] | all isHexDigit s + , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) + _ -> Nothing diff --git a/src/Data/YAML/Loader.hs b/src/Data/YAML/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Loader.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +module Data.YAML.Loader + ( decodeLoader + , Loader(..) + , NodeId + ) where + +import Control.Monad.Except +import Control.Monad.State +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.YAML.Event (Tag) +import qualified Data.YAML.Event as YE +import Util + +-- | Unique identifier for identifying nodes +-- +-- This is allows to observe the alias/anchor-reference structure +type NodeId = Word + +-- | Structure defining how to construct a document tree/graph +-- +data Loader m n = Loader + { yScalar :: Tag -> YE.Style -> Text -> m (Either String n) + , ySequence :: Tag -> [n] -> m (Either String n) + , yMapping :: Tag -> [(n,n)] -> m (Either String n) + , yAlias :: NodeId -> Bool -> n -> m (Either String n) + , yAnchor :: NodeId -> n -> m (Either String n) + } + +-- | Generalised document tree/graph construction +-- +-- This doesn't yet perform any tag resolution (thus all scalars are +-- represented as 'Text' values). See also 'decodeNode' for a more +-- convenient interface. +{-# INLINEABLE decodeLoader #-} +decodeLoader :: forall n m . MonadFix m => Loader m n -> BS.L.ByteString -> m (Either String [n]) +decodeLoader Loader{..} bs0 = do + case sequence . YE.parseEvents $ bs0 of + Left (pos,err) + | YE.posCharOffset pos < 0 -> return (Left err) + | otherwise -> return (Left $ ":" ++ show (YE.posLine pos) ++ ":" ++ show (YE.posColumn pos) ++ ": " ++ err) + Right evs -> runParserT goStream evs + where + goStream :: PT n m [n] + goStream = do + _ <- satisfy (== YE.StreamStart) + ds <- manyUnless (== YE.StreamEnd) goDoc + eof + return ds + + goDoc :: PT n m n + goDoc = do + _ <- satisfy isDocStart + modify $ \s0 -> s0 { sDict = mempty, sCycle = mempty } + n <- goNode + _ <- satisfy isDocEnd + return n + + getNewNid :: PT n m Word + getNewNid = state $ \s0 -> let i0 = sIdCnt s0 + in (i0, s0 { sIdCnt = i0+1 }) + + returnNode :: (Maybe YE.Anchor) -> Either String n -> PT n m n + returnNode _ (Left err) = throwError err + returnNode Nothing (Right node) = return node + returnNode (Just a) (Right node) = do + nid <- getNewNid + node0 <- lift $ yAnchor nid node + node' <- liftEither node0 + modify $ \s0 -> s0 { sDict = Map.insert a (nid,node') (sDict s0) } + return node' + + registerAnchor :: Maybe YE.Anchor -> PT n m n -> PT n m n + registerAnchor Nothing pn = pn + registerAnchor (Just a) pn = do + modify $ \s0 -> s0 { sCycle = Set.insert a (sCycle s0) } + nid <- getNewNid + + mdo + modify $ \s0 -> s0 { sDict = Map.insert a (nid,n) (sDict s0) } + n0 <- pn + n1 <- lift $ yAnchor nid n0 + n <- liftEither n1 + return n + + exitAnchor :: Maybe YE.Anchor -> PT n m () + exitAnchor Nothing = return () + exitAnchor (Just a) = modify $ \s0 -> s0 { sCycle = Set.delete a (sCycle s0) } + + goNode :: PT n m n + goNode = do + n <- satisfy (const True) + case n of + YE.Scalar manc tag sty val -> do + exitAnchor manc + n' <- lift $ yScalar tag sty val + returnNode manc $! n' + + YE.SequenceStart manc tag -> registerAnchor manc $ do + ns <- manyUnless (== YE.SequenceEnd) goNode + exitAnchor manc + liftEither =<< (lift $ ySequence tag ns) + + YE.MappingStart manc tag -> registerAnchor manc $ do + kvs <- manyUnless (== YE.MappingEnd) (liftM2 (,) goNode goNode) + exitAnchor manc + liftEither =<< (lift $ yMapping tag kvs) + + YE.Alias a -> do + d <- gets sDict + cy <- gets sCycle + case Map.lookup a d of + Nothing -> throwError ("anchor not found: " ++ show a) + Just (nid,n') -> liftEither =<< (lift $ yAlias nid (Set.member a cy) n') + + _ -> throwError "goNode: unexpected event" + + +---------------------------------------------------------------------------- +-- small parser framework + + +data S n = S { sEvs :: [YE.Event] + , sDict :: Map YE.Anchor (Word,n) + , sCycle :: Set YE.Anchor + , sIdCnt :: !Word + } + +newtype PT n m a = PT (StateT (S n) (ExceptT String m) a) + deriving ( Functor + , Applicative + , Monad + , MonadState (S n) + , MonadError String + , MonadFix + ) + +instance MonadTrans (PT n) where + lift = PT . lift . lift + +runParserT :: Monad m => PT n m a -> [YE.Event] -> m (Either String a) +runParserT (PT act) s0 = runExceptT $ evalStateT act (S s0 mempty mempty 0) + +satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.Event +satisfy p = do + s0 <- get + case sEvs s0 of + [] -> throwError "satisfy: premature eof" + (ev:rest) + | p ev -> do put (s0 { sEvs = rest}) + return ev + | otherwise -> throwError ("satisfy: predicate failed " ++ show ev) + +peek :: Monad m => PT n m (Maybe YE.Event) +peek = do + s0 <- get + case sEvs s0 of + [] -> return Nothing + (ev:_) -> return (Just ev) + +peek1 :: Monad m => PT n m YE.Event +peek1 = maybe (throwError "peek1: premature eof") return =<< peek + +anyEv :: Monad m => PT n m YE.Event +anyEv = satisfy (const True) + +eof :: Monad m => PT n m () +eof = do + s0 <- get + case sEvs s0 of + [] -> return () + _ -> throwError "eof expected" + +-- NB: consumes the end-event +manyUnless :: Monad m => (YE.Event -> Bool) -> PT n m a -> PT n m [a] +manyUnless p act = do + t0 <- peek1 + if p t0 + then anyEv >> return [] + else liftM2 (:) act (manyUnless p act) + +{- +tryError :: MonadError e m => m a -> m (Either e a) +tryError act = catchError (Right <$> act) (pure . Left) +-} + +isDocStart :: YE.Event -> Bool +isDocStart (YE.DocumentStart _) = True +isDocStart _ = False + +isDocEnd :: YE.Event -> Bool +isDocEnd (YE.DocumentEnd _) = True +isDocEnd _ = False diff --git a/src/Data/YAML/Schema.hs b/src/Data/YAML/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Schema.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- YAML 1.2 Schema resolvers +-- +module Data.YAML.Schema + ( SchemaResolver(..) + , failsafeSchemaResolver + , jsonSchemaResolver + , coreSchemaResolver + , Scalar(..) + + , tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap + ) where + +import Control.Monad.Except +import qualified Data.Char as C +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Numeric (readHex, readOct) +import Text.Parsec as P +import Text.Parsec.Text + +import Data.YAML.Event (Tag, isUntagged, mkTag, untagged) +import qualified Data.YAML.Event as YE + +import Util + +-- | Primitive scalar types as defined in YAML 1.2 +data Scalar = SNull -- ^ @tag:yaml.org,2002:null@ + | SBool !Bool -- ^ @tag:yaml.org,2002:bool@ + | SFloat !Double -- ^ @tag:yaml.org,2002:float@ + | SInt !Integer -- ^ @tag:yaml.org,2002:int@ + | SStr !Text -- ^ @tag:yaml.org,2002:str@ + + | SUnknown !Tag !Text -- ^ unknown/unsupported tag or untagged (thus unresolved) scalar + deriving (Eq,Ord,Show) + + +-- | Definition of a [YAML 1.2 Schema](http://yaml.org/spec/1.2/spec.html#Schema) +-- +-- A YAML schema defines how implicit tags are resolved to concrete tags and how data is represented textually in YAML. +data SchemaResolver = SchemaResolver + { schemaResolverScalar :: Tag -> YE.Style -> T.Text -> Either String Scalar + , schemaResolverSequence :: Tag -> Either String Tag + , schemaResolverMapping :: Tag -> Either String Tag + } + + +data ScalarTag = ScalarBangTag -- ^ non-specific ! tag + | ScalarQMarkTag -- ^ non-specific ? tag + | ScalarTag !Tag -- ^ specific tag + +-- common logic for 'schemaResolverScalar' +scalarTag :: (ScalarTag -> T.Text -> Either String Scalar) + -> Tag -> YE.Style -> T.Text -> Either String Scalar +scalarTag f tag sty val = f tag' val + where + tag' = case sty of + YE.Plain + | tag == untagged -> ScalarQMarkTag -- implicit ? tag + + _ | tag == untagged -> ScalarBangTag -- implicit ! tag + | tag == tagBang -> ScalarBangTag -- explicit ! tag + | otherwise -> ScalarTag tag + + +-- | \"Failsafe\" schema resolver as specified +-- in [YAML 1.2 / 10.1.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2803036) +failsafeSchemaResolver :: SchemaResolver +failsafeSchemaResolver = SchemaResolver{..} + where + -- scalars + schemaResolverScalar = scalarTag go + where + go ScalarBangTag v = Right (SStr v) + go (ScalarTag t) v + | t == tagStr = Right (SStr v) + | otherwise = Right (SUnknown t v) + go ScalarQMarkTag v = Right (SUnknown untagged v) -- leave unresolved + + -- mappings + schemaResolverMapping t + | t == tagBang = Right tagMap + | otherwise = Right t + + -- sequences + schemaResolverSequence t + | t == tagBang = Right tagSeq + | otherwise = Right t + +-- | Strict JSON schema resolver as specified +-- in [YAML 1.2 / 10.2.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2804356) +jsonSchemaResolver :: SchemaResolver +jsonSchemaResolver = SchemaResolver{..} + where + -- scalars + schemaResolverScalar = scalarTag go + where + go ScalarBangTag v = Right (SStr v) + go (ScalarTag t) v + | t == tagStr = Right (SStr v) + | t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v) + | t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ jsonDecodeInt v + | t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ jsonDecodeFloat v + | t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ jsonDecodeBool v + | otherwise = Right (SUnknown t v) -- unknown specific tag + go ScalarQMarkTag v + | isNullLiteral v = Right SNull + | Just b <- jsonDecodeBool v = Right $! SBool b + | Just i <- jsonDecodeInt v = Right $! SInt i + | Just f <- jsonDecodeFloat v = Right $! SFloat f + | otherwise = Right (SUnknown untagged v) -- leave unresolved -- FIXME: YAML 1.2 spec requires an error here + + isNullLiteral = (== "null") + + -- mappings + schemaResolverMapping t + | t == tagBang = Right tagMap + | isUntagged t = Right tagMap + | otherwise = Right t + + -- sequences + schemaResolverSequence t + | t == tagBang = Right tagSeq + | isUntagged t = Right tagSeq + | otherwise = Right t + +-- | Core JSON schema resolver as specified +-- in [YAML 1.2 / 10.3.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2805071) +coreSchemaResolver :: SchemaResolver +coreSchemaResolver = SchemaResolver{..} + where + -- scalars + schemaResolverScalar = scalarTag go + where + go ScalarBangTag v = Right (SStr v) + go (ScalarTag t) v + | t == tagStr = Right (SStr v) + | t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v) + | t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ coreDecodeInt v + | t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ coreDecodeFloat v + | t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ coreDecodeBool v + | otherwise = Right (SUnknown t v) -- unknown specific tag + go ScalarQMarkTag v + | isNullLiteral v = Right SNull + | Just b <- coreDecodeBool v = Right $! SBool b + | Just i <- coreDecodeInt v = Right $! SInt i + | Just f <- coreDecodeFloat v = Right $! SFloat f + | otherwise = Right (SStr v) -- map to !!str by default + + isNullLiteral = flip Set.member (Set.fromList [ "", "null", "NULL", "Null", "~" ]) + + -- mappings + schemaResolverMapping t + | t == tagBang = Right tagMap + | isUntagged t = Right tagMap + | otherwise = Right t + + -- sequences + schemaResolverSequence t + | t == tagBang = Right tagSeq + | isUntagged t = Right tagSeq + | otherwise = Right t + + +-- | @tag:yaml.org,2002:bool@ (JSON Schema) +jsonDecodeBool :: T.Text -> Maybe Bool +jsonDecodeBool "false" = Just False +jsonDecodeBool "true" = Just True +jsonDecodeBool _ = Nothing + +-- | @tag:yaml.org,2002:bool@ (Core Schema) +coreDecodeBool :: T.Text -> Maybe Bool +coreDecodeBool = flip Map.lookup $ + Map.fromList [ ("true", True) + , ("True", True) + , ("TRUE", True) + , ("false", False) + , ("False", False) + , ("FALSE", False) + ] + +-- | @tag:yaml.org,2002:int@ according to JSON Schema +-- +-- > 0 | -? [1-9] [0-9]* +jsonDecodeInt :: T.Text -> Maybe Integer +jsonDecodeInt t | T.null t = Nothing +jsonDecodeInt "0" = Just 0 +jsonDecodeInt t = do + -- [-]? [1-9] [0-9]* + let tabs | T.isPrefixOf "-" t = T.tail t + | otherwise = t + + guard (not (T.null tabs)) + guard (T.head tabs /= '0') + guard (T.all C.isDigit tabs) + + readMaybe (T.unpack t) + +-- | @tag:yaml.org,2002:int@ according to Core Schema +-- +-- > [-+]? [0-9]+ (Base 10) +-- > 0o [0-7]+ (Base 8) +-- > 0x [0-9a-fA-F]+ (Base 16) +-- +coreDecodeInt :: T.Text -> Maybe Integer +coreDecodeInt t + | T.null t = Nothing + + -- > 0x [0-9a-fA-F]+ (Base 16) + | Just rest <- T.stripPrefix "0x" t + , T.all C.isHexDigit rest + , [(j,"")] <- readHex (T.unpack rest) + = Just $! j + + -- 0o [0-7]+ (Base 8) + | Just rest <- T.stripPrefix "0o" t + , T.all C.isOctDigit rest + , [(j,"")] <- readOct (T.unpack rest) + = Just $! j + + -- [-+]? [0-9]+ (Base 10) + | T.all C.isDigit t + = Just $! read (T.unpack t) + + | Just rest <- T.stripPrefix "+" t + , not (T.null rest) + , T.all C.isDigit rest + = Just $! read (T.unpack rest) + + | Just rest <- T.stripPrefix "-" t + , not (T.null rest) + , T.all C.isDigit rest + = Just $! read (T.unpack t) + + | otherwise = Nothing + + +-- | @tag:yaml.org,2002:float@ according to JSON Schema +-- +-- > -? ( 0 | [1-9] [0-9]* ) ( \. [0-9]* )? ( [eE] [-+]? [0-9]+ )? +-- +jsonDecodeFloat :: T.Text -> Maybe Double +jsonDecodeFloat = either (const Nothing) Just . parse float "" + where + float :: Parser Double + float = do + -- -? + p0 <- option "" ("-" <$ char '-') + + -- ( 0 | [1-9] [0-9]* ) + p1 <- do + d <- digit + if (d /= '0') + then (d:) <$> P.many digit + else pure [d] + + -- ( \. [0-9]* )? + p2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit) + + -- ( [eE] [-+]? [0-9]+ )? + p3 <- option "" $ do + void (char 'e' P.<|> char 'E') + s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+')) + d <- P.many digit + + pure ("e" ++ s ++ d) + + eof + + let t' = p0++p1++p2++p3 + pure $! read t' + +-- | @tag:yaml.org,2002:float@ according to Core Schema +-- +-- > [-+]? ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) ( [eE] [-+]? [0-9]+ )? +-- +coreDecodeFloat :: T.Text -> Maybe Double +coreDecodeFloat t + | Just j <- Map.lookup t literals = Just j -- short-cut + | otherwise = either (const Nothing) Just . parse float "" $ t + where + float :: Parser Double + float = do + -- [-+]? + p0 <- option "" (("-" <$ char '-') P.<|> "" <$ char '+') + + -- ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) + p1 <- (char '.' *> (("0."++) <$> many1 digit)) + P.<|> do d1 <- many1 digit + d2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit) + pure (d1++d2) + + -- ( [eE] [-+]? [0-9]+ )? + p2 <- option "" $ do + void (char 'e' P.<|> char 'E') + s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+')) + d <- P.many digit + + pure ("e" ++ s ++ d) + + eof + + let t' = p0++p1++p2 + + pure $! read t' + + literals = Map.fromList + [ ("0" , 0) + + , (".nan", (0/0)) + , (".NaN", (0/0)) + , (".NAN", (0/0)) + + , (".inf", (1/0)) + , (".Inf", (1/0)) + , (".INF", (1/0)) + + , ("+.inf", (1/0)) + , ("+.Inf", (1/0)) + , ("+.INF", (1/0)) + + , ("-.inf", (-1/0)) + , ("-.Inf", (-1/0)) + , ("-.INF", (-1/0)) + ] + + +tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap, tagBang :: Tag +tagNull = mkTag "tag:yaml.org,2002:null" +tagStr = mkTag "tag:yaml.org,2002:str" +tagInt = mkTag "tag:yaml.org,2002:int" +tagFloat = mkTag "tag:yaml.org,2002:float" +tagBool = mkTag "tag:yaml.org,2002:bool" +tagSeq = mkTag "tag:yaml.org,2002:seq" +tagMap = mkTag "tag:yaml.org,2002:map" +tagBang = mkTag "!" diff --git a/src/Data/YAML/Token.hs b/src/Data/YAML/Token.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Token.hs @@ -0,0 +1,1958 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PostfixOperators #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- FIXME + +-- | +-- Copyright: © Oren Ben-Kiki 2007, +-- © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- Tokenizer for the YAML 1.2 syntax as defined in . +-- +module Data.YAML.Token + ( tokenize + , Token(..) + , Code(..) + ) where + +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Char (chr, ord) +import qualified Data.DList as D +import Prelude hiding ((*), (+), (-), (/), (^)) +import qualified Prelude + +import Util hiding (empty) + +-- * Generic operators +-- +-- ** Numeric operators +-- +-- We rename the four numerical operators @+@ @-@ @*@ @\/@ to start with @.@ +-- (@.+@, @.-@, @.*@, @.\/@). This allows us to use the originals for BNF +-- notation (we also hijack the @^@ operator). This is not a generally +-- recommended practice. It is justified in this case since we have very little +-- arithmetic operations, and a lot of BNF rules which this makes extremely +-- readable. + +infixl 6 .+ +-- | \".+\" is the numeric addition (we use \"+\" for postfix \"one or more\"). +(.+) :: Int -> Int -> Int +(.+) = (Prelude.+) + +infixl 6 .- +-- | \".-\" is the numeric subtraction (we use \"-\" for infix \"and not\"). +(.-) :: Int -> Int -> Int +(.-) = (Prelude.-) + +infixl 7 .* +-- | \".*\" is the numeric multiplication (we use \"*\" for postfix \"zero or +-- more\"). +(.*) :: Int -> Int -> Int +(.*) = (Prelude.*) + +-- ** Record field access +-- +-- We also define @|>@ for record access for increased readability. + +infixl 9 |> +-- | @record |> field@ is the same as @field record@, but is more readable. +(|>) :: record -> (record -> value) -> value +record |> field = field record + +-- * UTF decoding +-- +-- This really should be factored out to the standard libraries. Since it isn't +-- there, we get to tailor it exactly to our needs. We use lazy byte strings as +-- input, which should give reasonable I\/O performance when reading large +-- files. The output is a normal 'Char' list which is easy to work with and +-- should be efficient enough as long as the 'Parser' does its job right. + +-- | Recognized Unicode encodings. As of YAML 1.2 UTF-32 is also required. +data Encoding = UTF8 -- ^ UTF-8 encoding (or ASCII) + | UTF16LE -- ^ UTF-16 little endian + | UTF16BE -- ^ UTF-16 big endian + | UTF32LE -- ^ UTF-32 little endian + | UTF32BE -- ^ UTF-32 big endian + +-- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-") +-- as used by most programs. +instance Show Encoding where + show UTF8 = "UTF-8" + show UTF16LE = "UTF-16LE" + show UTF16BE = "UTF-16BE" + show UTF32LE = "UTF-32LE" + show UTF32BE = "UTF-32BE" + +-- | @decode bytes@ automatically detects the 'Encoding' used and converts the +-- /bytes/ to Unicode characters, with byte offsets. Note the offset is for +-- past end of the character, not its beginning. +decode :: BLC.ByteString -> (Encoding, [(Int, Char)]) +decode text = (encoding, undoEncoding encoding text) + where encoding = detectEncoding $ BLC.unpack $ BLC.take 4 text + +-- | @detectEncoding text@ examines the first few chars (bytes) of the /text/ +-- to deduce the Unicode encoding used according to the YAML spec. +detectEncoding :: [Char] -> Encoding +detectEncoding text = + case text of + '\x00' : '\x00' : '\xFE' : '\xFF' : _ -> UTF32BE + '\x00' : '\x00' : '\x00' : _ : _ -> UTF32BE + '\xFF' : '\xFE' : '\x00' : '\x00' : _ -> UTF32LE + _ : '\x00' : '\x00' : '\x00' : _ -> UTF32LE + '\xFE' : '\xFF' : _ -> UTF16BE + '\x00' : _ : _ -> UTF16BE + '\xFF' : '\xFE' : _ -> UTF16LE + _ : '\x00' : _ -> UTF16LE + '\xEF' : '\xBB' : '\xBF' : _ -> UTF8 + _ -> UTF8 + +-- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode +-- characters according to the /encoding/. +undoEncoding :: Encoding -> BLC.ByteString -> [(Int, Char)] +undoEncoding encoding bytes = + case encoding of + UTF8 -> undoUTF8 bytes 0 + UTF16LE -> combinePairs $ undoUTF16LE bytes 0 + UTF16BE -> combinePairs $ undoUTF16BE bytes 0 + UTF32LE -> combinePairs $ undoUTF32LE bytes 0 + UTF32BE -> combinePairs $ undoUTF32BE bytes 0 + +-- ** UTF-32 decoding + +-- | @hasFewerThan bytes n@ checks whether there are fewer than /n/ /bytes/ +-- left to read. +hasFewerThan :: Int -> BLC.ByteString -> Bool +hasFewerThan n bytes + | n == 1 = BLC.null bytes + | n > 1 = BLC.null bytes || hasFewerThan (n .- 1) (BLC.tail bytes) + | otherwise = False + +-- | @undoUTF32LE bytes offset@ decoded a UTF-32LE /bytes/ stream to Unicode +-- chars. +undoUTF32LE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF32LE bytes offset + | BLC.null bytes = [] + | hasFewerThan 4 bytes = error "UTF-32LE input contains invalid number of bytes" + | otherwise = let first = BLC.head bytes + bytes' = BLC.tail bytes + second = BLC.head bytes' + bytes'' = BLC.tail bytes' + third = BLC.head bytes'' + bytes''' = BLC.tail bytes'' + fourth = BLC.head bytes''' + rest = BLC.tail bytes''' + in (offset .+ 4, + chr $ (ord first) + .+ 256 .* ((ord second) + .+ 256 .* ((ord third) + .+ 256 .* ((ord fourth))))):(undoUTF32LE rest $ offset .+ 4) + +-- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode +-- chars. +undoUTF32BE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF32BE bytes offset + | BLC.null bytes = [] + | hasFewerThan 4 bytes = error "UTF-32BE input contains invalid number of bytes" + | otherwise = let first = BLC.head bytes + bytes' = BLC.tail bytes + second = BLC.head bytes' + bytes'' = BLC.tail bytes' + third = BLC.head bytes'' + bytes''' = BLC.tail bytes'' + fourth = BLC.head bytes''' + rest = BLC.tail bytes''' + in (offset .+ 4, + chr $ (ord fourth) + .+ 256 .* ((ord third) + .+ 256 .* ((ord second) + .+ 256 .* ((ord first))))):(undoUTF32BE rest $ offset .+ 4) + +-- ** UTF-16 decoding + +-- | @combinePairs chars@ converts each pair of UTF-16 surrogate characters to a +-- single Unicode character. +combinePairs :: [(Int, Char)] -> [(Int, Char)] +combinePairs [] = [] +combinePairs (head@(_, head_char):tail) + | '\xD800' <= head_char && head_char <= '\xDBFF' = combineLead head tail + | '\xDC00' <= head_char && head_char <= '\xDFFF' = error "UTF-16 contains trail surrogate without lead surrogate" + | otherwise = head:(combinePairs tail) + +-- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the +-- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues +-- combining surrogate pairs. +combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)] +combineLead _lead [] = error "UTF-16 contains lead surrogate as final character" +combineLead (_, lead_char) ((trail_offset, trail_char):rest) + | '\xDC00' <= trail_char && trail_char <= '\xDFFF' = (trail_offset, combineSurrogates lead_char trail_char):combinePairs rest + | otherwise = error "UTF-16 contains lead surrogate without trail surrogate" + +-- | @surrogateOffset@ is copied from the Unicode FAQs. +surrogateOffset :: Int +surrogateOffset = 0x10000 .- (0xD800 .* 1024) .- 0xDC00 + +-- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single +-- Unicode character. +combineSurrogates :: Char -> Char -> Char +combineSurrogates lead trail = chr $ (ord lead) .* 1024 .+ (ord trail) .+ surrogateOffset + +-- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode +-- chars. +undoUTF16LE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF16LE bytes offset + | BLC.null bytes = [] + | hasFewerThan 2 bytes = error "UTF-16LE input contains odd number of bytes" + | otherwise = let low = BLC.head bytes + bytes' = BLC.tail bytes + high = BLC.head bytes' + rest = BLC.tail bytes' + in (offset .+ 2, chr $ (ord low) .+ (ord high) .* 256):(undoUTF16LE rest $ offset .+ 2) + +-- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode +-- chars. +undoUTF16BE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF16BE bytes offset + | BLC.null bytes = [] + | hasFewerThan 2 bytes = error "UTF-16BE input contains odd number of bytes" + | otherwise = let high = BLC.head bytes + bytes' = BLC.tail bytes + low = BLC.head bytes' + rest = BLC.tail bytes' + in (offset .+ 2, chr $ (ord low) .+ (ord high) .* 256):(undoUTF16BE rest $ offset .+ 2) + +-- ** UTF-8 decoding + +-- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars. +undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF8 bytes offset + | BLC.null bytes = [] + | otherwise = let first = BLC.head bytes + rest = BLC.tail bytes + in case () of + _ | first < '\x80' -> (offset .+ 1, first):(undoUTF8 rest $ offset .+ 1) + | first < '\xC0' -> error $ "UTF-8 input contains invalid first byte" + | first < '\xE0' -> decodeTwoUTF8 first offset rest + | first < '\xF0' -> decodeThreeUTF8 first offset rest + | first < '\xF8' -> decodeFourUTF8 first offset rest + | otherwise -> error $ "UTF-8 input contains invalid first byte" + +-- | @decodeTwoUTF8 first offset bytes@ decodes a two-byte UTF-8 character, +-- where the /first/ byte is already available and the second is the head of +-- the /bytes/, and then continues to undo the UTF-8 encoding. +decodeTwoUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] +decodeTwoUTF8 first offset bytes + | BLC.null bytes = error "UTF-8 double byte char is missing second byte at eof" + | otherwise = let second = BLC.head bytes + rest = BLC.tail bytes + in case () of + _ | second < '\x80' || '\xBF' < second -> error $ "UTF-8 double byte char has invalid second byte" + | otherwise -> (offset .+ 2, combineTwoUTF8 first second):(undoUTF8 rest $ offset .+ 2) + +-- | @combineTwoUTF8 first second@ combines the /first/ and /second/ bytes of a +-- two-byte UTF-8 char into a single Unicode char. +combineTwoUTF8 :: Char -> Char -> Char +combineTwoUTF8 first second = chr(((ord first) .- 0xC0) .* 64 + .+ ((ord second) .- 0x80)) + +-- | @decodeThreeUTF8 first offset bytes@ decodes a three-byte UTF-8 character, +-- where the /first/ byte is already available and the second and third are the +-- head of the /bytes/, and then continues to undo the UTF-8 encoding. +decodeThreeUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] +decodeThreeUTF8 first offset bytes + | hasFewerThan 2 bytes = error "UTF-8 triple byte char is missing bytes at eof" + | otherwise = let second = BLC.head bytes + bytes' = BLC.tail bytes + third = BLC.head bytes' + rest = BLC.tail bytes' + in case () of + _ | second < '\x80' || '\xBF' < second -> error "UTF-8 triple byte char has invalid second byte" + | third < '\x80' || '\xBF' < third -> error "UTF-8 triple byte char has invalid third byte" + | otherwise -> (offset .+ 3, combineThreeUTF8 first second third):(undoUTF8 rest $ offset .+ 3) + +-- | @combineThreeUTF8 first second@ combines the /first/, /second/ and /third/ +-- bytes of a three-byte UTF-8 char into a single Unicode char. +combineThreeUTF8 :: Char -> Char -> Char -> Char +combineThreeUTF8 first second third = chr(((ord first) .- 0xE0) .* 4096 + .+ ((ord second) .- 0x80) .* 64 + .+ ((ord third) .- 0x80)) + +-- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character, +-- where the /first/ byte is already available and the second, third and fourth +-- are the head of the /bytes/, and then continues to undo the UTF-8 encoding. +decodeFourUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] +decodeFourUTF8 first offset bytes + | hasFewerThan 3 bytes = error "UTF-8 quad byte char is missing bytes at eof" + | otherwise = let second = BLC.head bytes + bytes' = BLC.tail bytes + third = BLC.head bytes' + bytes'' = BLC.tail bytes' + fourth = BLC.head bytes'' + rest = BLC.tail bytes'' + in case () of + _ | second < '\x80' || '\xBF' < second -> error "UTF-8 quad byte char has invalid second byte" + | third < '\x80' || '\xBF' < third -> error "UTF-8 quad byte char has invalid third byte" + | third < '\x80' || '\xBF' < third -> error "UTF-8 quad byte char has invalid fourth byte" + | otherwise -> (offset .+ 4, combineFourUTF8 first second third fourth):(undoUTF8 rest $ offset .+ 4) + +-- | @combineFourUTF8 first second@ combines the /first/, /second/ and /third/ +-- bytes of a three-byte UTF-8 char into a single Unicode char. +combineFourUTF8 :: Char -> Char -> Char -> Char -> Char +combineFourUTF8 first second third fourth = chr(((ord first) .- 0xF0) .* 262144 + .+ ((ord second) .- 0x80) .* 4096 + .+ ((ord third) .- 0x80) .* 64 + .+ ((ord fourth) .- 0x80)) + +-- * Result tokens +-- +-- The parsing result is a stream of tokens rather than a parse tree. The idea +-- is to convert the YAML input into \"byte codes\". These byte codes are +-- intended to be written into a byte codes file (or more likely a UNIX pipe) +-- for further processing. + +-- | 'Token' codes. +data Code = Bom -- ^ BOM, contains \"@TF8@\", \"@TF16LE@\", \"@TF32BE@\", etc. + | Text -- ^ Content text characters. + | Meta -- ^ Non-content (meta) text characters. + | Break -- ^ Separation line break. + | LineFeed -- ^ Line break normalized to content line feed. + | LineFold -- ^ Line break folded to content space. + | Indicator -- ^ Character indicating structure. + | White -- ^ Separation white space. + | Indent -- ^ Indentation spaces. + | DirectivesEnd -- ^ Document start marker. + | DocumentEnd -- ^ Document end marker. + | BeginEscape -- ^ Begins escape sequence. + | EndEscape -- ^ Ends escape sequence. + | BeginComment -- ^ Begins comment. + | EndComment -- ^ Ends comment. + | BeginDirective -- ^ Begins directive. + | EndDirective -- ^ Ends directive. + | BeginTag -- ^ Begins tag. + | EndTag -- ^ Ends tag. + | BeginHandle -- ^ Begins tag handle. + | EndHandle -- ^ Ends tag handle. + | BeginAnchor -- ^ Begins anchor. + | EndAnchor -- ^ Ends anchor. + | BeginProperties -- ^ Begins node properties. + | EndProperties -- ^ Ends node properties. + | BeginAlias -- ^ Begins alias. + | EndAlias -- ^ Ends alias. + | BeginScalar -- ^ Begins scalar content. + | EndScalar -- ^ Ends scalar content. + | BeginSequence -- ^ Begins sequence content. + | EndSequence -- ^ Ends sequence content. + | BeginMapping -- ^ Begins mapping content. + | EndMapping -- ^ Ends mapping content. + | BeginPair -- ^ Begins mapping key:value pair. + | EndPair -- ^ Ends mapping key:value pair. + | BeginNode -- ^ Begins complete node. + | EndNode -- ^ Ends complete node. + | BeginDocument -- ^ Begins document. + | EndDocument -- ^ Ends document. + | BeginStream -- ^ Begins YAML stream. + | EndStream -- ^ Ends YAML stream. + | Error -- ^ Parsing error at this point. + | Unparsed -- ^ Unparsed due to errors (or at end of test). + | Detected -- ^ Detected parameter (for testing). + deriving (Show,Eq) + +{- +-- | @show code@ converts a 'Code' to the one-character YEAST token code char. +-- The list of byte codes is also documented in the @yaml2yeast@ program. +instance Show Code where + show code = case code of + Bom -> "U" + Text -> "T" + Meta -> "t" + Break -> "b" + LineFeed -> "L" + LineFold -> "l" + Indicator -> "I" + White -> "w" + Indent -> "i" + DirectivesEnd -> "K" + DocumentEnd -> "k" + BeginEscape -> "E" + EndEscape -> "e" + BeginComment -> "C" + EndComment -> "c" + BeginDirective -> "D" + EndDirective -> "d" + BeginTag -> "G" + EndTag -> "g" + BeginHandle -> "H" + EndHandle -> "h" + BeginAnchor -> "A" + EndAnchor -> "a" + BeginProperties -> "P" + EndProperties -> "p" + BeginAlias -> "R" + EndAlias -> "r" + BeginScalar -> "S" + EndScalar -> "s" + BeginSequence -> "Q" + EndSequence -> "q" + BeginMapping -> "M" + EndMapping -> "m" + BeginNode -> "N" + EndNode -> "n" + BeginPair -> "X" + EndPair -> "x" + BeginDocument -> "O" + EndDocument -> "o" + Error -> "!" + Unparsed -> "-" + Detected -> "$" +-} + +-- | Parsed token. +data Token = Token { + tByteOffset :: Int, -- ^ 0-base byte offset in stream. + tCharOffset :: Int, -- ^ 0-base character offset in stream. + tLine :: Int, -- ^ 1-based line number. + tLineChar :: Int, -- ^ 0-based character in line. + tCode :: Code, -- ^ Specific token 'Code'. + tText :: String -- ^ Contained input chars, if any. + } deriving Show + + +-- * Parsing framework +-- +-- Haskell has no shortage of parsing frameworks. We use our own because: +-- +-- * Most available frameworks are inappropriate because of their focus on +-- building a parse tree, and completing all of it before any of it is +-- accessible to the caller. We return a stream of tokens, and would like +-- its head to be accessible as soon as possible to allow for streaming. To +-- do this with bounded memory usage we use a combination of continuation +-- passing style and difference lists for the collected tokens. +-- +-- * Haskell makes it so easy to roll your own parsing framework. We need some +-- specialized machinery (limited lookahead, forbidden patterns). It is +-- possible to build these on top of existing frameworks but the end result +-- isn't much shorter than rolling our own. +-- +-- Since we roll our own framework we don't bother with making it generalized, +-- so we maintain a single 'State' type rather than having a generic one that +-- contains a polymorphic \"UserState\" field etc. + +-- | A 'Parser' is basically a function computing a 'Reply'. +data Parser result = Parser (State -> Reply result) + +-- | The 'Result' of each invocation is either an error, the actual result, or +-- a continuation for computing the actual result. +data Result result = Failed String -- ^ Parsing aborted with a failure. + | Result result -- ^ Parsing completed with a result. + | More (Parser result) -- ^ Parsing is ongoing with a continuation. + +-- Showing a 'Result' is only used in debugging. +instance (Show result) => Show (Result result) where + show result = case result of + Failed message -> "Failed " ++ message + Result result -> "Result " ++ (show result) + More _ -> "More" + +-- | Each invication of a 'Parser' yields a 'Reply'. The 'Result' is only one +-- part of the 'Reply'. +data Reply result = Reply { + rResult :: !(Result result), -- ^ Parsing result. + rTokens :: !(D.DList Token), -- ^ Tokens generated by the parser. + rCommit :: !(Maybe String), -- ^ Commitment to a decision point. + rState :: !State -- ^ The updated parser state. + } + +-- Showing a 'State' is only used in debugging. +instance (Show result) => Show (Reply result) where + show reply = "Result: " ++ (show $ reply|>rResult) + ++ ", Tokens: " ++ (show $ D.toList $ reply|>rTokens) + ++ ", Commit: " ++ (show $ reply|>rCommit) + ++ ", State: { " ++ (show $ reply|>rState) ++ "}" + +-- A 'Pattern' is a parser that doesn't have an (interesting) result. +type Pattern = Parser () + +-- ** Parsing state + +-- | The internal parser state. We don't bother with parameterising it with a +-- \"UserState\", we just bundle the generic and specific fields together (not +-- that it is that easy to draw the line - is @sLine@ generic or specific?). +data State = State { + sEncoding :: !Encoding, -- ^ The input UTF encoding. + sDecision :: !String, -- ^ Current decision name. + sLimit :: !Int, -- ^ Lookahead characters limit. + sForbidden :: !(Maybe Pattern), -- ^ Pattern we must not enter into. + sIsPeek :: !Bool, -- ^ Disables token generation. + sIsSol :: !Bool, -- ^ Is at start of line? + sChars :: ![Char], -- ^ (Reversed) characters collected for a token. + sCharsByteOffset :: !Int, -- ^ Byte offset of first collected character. + sCharsCharOffset :: !Int, -- ^ Char offset of first collected character. + sCharsLine :: !Int, -- ^ Line of first collected character. + sCharsLineChar :: !Int, -- ^ Character in line of first collected character. + sByteOffset :: !Int, -- ^ Offset in bytes in the input. + sCharOffset :: !Int, -- ^ Offset in characters in the input. + sLine :: !Int, -- ^ Builds on YAML's line break definition. + sLineChar :: !Int, -- ^ Character number in line. + sCode :: !Code, -- ^ Of token we are collecting chars for. + sLast :: !Char, -- ^ Last matched character. + sInput :: ![(Int, Char)] -- ^ The decoded input characters. + } + +-- Showing a 'State' is only used in debugging. Note that forcing dump of +-- @sInput@ will disable streaming it. +instance Show State where + show state = "Encoding: " ++ (show $ state|>sEncoding) + ++ ", Decision: " ++ (show $ state|>sDecision) + ++ ", Limit: " ++ (show $ state|>sLimit) + ++ ", IsPeek: " ++ (show $ state|>sIsPeek) + ++ ", IsSol: " ++ (show $ state|>sIsSol) + ++ ", Chars: >>>" ++ (reverse $ state|>sChars) ++ "<<<" + ++ ", CharsByteOffset: " ++ (show $ state|>sCharsByteOffset) + ++ ", CharsCharOffset: " ++ (show $ state|>sCharsCharOffset) + ++ ", CharsLine: " ++ (show $ state|>sCharsLine) + ++ ", CharsLineChar: " ++ (show $ state|>sCharsLineChar) + ++ ", ByteOffset: " ++ (show $ state|>sByteOffset) + ++ ", CharOffset: " ++ (show $ state|>sCharOffset) + ++ ", Line: " ++ (show $ state|>sLine) + ++ ", LineChar: " ++ (show $ state|>sLineChar) + ++ ", Code: " ++ (show $ state|>sCode) + ++ ", Last: " ++ (show $ state|>sLast) +-- ++ ", Input: >>>" ++ (show $ state|>sInput) ++ "<<<" + +-- | @initialState name input@ returns an initial 'State' for parsing the +-- /input/ (with /name/ for error messages). +initialState :: BLC.ByteString -> State +initialState input + = State { sEncoding = encoding + , sDecision = "" + , sLimit = -1 + , sForbidden = Nothing + , sIsPeek = False + , sIsSol = True + , sChars = [] + , sCharsByteOffset = -1 + , sCharsCharOffset = -1 + , sCharsLine = -1 + , sCharsLineChar = -1 + , sByteOffset = 0 + , sCharOffset = 0 + , sLine = 1 + , sLineChar = 0 + , sCode = Unparsed + , sLast = ' ' + , sInput = decoded + } + where + (encoding, decoded) = decode input + +-- *** Setters +-- +-- We need four setter functions to pass them around as arguments. For some +-- reason, Haskell only generates getter functions. + +-- | @setLimit limit state@ sets the @sLimit@ field to /limit/. +setLimit :: Int -> State -> State +setLimit limit state = state { sLimit = limit } + +-- | @setForbidden forbidden state@ sets the @sForbidden@ field to /forbidden/. +setForbidden :: Maybe Pattern -> State -> State +setForbidden forbidden state = state { sForbidden = forbidden } + +-- | @setCode code state@ sets the @sCode@ field to /code/. +setCode :: Code -> State -> State +setCode code state = state { sCode = code } + +-- ** Implicit parsers +-- +-- It is tedious to have to wrap each expected character (or character range) +-- in an explicit 'Parse' constructor. We let Haskell do that for us using a +-- 'Match' class. + +-- | @Match parameter result@ specifies that we can convert the /parameter/ to +-- a 'Parser' returning the /result/. +class Match parameter result | parameter -> result where + match :: parameter -> Parser result + +-- | We don't need to convert a 'Parser', it already is one. +instance Match (Parser result) result where + match = id + +-- | We convert 'Char' to a parser for a character (that returns nothing). +instance Match Char () where + match code = nextIf (== code) + +-- | We convert a 'Char' tuple to a parser for a character range (that returns +-- nothing). +instance Match (Char, Char) () where + match (low, high) = nextIf $ \ code -> low <= code && code <= high + +-- | We convert 'String' to a parser for a sequence of characters (that returns +-- nothing). +instance Match String () where + match = foldr (&) empty + +-- ** Reply constructors + +-- | @returnReply state result@ prepares a 'Reply' with the specified /state/ +-- and /result/. +returnReply :: State -> result -> Reply result +returnReply state result = Reply { rResult = Result result, + rTokens = D.empty, + rCommit = Nothing, + rState = state } + +-- | @tokenReply state token@ returns a 'Reply' containing the /state/ and +-- /token/. Any collected characters are cleared (either there are none, or we +-- put them in this token, or we don't want them). +tokenReply :: State -> Token -> Reply () +tokenReply state token = Reply { rResult = Result (), + rTokens = D.singleton token, + rCommit = Nothing, + rState = state { sCharsByteOffset = -1, + sCharsCharOffset = -1, + sCharsLine = -1, + sCharsLineChar = -1, + sChars = [] } } + +-- | @failReply state message@ prepares a 'Reply' with the specified /state/ +-- and error /message/. +failReply :: State -> String -> Reply result +failReply state message = Reply { rResult = Failed message, + rTokens = D.empty, + rCommit = Nothing, + rState = state } + +-- | @unexpectedReply state@ returns a @failReply@ for an unexpected character. +unexpectedReply :: State -> Reply result +unexpectedReply state = case state|>sInput of + ((_, char):_) -> failReply state $ "Unexpected '" ++ [char] ++ "'" + [] -> failReply state "Unexpected end of input" + + +instance Functor Parser where + fmap = liftM + +instance Applicative Parser where + pure = return + (<*>) = ap + +-- | Allow using the @do@ notation for our parsers, which makes for short and +-- sweet @do@ syntax when we want to examine the results (we typically don't). +instance Monad Parser where + + -- @return result@ does just that - return a /result/. + return result = Parser $ \ state -> returnReply state result + + -- @left >>= right@ applies the /left/ parser, and if it didn't fail + -- applies the /right/ one (well, the one /right/ returns). + left >>= right = bindParser left right + where bindParser (Parser left) right = Parser $ \ state -> + let reply = left state + in case reply|>rResult of + Failed message -> reply { rResult = Failed message } + Result value -> reply { rResult = More $ right value } + More parser -> reply { rResult = More $ bindParser parser right } + + -- @fail message@ does just that - fails with a /message/. + fail message = Parser $ \ state -> failReply state message + +-- ** Parsing operators +-- +-- Here we reap the benefits of renaming the numerical operators. The Operator +-- precedence, in decreasing strength: +-- +-- @repeated % n@, @repeated <% n@, @match - rejected@, @match ! decision@, +-- @match ?! decision@, @choice ^ (first \/ second)@. +-- +-- @match - first - second@ is @(match - first) - second@. +-- +-- @first & second & third@ is @first & (second & third)@. Note that @first - +-- rejected & second@ is @(first - rejected) & second@, etc. +-- +-- @match \/ alternative \/ otherwise@ is @match \/ (alternative \/ +-- otherwise)@. Note that @first & second \/ third@ is @(first & second) \/ +-- third@. +-- +-- @( match *)@, @(match +)@, @(match ?)@, @(match ?)@, @(match +-- >!)@, @(match ? +infix 0 >! + +-- | @parser % n@ repeats /parser/ exactly /n/ times. +(%) :: (Match match result) => match -> Int -> Pattern +parser % n + | n <= 0 = empty + | n > 0 = parser & parser % n .- 1 + +-- | @parser <% n@ matches fewer than /n/ occurrences of /parser/. +(<%) :: (Match match result) => match -> Int -> Pattern +parser <% n + | n < 1 = fail "Fewer than 0 repetitions" + | n == 1 = reject parser Nothing + | n > 1 = "<%" ^ ( parser ! "<%" & parser <% n .- 1 / empty ) + +-- | @decision ^ (option \/ option \/ ...)@ provides a /decision/ name to the +-- choice about to be made, to allow to @commit@ to it. +(^) :: (Match match result) => String -> match -> Parser result +decision ^ parser = choice decision $ match parser + +-- | @parser ! decision@ commits to /decision/ (in an option) after +-- successfully matching the /parser/. +(!) :: (Match match result) => match -> String -> Pattern +parser ! decision = parser & commit decision + +-- | @parser ?! decision@ commits to /decision/ (in an option) if the current +-- position matches /parser/, without consuming any characters. +(?!) :: (Match match result) => match -> String -> Pattern +parser ?! decision = peek parser & commit decision + +-- | @lookbehind match -> Parser result +(?@ matches the current point without consuming any characters +-- if it matches the lookahead parser (positive lookahead) +(>?) :: (Match match result) => match -> Parser result +(>?) lookahead = peek lookahead + +-- | @lookahead >?@ matches the current point without consuming any characters +-- if it matches the lookahead parser (negative lookahead) +(>!) :: (Match match result) => match -> Pattern +(>!) lookahead = reject lookahead Nothing + +-- | @parser - rejected@ matches /parser/, except if /rejected/ matches at this +-- point. +(-) :: (Match match1 result1, Match match2 result2) => match1 -> match2 -> Parser result1 +parser - rejected = reject rejected Nothing & parser + +-- | @before & after@ parses /before/ and, if it succeeds, parses /after/. This +-- basically invokes the monad's @>>=@ (bind) method. +(&) :: (Match match1 result1, Match match2 result2) => match1 -> match2 -> Parser result2 +before & after = (match before) >> (match after) + +-- | @first \/ second@ tries to parse /first/, and failing that parses +-- /second/, unless /first/ has committed in which case is fails immediately. +(/) :: (Match match1 result, Match match2 result) => match1 -> match2 -> Parser result +first / second = Parser $ \ state -> + let Parser parser = decide (match first) (match second) + in parser state + +-- | @(optional ?)@ tries to match /parser/, otherwise does nothing. +(?) :: (Match match result) => match -> Pattern +(?) optional = (optional & empty) / empty + +-- | @(parser *)@ matches zero or more occurrences of /repeat/, as long as each +-- one actually consumes input characters. +(*) :: (Match match result) => match -> Pattern +(*) parser = "*" ^ zomParser + where zomParser = (parser ! "*" & zomParser) / empty + +-- | @(parser +)@ matches one or more occurrences of /parser/, as long as each +-- one actually consumed input characters. +(+) :: (Match match result) => match -> Pattern +(+) parser = parser & (parser *) + +-- ** Basic parsers + +-- | @decide first second@ tries to parse /first/, and failing that parses +-- /second/, unless /first/ has committed in which case is fails immediately. +decide :: Parser result -> Parser result -> Parser result +decide left right = Parser $ \ state -> + let Parser parser = decideParser state D.empty left right + in parser state + where decideParser point tokens (Parser left) right = Parser $ \state -> + let reply = left state + tokens' reply = D.append tokens $ reply|>rTokens + in case (reply|>rResult, reply|>rCommit) of + (Failed _, _) -> Reply { rState = point, + rTokens = D.empty, + rResult = More right, + rCommit = Nothing } + (Result _, _) -> reply { rTokens = tokens' reply } + (More left', Just _) -> reply { rTokens = tokens' reply, + rResult = More left' } + (More left', Nothing) -> let Parser parser = decideParser point (tokens' reply) left' right + in parser $ reply|>rState + +-- | @choice decision parser@ provides a /decision/ name to the choice about to +-- be made in /parser/, to allow to @commit@ to it. +choice :: String -> Parser result -> Parser result +choice decision parser = Parser $ \ state -> + let Parser parser' = choiceParser (state|>sDecision) decision parser + in parser' state { sDecision = decision } + where choiceParser parentDecision makingDecision (Parser parser) = Parser $ \ state -> + let reply = parser state + commit' = case reply|>rCommit of + Nothing -> Nothing + Just decision | decision == makingDecision -> Nothing + | otherwise -> reply|>rCommit + reply' = case reply|>rResult of + More parser' -> reply { rCommit = commit', + rResult = More $ choiceParser parentDecision makingDecision parser' } + _ -> reply { rCommit = commit', + rState = (reply|>rState) { sDecision = parentDecision } } + in reply' + +-- | @parser ``recovery`` pattern@ parses the specified /parser/; if it fails, +-- it continues to the /recovery/ parser to recover. +recovery :: (Match match1 result, Match match2 result) => match1 -> match2 -> Parser result +recovery pattern recover = + Parser $ \ state -> + let (Parser parser) = match pattern + reply = parser state + in if state|>sIsPeek + then reply + else case reply|>rResult of + Result _ -> reply + More more -> reply { rResult = More $ more `recovery` recover } + Failed message -> reply { rResult = More $ fake Error message & unparsed & recover } + where unparsed = let (Parser parser) = match finishToken + in Parser $ \ state -> parser $ state { sCode = Unparsed } + +-- | @prev parser@ succeeds if /parser/ matches at the previous character. It +-- does not consume any input. +prev :: (Match match result) => match -> Parser result +prev parser = Parser $ \ state -> + prevParser state (match parser) state { sIsPeek = True, sInput = (-1, state|>sLast) : state|>sInput } + where prevParser point (Parser parser) state = + let reply = parser state + in case reply|>rResult of + Failed message -> failReply point message + Result value -> returnReply point value + More parser' -> prevParser point parser' $ reply|>rState + +-- | @peek parser@ succeeds if /parser/ matches at this point, but does not +-- consume any input. +peek :: (Match match result) => match -> Parser result +peek parser = Parser $ \ state -> + peekParser state (match parser) state { sIsPeek = True } + where peekParser point (Parser parser) state = + let reply = parser state + in case reply|>rResult of + Failed message -> failReply point message + Result value -> returnReply point value + More parser' -> peekParser point parser' $ reply|>rState + +-- | @reject parser name@ fails if /parser/ matches at this point, and does +-- nothing otherwise. If /name/ is provided, it is used in the error message, +-- otherwise the messages uses the current character. +reject :: (Match match result) => match -> Maybe String -> Pattern +reject parser name = Parser $ \ state -> + rejectParser state name (match parser) state { sIsPeek = True } + where rejectParser point name (Parser parser) state = + let reply = parser state + in case reply|>rResult of + Failed _message -> returnReply point () + Result _value -> case name of + Nothing -> unexpectedReply point + Just text -> failReply point $ "Unexpected " ++ text + More parser' -> rejectParser point name parser' $ reply|>rState + +-- | @upto parser@ consumes all the character up to and not including the next +-- point where the specified parser is a match. +upto :: Pattern -> Pattern + +upto parser = ( ( parser >!) & nextIf (const True) *) + +-- | @nonEmpty parser@ succeeds if /parser/ matches some non-empty input +-- characters at this point. +nonEmpty :: (Match match result) => match -> Parser result +nonEmpty parser = Parser $ \ state -> + let Parser parser' = nonEmptyParser (state|>sCharOffset) (match parser) + in parser' state + where nonEmptyParser offset (Parser parser) = Parser $ \ state -> + let reply = parser state + state' = reply|>rState + in case reply|>rResult of + Failed _message -> reply + Result _value -> if state'|>sCharOffset > offset + then reply + else failReply state' "Matched empty pattern" + More parser' -> reply { rResult = More $ nonEmptyParser offset parser' } + +-- | @empty@ always matches without consuming any input. +empty :: Pattern +empty = return () + +-- | @eof@ matches the end of the input. +eof :: Pattern +eof = Parser $ \ state -> + if state|>sInput == [] + then returnReply state () + else unexpectedReply state + +-- | @sol@ matches the start of a line. +sol :: Pattern +sol = Parser $ \ state -> + if state|>sIsSol + then returnReply state () + else failReply state "Expected start of line" + +-- ** State manipulation pseudo-parsers + +-- | @commit decision@ commits the parser to all the decisions up to the most +-- recent parent /decision/. This makes all tokens generated in this parsing +-- path immediately available to the caller. +commit :: String -> Pattern +commit decision = Parser $ \ state -> + Reply { rState = state, + rTokens = D.empty, + rResult = Result (), + rCommit = Just decision } + +-- | @nextLine@ increments @sLine@ counter and resets @sLineChar@. +nextLine :: Pattern +nextLine = Parser $ \ state -> + returnReply state { sIsSol = True, + sLine = state|>sLine .+ 1, + sLineChar = 0 } + () + +-- | @with setField getField value parser@ invokes the specified /parser/ with +-- the value of the specified field set to /value/ for the duration of the +-- invocation, using the /setField/ and /getField/ functions to manipulate it. +with :: (value -> State -> State) -> (State -> value) -> value -> Parser result -> Parser result +with setField getField value parser = Parser $ \ state -> + let value' = getField state + Parser parser' = value' `seq` withParser value' parser + in parser' $ setField value state + where withParser parentValue (Parser parser) = Parser $ \ state -> + let reply = parser state + in case reply|>rResult of + Failed _ -> reply { rState = setField parentValue $ reply|>rState } + Result _ -> reply { rState = setField parentValue $ reply|>rState } + More parser' -> reply { rResult = More $ withParser parentValue parser' } + +-- | @parser ``forbidding`` pattern@ parses the specified /parser/ ensuring +-- that it does not contain anything matching the /forbidden/ parser. +forbidding :: (Match match1 result1, Match match2 result2) => match1 -> match2 -> Parser result1 +forbidding parser forbidden = with setForbidden sForbidden (Just $ forbidden & empty) (match parser) + +-- | @parser ``limitedTo`` limit@ parses the specified /parser/ +-- ensuring that it does not consume more than the /limit/ input chars. +limitedTo :: (Match match result) => match -> Int -> Parser result +limitedTo parser limit = with setLimit sLimit limit (match parser) + +-- ** Consuming input characters + +-- | @nextIf test@ fails if the current position matches the 'State' forbidden +-- pattern or if the 'State' lookahead limit is reached. Otherwise it consumes +-- (and buffers) the next input char if it satisfies /test/. +nextIf :: (Char -> Bool) -> Pattern +nextIf test = Parser $ \ state -> + case state|>sForbidden of + Nothing -> limitedNextIf state + Just parser -> let Parser parser' = reject parser $ Just "forbidden pattern" + reply = parser' state { sForbidden = Nothing } + in case reply|>rResult of + Failed _ -> reply + Result _ -> limitedNextIf state + where limitedNextIf state = + case state|>sLimit of + -1 -> consumeNextIf state + 0 -> failReply state "Lookahead limit reached" + _limit -> consumeNextIf state { sLimit = state|>sLimit .- 1 } + consumeNextIf state = + case state|>sInput of + ((offset, char):rest) | test char -> let chars = if state|>sIsPeek + then [] + else char:(state|>sChars) + byte_offset = charsOf sByteOffset sCharsByteOffset + char_offset = charsOf sCharOffset sCharsCharOffset + line = charsOf sLine sCharsLine + line_char = charsOf sLineChar sCharsLineChar + is_sol = if char == '\xFEFF' + then state|>sIsSol + else False + state' = state { sInput = rest, + sLast = char, + sChars = chars, + sCharsByteOffset = byte_offset, + sCharsCharOffset = char_offset, + sCharsLine = line, + sCharsLineChar = line_char, + sIsSol = is_sol, + sByteOffset = offset, + sCharOffset = state|>sCharOffset .+ 1, + sLineChar = state|>sLineChar .+ 1 } + in returnReply state' () + | otherwise -> unexpectedReply state + [] -> unexpectedReply state + where charsOf field charsField = if state|>sIsPeek + then -1 + else if state|>sChars == [] + then state|>field + else state|>charsField + +-- ** Producing tokens + +-- | @finishToken@ places all collected text into a new token and begins a new +-- one, or does nothing if there are no collected characters. +finishToken :: Pattern +finishToken = Parser $ \ state -> + let state' = state { sChars = [], + sCharsByteOffset = -1, + sCharsCharOffset = -1, + sCharsLine = -1, + sCharsLineChar = -1 } + in if state|>sIsPeek + then returnReply state' () + else case state|>sChars of + [] -> returnReply state' () + chars@(_:_) -> tokenReply state' Token { tByteOffset = state|>sCharsByteOffset, + tCharOffset = state|>sCharsCharOffset, + tLine = state|>sCharsLine, + tLineChar = state|>sCharsLineChar, + tCode = state|>sCode, + tText = reverse chars } + +-- | @wrap parser@ invokes the /parser/, ensures any unclaimed input characters +-- are wrapped into a token (only happens when testing productions), ensures no +-- input is left unparsed, and returns the parser's result. +wrap :: (Match match result) => match -> Parser result +wrap parser = do result <- match parser + finishToken + eof + return result + +-- | @token code parser@ places all text matched by /parser/ into a 'Token' with +-- the specified /code/ (unless it is empty). Note it collects the text even if +-- there is an error. +token :: (Match match result) => Code -> match -> Pattern +token code parser = finishToken & with setCode sCode code (parser & finishToken) + +-- | @fake code text@ creates a token with the specified /code/ and \"fake\" +-- /text/ characters, instead of whatever characters are collected so far. +fake :: Code -> String -> Pattern +fake code text = Parser $ \ state -> + if state|>sIsPeek + then returnReply state () + else tokenReply state Token { tByteOffset = value state sByteOffset sCharsByteOffset, + tCharOffset = value state sCharOffset sCharsCharOffset, + tLine = value state sLine sCharsLine, + tLineChar = value state sLineChar sCharsLineChar, + tCode = code, + tText = text } + where value state field1 field2 = + if field2 state == -1 + then field1 state + else field2 state + +-- | @meta parser@ collects the text matched by the specified /parser/ into a +-- | @Meta@ token. +meta :: (Match match result) => match -> Pattern +meta parser = token Meta parser + +-- | @indicator code@ collects the text matched by the specified /parser/ into an +-- @Indicator@ token. +indicator :: (Match match result) => match -> Pattern +indicator parser = token Indicator $ parser + +-- | @text parser@ collects the text matched by the specified /parser/ into a +-- @Text@ token. +text :: (Match match result) => match -> Pattern +text parser = token Text parser + +-- | @emptyToken code@ returns an empty token. +emptyToken :: Code -> Pattern +emptyToken code = finishToken & parser code + where parser code = Parser $ \ state -> + if state|>sIsPeek + then returnReply state () + else tokenReply state Token { tByteOffset = state|>sByteOffset, + tCharOffset = state|>sCharOffset, + tLine = state|>sLine, + tLineChar = state|>sLineChar, + tCode = code, + tText = "" } + +-- | @wrapTokens beginCode endCode parser@ wraps the specified /parser/ with +-- matching /beginCode/ and /endCode/ tokens. +wrapTokens :: Code -> Code -> Pattern -> Pattern +wrapTokens beginCode endCode pattern = emptyToken beginCode + & prefixErrorWith pattern (emptyToken endCode) + & emptyToken endCode + +-- | @prefixErrorWith pattern prefix@ will invoke the @prefix@ parser if an +-- error is detected during the @pattern@ parser, and then return the error. +prefixErrorWith :: (Match match result) => match -> Pattern -> Parser result +prefixErrorWith pattern prefix = + Parser $ \ state -> + let (Parser parser) = match pattern + reply = parser state + in case reply|>rResult of + Result _ -> reply + More more -> reply { rResult = More $ prefixErrorWith more prefix } + Failed message -> reply { rResult = More $ prefix & (fail message :: Parser result) } + +-- * Production parameters + +-- | Production context. +data Context = BlockOut -- ^ Outside block sequence. + | BlockIn -- ^ Inside block sequence. + | FlowOut -- ^ Outside flow collection. + | FlowIn -- ^ Inside flow collection. + | BlockKey -- ^ Implicit block key. + | FlowKey -- ^ Implicit flow key. + +-- | @show context@ converts a 'Context' to a 'String'. +instance Show Context where + show context = case context of + BlockOut -> "block-out" + BlockIn -> "block-in" + FlowOut -> "flow-out" + FlowIn -> "flow-in" + BlockKey -> "block-key" + FlowKey -> "flow-key" + +-- | @read context@ converts a 'String' to a 'Context'. We trust our callers to +-- convert any @-@ characters into @_@ to allow the built-in @lex@ function to +-- handle the names as single identifiers. +instance Read Context where + readsPrec _ text = [ ((r word), tail) | (word, tail) <- lex text ] + where r word = case word of + "block_out" -> BlockOut + "block_in" -> BlockIn + "flow_out" -> FlowOut + "flow_in" -> FlowIn + "block_key" -> BlockKey + "flow_key" -> FlowKey + _ -> error $ "unknown context: " ++ word + +-- | Chomp method. +data Chomp = Strip -- ^ Remove all trailing line breaks. + | Clip -- ^ Keep first trailing line break. + | Keep -- ^ Keep all trailing line breaks. + +-- | @show chomp@ converts a 'Chomp' to a 'String'. +instance Show Chomp where + show chomp = case chomp of + Strip -> "strip" + Clip -> "clip" + Keep -> "keep" + +-- | @read chomp@ converts a 'String' to a 'Chomp'. +instance Read Chomp where + readsPrec _ text = [ ((r word), tail) | (word, tail) <- lex text ] + where r word = case word of + "strip" -> Strip + "clip" -> Clip + "keep" -> Keep + _ -> error $ "unknown chomp: " ++ word + +-- * Tokenizers +-- +-- We encapsulate the 'Parser' inside a 'Tokenizer'. This allows us to hide the +-- implementation details from our callers. + +-- | 'Tokenizer' converts a input text into a list of 'Token'. Errors +-- are reported as tokens with the @Error@ 'Code', and the unparsed text +-- following an error may be attached as a final token (if the @Bool@ is +-- @True@). Note that tokens are available \"immediately\", allowing for +-- streaming of large YAML files with memory requirements depending only on the +-- YAML nesting level. +type Tokenizer = BLC.ByteString -> Bool -> [Token] + +-- | @patternTokenizer pattern@ converts the /pattern/ to a simple 'Tokenizer'. +patternTokenizer :: Pattern -> Tokenizer +patternTokenizer pattern input withFollowing = + D.toList $ patternParser (wrap pattern) (initialState input) + where patternParser (Parser parser) state = + let reply = parser state + tokens = commitBugs reply + state' = reply|>rState + in case reply|>rResult of + Failed message -> errorTokens tokens state' message withFollowing + Result _ -> tokens + More parser' -> D.append tokens $ patternParser parser' state' + +-- | @errorTokens tokens state message withFollowing@ appends an @Error@ token +-- with the specified /message/ at the end of /tokens/, and if /withFollowing/ +-- also appends the unparsed text following the error as a final @Unparsed@ +-- token. +errorTokens :: D.DList Token -> State -> String -> Bool -> D.DList Token +errorTokens tokens state message withFollowing = + let tokens' = D.append tokens $ D.singleton Token { tByteOffset = state|>sByteOffset, + tCharOffset = state|>sCharOffset, + tLine = state|>sLine, + tLineChar = state|>sLineChar, + tCode = Error, + tText = message } + in if withFollowing && state|>sInput /= [] + then D.append tokens' $ D.singleton Token { tByteOffset = state|>sByteOffset, + tCharOffset = state|>sCharOffset, + tLine = state|>sLine, + tLineChar = state|>sLineChar, + tCode = Unparsed, + tText = map snd $ state|>sInput } + else tokens' + +-- | @commitBugs reply@ inserts an error token if a commit was made outside a +-- named choice. This should never happen outside tests. +commitBugs :: Reply result -> D.DList Token +commitBugs reply = + let tokens = reply|>rTokens + state = reply|>rState + in case reply|>rCommit of + Nothing -> tokens + Just commit -> D.append tokens $ D.singleton Token { tByteOffset = state|>sByteOffset, + tCharOffset = state|>sCharOffset, + tLine = state|>sLine, + tLineChar = state|>sLineChar, + tCode = Error, + tText = "Commit to '" ++ commit ++ "' was made outside it" } + +-- | @'tokenize' input emit_unparsed@ +-- converts the Unicode /input/ to a +-- list of 'Token' according to the YAML 1.2 specification. +-- +-- Errors are reported as tokens with @'Error' :: 'Code'@, and the +-- unparsed text following an error may be attached as a final 'Unparsed' token +-- (if the /emit_unparsed/ argument is @True@). Note that tokens are available +-- \"immediately\", allowing for streaming of large YAML files with +-- memory requirements depending only on the YAML nesting level. +tokenize :: BLC.ByteString -> Bool -> [Token] +tokenize = patternTokenizer l_yaml_stream + +-- * Productions + +-- ** BNF compatibility helpers + +-- | @detect_utf_encoding@ doesn't actually detect the encoding, we just call it +-- this way to make the productions compatible with the spec. Instead it simply +-- reports the encoding (which was already detected when we started parsing). +bom :: Match match1 result1 => match1 -> Parser () +bom code = code + & (Parser $ \ state -> let text = case state|>sEncoding of + UTF8 -> "TF-8" + UTF16LE -> "TF-16LE" + UTF16BE -> "TF-16BE" + UTF32LE -> "TF-32LE" + UTF32BE -> "TF-32BE" + Parser parser = fake Bom text + in parser state) + +-- | @na@ is the \"non-applicable\" indentation value. We use Haskell's laziness +-- to verify it really is never used. +na :: Int +na = error "Accessing non-applicable indentation" + +-- | @asInteger@ returns the last consumed character, which is assumed to be a +-- decimal digit, as an integer. +asInteger :: Parser Int +asInteger = Parser $ \ state -> returnReply state $ ord (state|>sLast) .- 48 + +-- | @result value@ is the same as /return value/ except that we give the +-- Haskell type deduction the additional boost it needs to figure out this is +-- wrapped in a 'Parser'. +result :: result -> Parser result +result = return + +---------------------------------------------------------------------------- + +-- ** Spec productions +-- +-- These are copied directly from the spec, with the sprinkling of +-- additional token and decision point directives. + +-- 5.1 Character Set + +c_printable {- 1 -} = '\x9' / '\xA' / '\xD' / ('\x20', '\x7E') + / '\x85' / ('\xA0', '\xD7FF') / ('\xE000', '\xFFFD') + / ('\x10000', '\x10FFFF') + +nb_json {- 2 -} = '\x9' / ('\x20', '\x10FFFF') + +-- 5.2 Character Encodings + +c_byte_order_mark {- 3 -} = bom '\xFEFF' + +-- 5.3 Indicator Characters + +c_sequence_entry {- 4 -} = indicator '-' +c_mapping_key {- 5 -} = indicator '?' +c_mapping_value {- 6 -} = indicator ':' + +c_collect_entry {- 7 -} = indicator ',' +c_sequence_start {- 8 -} = indicator '[' +c_sequence_end {- 9 -} = indicator ']' +c_mapping_start {- 10 -} = indicator '{' +c_mapping_end {- 11 -} = indicator '}' + +c_comment {- 12 -} = indicator '#' + +c_anchor {- 13 -} = indicator '&' +c_alias {- 14 -} = indicator '*' +c_tag {- 15 -} = indicator '!' + +c_literal {- 16 -} = indicator '|' +c_folded {- 17 -} = indicator '>' + +c_single_quote {- 18 -} = indicator '\'' +c_double_quote {- 19 -} = indicator '"' + +c_directive {- 20 -} = indicator '%' + +c_reserved {- 21 -} = indicator ( '@' / '`' ) + +c_indicator {- 22 -} = c_sequence_entry / c_mapping_key / c_mapping_value / c_collect_entry + / c_sequence_start / c_sequence_end / c_mapping_start / c_mapping_end + / c_comment / c_anchor / c_alias / c_tag + / c_literal / c_folded / c_single_quote / c_double_quote + / c_directive / c_reserved + +c_flow_indicator {- 23 -} = c_collect_entry / c_sequence_start / c_sequence_end / c_mapping_start / c_mapping_end + +-- 5.4 Line Break Characters + +b_line_feed {- 24 -} = '\xA' +b_carriage_return {- 25 -} = '\xD' +b_char {- 26 -} = b_line_feed / b_carriage_return + +nb_char {- 27 -} = c_printable - b_char - c_byte_order_mark + +b_break {- 28 -} = ( b_carriage_return & b_line_feed + / b_carriage_return + / b_line_feed ) + & nextLine + +b_as_line_feed {- 29 -} = token LineFeed b_break + +b_non_content {- 30 -} = token Break b_break + +-- 5.5 White Space Characters + +s_space {- 31 -} = '\x20' +s_tab {- 32 -} = '\x9' +s_white {- 33 -} = s_space / s_tab + +ns_char {- 34 -} = nb_char - s_white + +-- 5.6 Miscellaneous Characters + +ns_dec_digit {- 35 -} = ('\x30', '\x39') + +ns_hex_digit {- 36 -} = ns_dec_digit + / ('\x41', '\x46') / ('\x61', '\x66') + +ns_ascii_letter {- 37 -} = ('\x41', '\x5A') / ('\x61', '\x7A') + +ns_word_char {- 38 -} = ns_dec_digit / ns_ascii_letter / '-' + +ns_uri_char {- 39 -} = "escape" + ^ ( '%' ! "escape" & ns_hex_digit & ns_hex_digit / ns_word_char / '#' + / ';' / '/' / '?' / ':' / '@' / '&' / '=' / '+' / '$' / ',' + / '_' / '.' / '!' / '~' / '*' / '\'' / '(' / ')' / '[' / ']' ) + +ns_tag_char {- 40 -} = ns_uri_char - c_tag - c_flow_indicator + +-- 5.7 Escaped Characters + +c_escape {- 41 -} = indicator '\\' + +ns_esc_null {- 42 -} = meta '0' +ns_esc_bell {- 43 -} = meta 'a' +ns_esc_backspace {- 44 -} = meta 'b' +ns_esc_horizontal_tab {- 45 -} = meta ( 't' / '\x9' ) +ns_esc_line_feed {- 46 -} = meta 'n' +ns_esc_vertical_tab {- 47 -} = meta 'v' +ns_esc_form_feed {- 48 -} = meta 'f' +ns_esc_carriage_return {- 49 -} = meta 'r' +ns_esc_escape {- 50 -} = meta 'e' +ns_esc_space {- 51 -} = meta '\x20' +ns_esc_double_quote {- 52 -} = meta '"' +ns_esc_slash {- 53 -} = meta '/' +ns_esc_backslash {- 54 -} = meta '\\' +ns_esc_next_line {- 55 -} = meta 'N' +ns_esc_non_breaking_space {- 56 -} = meta '_' +ns_esc_line_separator {- 57 -} = meta 'L' +ns_esc_paragraph_separator {- 58 -} = meta 'P' +ns_esc_8_bit {- 59 -} = indicator 'x' ! "escaped" & meta ( ns_hex_digit % 2 ) +ns_esc_16_bit {- 60 -} = indicator 'u' ! "escaped" & meta ( ns_hex_digit % 4 ) +ns_esc_32_bit {- 61 -} = indicator 'U' ! "escaped" & meta ( ns_hex_digit % 8 ) + +c_ns_esc_char {- 62 -} = wrapTokens BeginEscape EndEscape + $ c_escape ! "escape" + & "escaped" + ^ ( ns_esc_null / ns_esc_bell / ns_esc_backspace + / ns_esc_horizontal_tab / ns_esc_line_feed + / ns_esc_vertical_tab / ns_esc_form_feed + / ns_esc_carriage_return / ns_esc_escape / ns_esc_space + / ns_esc_double_quote / ns_esc_slash / ns_esc_backslash + / ns_esc_next_line / ns_esc_non_breaking_space + / ns_esc_line_separator / ns_esc_paragraph_separator + / ns_esc_8_bit / ns_esc_16_bit / ns_esc_32_bit ) + +-- 6.1 Indentation Spaces + +s_indent n {- 63 -} = token Indent ( s_space % n ) + +s_indent_lt n {- 64 -} = token Indent ( s_space <% n ) +s_indent_le n {- 65 -} = token Indent ( s_space <% (n .+ 1) ) + +-- 6.2 Separation Spaces + +s_separate_in_line {- 66 -} = token White ( s_white +) / sol + +-- 6.3 Line Prefixes + +s_line_prefix n c {- 67 -} = case c of + BlockOut -> s_block_line_prefix n + BlockIn -> s_block_line_prefix n + FlowOut -> s_flow_line_prefix n + FlowIn -> s_flow_line_prefix n + +s_block_line_prefix n {- 68 -} = s_indent n +s_flow_line_prefix n {- 69 -} = s_indent n & ( s_separate_in_line ?) + +-- 6.4 Empty Lines + +l_empty n c {- 70 -} = ( s_line_prefix n c / s_indent_lt n ) + & b_as_line_feed + +-- 6.5 Line Folding + +b_l_trimmed n c {- 71 -} = b_non_content & ( l_empty n c +) + +b_as_space {- 72 -} = token LineFold b_break + +b_l_folded n c {- 73 -} = b_l_trimmed n c / b_as_space + +s_flow_folded n {- 74 -} = ( s_separate_in_line ?) & b_l_folded n FlowIn + & s_flow_line_prefix n + +-- 6.6 Comments + +c_nb_comment_text {- 75 -} = wrapTokens BeginComment EndComment + $ c_comment & meta ( nb_char *) + +b_comment {- 76 -} = b_non_content / eof + +s_b_comment {- 77 -} = ( s_separate_in_line & ( c_nb_comment_text ?) ?) + & b_comment + +l_comment {- 78 -} = s_separate_in_line & ( c_nb_comment_text ?) & b_comment + +s_l_comments {- 79 -} = ( s_b_comment / sol ) + & ( nonEmpty l_comment *) + +-- 6.7 Separation Lines + +s_separate n c {- 80 -} = case c of + BlockOut -> s_separate_lines n + BlockIn -> s_separate_lines n + FlowOut -> s_separate_lines n + FlowIn -> s_separate_lines n + BlockKey -> s_separate_in_line + FlowKey -> s_separate_in_line +s_separate_lines n {- 81 -} = s_l_comments & s_flow_line_prefix n + / s_separate_in_line + +-- 6.8 Directives + +l_directive {- 82 -} = ( wrapTokens BeginDirective EndDirective + $ c_directive ! "doc" + & "directive" + ^ ( ns_yaml_directive + / ns_tag_directive + / ns_reserved_directive ) ) + & s_l_comments + +ns_reserved_directive {- 83 -} = ns_directive_name + & ( s_separate_in_line & ns_directive_parameter *) +ns_directive_name {- 84 -} = meta ( ns_char +) +ns_directive_parameter {- 85 -} = meta ( ns_char +) + +-- 6.8.1 Yaml Directives + +ns_yaml_directive {- 86 -} = meta [ 'Y', 'A', 'M', 'L' ] ! "directive" + & s_separate_in_line & ns_yaml_version +ns_yaml_version {- 87 -} = meta ( ( ns_dec_digit +) & '.' & ( ns_dec_digit +) ) + +-- 6.8.2 Tag Directives + +ns_tag_directive {- 88 -} = meta [ 'T', 'A', 'G' ] ! "directive" + & s_separate_in_line & c_tag_handle + & s_separate_in_line & ns_tag_prefix + +-- 6.8.2.1 Tag Handles + +c_tag_handle {- 89 -} = c_named_tag_handle + / c_secondary_tag_handle + / c_primary_tag_handle + +c_primary_tag_handle {- 90 -} = wrapTokens BeginHandle EndHandle + $ c_tag + +c_secondary_tag_handle {- 91 -} = wrapTokens BeginHandle EndHandle + $ c_tag & c_tag + +c_named_tag_handle {- 92 -} = wrapTokens BeginHandle EndHandle + $ c_tag & meta ( ns_word_char +) & c_tag + +-- 6.8.2.2 Tag Prefixes + +ns_tag_prefix {- 93 -} = wrapTokens BeginTag EndTag + $ ( c_ns_local_tag_prefix / ns_global_tag_prefix ) + +c_ns_local_tag_prefix {- 94 -} = c_tag & meta ( ns_uri_char *) + +ns_global_tag_prefix {- 95 -} = meta ( ns_tag_char & ( ns_uri_char *) ) + +-- 6.9 Node Properties + +c_ns_properties n c {- 96 -} = wrapTokens BeginProperties EndProperties + $ ( c_ns_tag_property + & ( s_separate n c & c_ns_anchor_property ?) ) + / ( c_ns_anchor_property + & ( s_separate n c & c_ns_tag_property ?) ) + +-- 6.9.1 Node Tags + +c_ns_tag_property {- 97 -} = wrapTokens BeginTag EndTag + $ c_verbatim_tag + / c_ns_shorthand_tag + / c_non_specific_tag + +c_verbatim_tag {- 98 -} = c_tag & indicator '<' & meta ( ns_uri_char +) & indicator '>' + +c_ns_shorthand_tag {- 99 -} = c_tag_handle & meta ( ns_tag_char +) + +c_non_specific_tag {- 100 -} = c_tag + +-- 6.9.2 Node Anchors + +c_ns_anchor_property {- 101 -} = wrapTokens BeginAnchor EndAnchor + $ c_anchor & ns_anchor_name + +ns_anchor_char {- 102 -} = ns_char - c_flow_indicator +ns_anchor_name {- 103 -} = meta ( ns_anchor_char +) + +-- 7.1 Alias Nodes + +c_ns_alias_node {- 104 -} = wrapTokens BeginAlias EndAlias + $ c_alias ! "node" & ns_anchor_name + +-- 7.2 Empty Nodes + +e_scalar {- 105 -} = wrapTokens BeginScalar EndScalar empty + +e_node {- 106 -} = wrapTokens BeginNode EndNode e_scalar + +-- 7.3.1 Double Quoted Style + +nb_double_char {- 107 -} = "escape" ^ ( c_ns_esc_char / ( nb_json - c_escape - c_double_quote ) ) +ns_double_char {- 108 -} = nb_double_char - s_white + +c_double_quoted n c {- 109 -} = wrapTokens BeginScalar EndScalar + $ c_double_quote ! "node" & text ( nb_double_text n c ) & c_double_quote +nb_double_text n c {- 110 -} = case c of + FlowOut -> nb_double_multi_line n + FlowIn -> nb_double_multi_line n + BlockKey -> nb_double_one_line + FlowKey -> nb_double_one_line +nb_double_one_line {- 111 -} = ( nb_double_char *) + +s_double_escaped n {- 112 -} = ( s_white *) + & wrapTokens BeginEscape EndEscape ( c_escape ! "escape" & b_non_content ) + & ( l_empty n FlowIn *) + & s_flow_line_prefix n +s_double_break n {- 113 -} = "escape" ^ ( s_double_escaped n / s_flow_folded n ) + +nb_ns_double_in_line {- 114 -} = ( ( s_white *) & ns_double_char *) +s_double_next_line n {- 115 -} = s_double_break n + & ( ns_double_char & nb_ns_double_in_line + & ( s_double_next_line n / ( s_white *) ) ?) +nb_double_multi_line n {- 116 -} = nb_ns_double_in_line + & ( s_double_next_line n / ( s_white *) ) + +-- 7.3.2 Single Quoted Style + +c_quoted_quote {- 117 -} = wrapTokens BeginEscape EndEscape + $ c_single_quote ! "escape" & meta '\'' +nb_single_char {- 118 -} = "escape" ^ ( c_quoted_quote / ( nb_json - c_single_quote ) ) +ns_single_char {- 119 -} = nb_single_char - s_white + +c_single_quoted n c {- 120 -} = wrapTokens BeginScalar EndScalar + $ c_single_quote ! "node" & text ( nb_single_text n c ) & c_single_quote +nb_single_text n c {- 121 -} = case c of + FlowOut -> nb_single_multi_line n + FlowIn -> nb_single_multi_line n + BlockKey -> nb_single_one_line + FlowKey -> nb_single_one_line +nb_single_one_line {- 122 -} = ( nb_single_char *) + +nb_ns_single_in_line {- 123 -} = ( ( s_white *) & ns_single_char *) +s_single_next_line n {- 124 -} = s_flow_folded n + & ( ns_single_char & nb_ns_single_in_line + & ( s_single_next_line n / ( s_white *) ) ?) +nb_single_multi_line n {- 125 -} = nb_ns_single_in_line + & ( s_single_next_line n / ( s_white *) ) + +-- 7.3.3 Plain Style + +ns_plain_first _c {- 126 -} = ns_char - c_indicator + / ( ':' / '?' / '-' ) & ( ns_char >?) + +ns_plain_safe c {- 127 -} = case c of + FlowOut -> ns_plain_safe_out + FlowIn -> ns_plain_safe_in + BlockKey -> ns_plain_safe_out + FlowKey -> ns_plain_safe_in +ns_plain_safe_out {- 128 -} = ns_char - c_mapping_value - c_comment +ns_plain_safe_in {- 129 -} = ns_plain_safe_out - c_flow_indicator +ns_plain_char c {- 130 -} = ns_plain_safe c + / ( ns_char ?) + +ns_plain n c {- 131 -} = wrapTokens BeginScalar EndScalar + $ text (case c of + FlowOut -> ns_plain_multi_line n c + FlowIn -> ns_plain_multi_line n c + BlockKey -> ns_plain_one_line c + FlowKey -> ns_plain_one_line c) +nb_ns_plain_in_line c {- 132 -} = ( ( s_white *) & ns_plain_char c *) +ns_plain_one_line c {- 133 -} = ns_plain_first c ! "node" & nb_ns_plain_in_line c + +s_ns_plain_next_line n c {- 134 -} = s_flow_folded n + & ns_plain_char c & nb_ns_plain_in_line c +ns_plain_multi_line n c {- 135 -} = ns_plain_one_line c + & ( s_ns_plain_next_line n c *) + +-- 7.4 Flow Collection Styles + +in_flow c {- 136 -} = case c of + FlowOut -> FlowIn + FlowIn -> FlowIn + BlockKey -> FlowKey + FlowKey -> FlowKey + +-- 7.4.1 Flow Sequences + +c_flow_sequence n c {- 137 -} = wrapTokens BeginSequence EndSequence + $ c_sequence_start ! "node" & ( s_separate n c ?) + & ( ns_s_flow_seq_entries n (in_flow c) ?) & c_sequence_end + +ns_s_flow_seq_entries n c {- 138 -} = ns_flow_seq_entry n c & ( s_separate n c ?) + & ( c_collect_entry & ( s_separate n c ?) + & ( ns_s_flow_seq_entries n c ?) ?) + +ns_flow_seq_entry n c {- 139 -} = "pair" ^ ( ns_flow_pair n c / "node" ^ ns_flow_node n c ) + +-- 7.4.2 Flow Mappings + +c_flow_mapping n c {- 140 -} = wrapTokens BeginMapping EndMapping + $ c_mapping_start ! "node" & ( s_separate n c ?) + & ( ns_s_flow_map_entries n (in_flow c) ?) & c_mapping_end +ns_s_flow_map_entries n c {- 141 -} = ns_flow_map_entry n c & ( s_separate n c ?) + & ( c_collect_entry & ( s_separate n c ?) + & ( ns_s_flow_map_entries n c ?) ?) + +ns_flow_map_entry n c {- 142 -} = wrapTokens BeginPair EndPair + $ "key" ^ ( ( c_mapping_key ! "key" & s_separate n c + & ns_flow_map_explicit_entry n c ) + / ns_flow_map_implicit_entry n c ) +ns_flow_map_explicit_entry n c {- 143 -} = ns_flow_map_implicit_entry n c + / ( e_node + & e_node ) + +ns_flow_map_implicit_entry n c {- 144 -} = "pair" + ^ ( ns_flow_map_yaml_key_entry n c + / c_ns_flow_map_empty_key_entry n c + / c_ns_flow_map_json_key_entry n c ) +ns_flow_map_yaml_key_entry n c {- 145 -} = ( "node" ^ ns_flow_yaml_node n c ) ! "pair" + & ( ( ( s_separate n c ?) + & c_ns_flow_map_separate_value n c ) + / e_node ) +c_ns_flow_map_empty_key_entry n c {- 146 -} = e_node + & c_ns_flow_map_separate_value n c + +c_ns_flow_map_separate_value n c {- 147 -} = c_mapping_value & ( ns_char >!) ! "pair" + & ( ( s_separate n c & ns_flow_node n c ) + / e_node ) + +c_ns_flow_map_json_key_entry n c {- 148 -} = ( "node" ^ c_flow_json_node n c ) ! "pair" + & ( ( ( s_separate n c ?) + & c_ns_flow_map_adjacent_value n c ) + / e_node ) +c_ns_flow_map_adjacent_value n c {- 149 -} = c_mapping_value ! "pair" + & ( ( ( s_separate n c ?) + & ns_flow_node n c ) + / e_node ) + +ns_flow_pair n c {- 150 -} = wrapTokens BeginMapping EndMapping + $ wrapTokens BeginPair EndPair + $ ( ( c_mapping_key ! "pair" & s_separate n c + & ns_flow_map_explicit_entry n c ) + / ns_flow_pair_entry n c ) + +ns_flow_pair_entry n c {- 151 -} = ( ns_flow_pair_yaml_key_entry n c + / c_ns_flow_map_empty_key_entry n c + / c_ns_flow_pair_json_key_entry n c ) +ns_flow_pair_yaml_key_entry n c {- 152 -} = ns_s_implicit_yaml_key FlowKey + & c_ns_flow_map_separate_value n c +c_ns_flow_pair_json_key_entry n c {- 153 -} = c_s_implicit_json_key FlowKey + & c_ns_flow_map_adjacent_value n c +ns_s_implicit_yaml_key c {- 154 -} = ( "node" ^ ( ns_flow_yaml_node na c ) & ( s_separate_in_line ?) ) + `limitedTo` 1024 +c_s_implicit_json_key c {- 155 -} = ( "node" ^ ( c_flow_json_node na c ) & ( s_separate_in_line ?) ) + `limitedTo` 1024 + +-- 7.5 Flow Nodes + +ns_flow_yaml_content n c {- 156 -} = ns_plain n c +c_flow_json_content n c {- 157 -} = c_flow_sequence n c / c_flow_mapping n c + / c_single_quoted n c / c_double_quoted n c +ns_flow_content n c {- 158 -} = ns_flow_yaml_content n c / c_flow_json_content n c + +ns_flow_yaml_node n c {- 159 -} = wrapTokens BeginNode EndNode + $ c_ns_alias_node + / ns_flow_yaml_content n c + / ( c_ns_properties n c + & ( ( s_separate n c & ns_flow_yaml_content n c ) + / e_scalar ) ) +c_flow_json_node n c {- 160 -} = wrapTokens BeginNode EndNode + $ ( c_ns_properties n c & s_separate n c ?) + & c_flow_json_content n c +ns_flow_node n c {- 161 -} = wrapTokens BeginNode EndNode + $ c_ns_alias_node + / ns_flow_content n c + / ( c_ns_properties n c + & ( ( s_separate n c & ns_flow_content n c ) + / e_scalar ) ) + +-- 8.1.1 Block Scalar Headers + +c_b_block_header n {- 162 -} = "header" + ^ ( do m <- c_indentation_indicator n + t <- c_chomping_indicator + ( s_white / b_char ) ?! "header" + s_b_comment + result (m, t) + / do t <- c_chomping_indicator + m <- c_indentation_indicator n + s_b_comment + result (m, t) ) + +-- 8.1.1.1 Block Indentation Indicator + +c_indentation_indicator n {- 163 -} = indicator ( ns_dec_digit - '0' ) & asInteger + / detect_scalar_indentation n + +detect_scalar_indentation n = peek $ ( nb_char *) + & ( b_non_content & ( l_empty n BlockIn *) ?) + & count_spaces (-n) + +count_spaces n = (s_space & count_spaces (n .+ 1)) + / result (max 1 n) + +-- 8.1.1.2 Chomping Indicator + +c_chomping_indicator {- 164 -} = indicator '-' & result Strip + / indicator '+' & result Keep + / result Clip + +end_block_scalar t = case t of + Strip -> emptyToken EndScalar + Clip -> emptyToken EndScalar + Keep -> empty + +b_chomped_last t {- 165 -} = case t of + Strip -> emptyToken EndScalar & b_non_content + Clip -> b_as_line_feed & emptyToken EndScalar + Keep -> b_as_line_feed + +l_chomped_empty n t {- 166 -} = case t of + Strip -> l_strip_empty n + Clip -> l_strip_empty n + Keep -> l_keep_empty n +l_strip_empty n {- 167 -} = ( s_indent_le n & b_non_content *) + & ( l_trail_comments n ?) +l_keep_empty n {- 168 -} = ( l_empty n BlockIn *) + & emptyToken EndScalar + & ( l_trail_comments n ?) + +l_trail_comments n {- 169 -} = s_indent_lt n & c_nb_comment_text & b_comment + & ( nonEmpty l_comment *) + +-- 8.1.2 Literal Style + +c_l__literal n {- 170 -} = do emptyToken BeginScalar + c_literal ! "node" + (m, t) <- c_b_block_header n `prefixErrorWith` emptyToken EndScalar + text ( l_literal_content (n .+ m) t ) + +l_nb_literal_text n {- 171 -} = ( l_empty n BlockIn *) + & s_indent n & ( nb_char +) +b_nb_literal_next n {- 172 -} = b_as_line_feed + & l_nb_literal_text n +l_literal_content n t {- 173 -} = ( ( l_nb_literal_text n & ( b_nb_literal_next n *) & b_chomped_last t ) + / end_block_scalar t ) + & l_chomped_empty n t + +-- 8.1.3 Folded Style + +c_l__folded n {- 174 -} = do emptyToken BeginScalar + c_folded ! "node" + (m, t) <- c_b_block_header n `prefixErrorWith` emptyToken EndScalar + text ( l_folded_content (n .+ m) t ) + +s_nb_folded_text n {- 175 -} = s_indent n & ns_char ! "fold" & ( nb_char *) +l_nb_folded_lines n {- 176 -} = s_nb_folded_text n + & ( b_l_folded n BlockIn & s_nb_folded_text n *) + +s_nb_spaced_text n {- 177 -} = s_indent n & s_white ! "fold" & ( nb_char *) +b_l_spaced n {- 178 -} = b_as_line_feed + & ( l_empty n BlockIn *) +l_nb_spaced_lines n {- 179 -} = s_nb_spaced_text n + & ( b_l_spaced n & s_nb_spaced_text n *) + +l_nb_same_lines n {- 180 -} = ( l_empty n BlockIn *) + & "fold" ^ ( l_nb_folded_lines n / l_nb_spaced_lines n ) + +l_nb_diff_lines n {- 181 -} = l_nb_same_lines n + & ( b_as_line_feed & l_nb_same_lines n *) + +l_folded_content n t {- 182 -} = ( ( l_nb_diff_lines n & b_chomped_last t ) + / end_block_scalar t ) + & l_chomped_empty n t + +-- 8.2.1 Block Sequences + +detect_collection_indentation n = peek $ ( nonEmpty l_comment* ) & count_spaces (-n) +detect_inline_indentation = peek $ count_spaces 0 + +l__block_sequence n {- 183 -} = do m <- detect_collection_indentation n + wrapTokens BeginSequence EndSequence $ ( s_indent (n .+ m) & c_l_block_seq_entry (n .+ m) +) +c_l_block_seq_entry n {- 184 -} = c_sequence_entry & ( ns_char >!) ! "node" + & s_l__block_indented n BlockIn + +s_l__block_indented n c {- 185 -} = do m <- detect_inline_indentation + "node" ^ ( ( s_indent m + & ( ns_l_in_line_sequence (n .+ 1 .+ m) + / ns_l_in_line_mapping (n .+ 1 .+ m) ) ) + / s_l__block_node n c + / ( e_node & ( s_l_comments ?) & unparsed (n .+ 1) ) ) `recovery` unparsed (n .+ 1) +ns_l_in_line_sequence n {- 186 -} = wrapTokens BeginNode EndNode + $ wrapTokens BeginSequence EndSequence + $ c_l_block_seq_entry n + & ( s_indent n & c_l_block_seq_entry n *) + +-- 8.2.2 Block Mappings + +l__block_mapping n = {- 187 -} do m <- detect_collection_indentation n + wrapTokens BeginMapping EndMapping $ ( s_indent (n .+ m) & ns_l_block_map_entry (n .+ m) +) + +ns_l_block_map_entry n {- 188 -} = wrapTokens BeginPair EndPair + $ c_l_block_map_explicit_entry n + / ns_l_block_map_implicit_entry n +c_l_block_map_explicit_entry n {- 189 -} = c_l_block_map_explicit_key n + & ( l_block_map_explicit_value n + / e_node ) +c_l_block_map_explicit_key n {- 190 -} = c_mapping_key ! "node" & s_l__block_indented n BlockOut +l_block_map_explicit_value n {- 191 -} = s_indent n & c_mapping_value & s_l__block_indented n BlockOut + +ns_l_block_map_implicit_entry n {- 192 -} = ( ns_s_block_map_implicit_key + / e_node ) + & c_l_block_map_implicit_value n +ns_s_block_map_implicit_key {- 193 -} = c_s_implicit_json_key BlockKey + / ns_s_implicit_yaml_key BlockKey + +c_l_block_map_implicit_value n {- 194 -} = c_mapping_value ! "node" + & ( ( s_l__block_node n BlockOut + / ( e_node & ( s_l_comments ?) & unparsed (n .+ 1) ) ) `recovery` unparsed (n .+ 1) ) + +ns_l_in_line_mapping n {- 195 -} = wrapTokens BeginNode EndNode + $ wrapTokens BeginMapping EndMapping + $ ns_l_block_map_entry n + & ( s_indent n & ns_l_block_map_entry n *) + +-- 8.2.3 Block Nodes + +unparsed n = ( sol / unparsed_text & unparsed_break ) + & ( nonEmpty ( unparsed_indent n & unparsed_text & unparsed_break ) *) +unparsed_indent n = token Unparsed ( s_space % n ) +unparsed_text = token Unparsed ( upto ( eof / c_forbidden / b_break ) ) +unparsed_break = eof / peek c_forbidden / token Unparsed b_break / empty + +s_l__block_node n c {- 196 -} = s_l__block_in_block n c / s_l__flow_in_block n +s_l__flow_in_block n {- 197 -} = s_separate (n .+ 1) FlowOut + & ns_flow_node (n .+ 1) FlowOut & s_l_comments + +s_l__block_in_block n c {- 198 -} = wrapTokens BeginNode EndNode + $ ( s_l__block_scalar n c / s_l__block_collection n c ) +s_l__block_scalar n c {- 199 -} = s_separate (n .+ 1) c + & ( c_ns_properties (n .+ 1) c & s_separate (n .+ 1) c ?) + & ( c_l__literal n / c_l__folded n ) + +s_l__block_collection n c {- 200 -} = ( s_separate (n .+ 1) c & c_ns_properties (n .+ 1) c & ( s_l_comments >?) ?) + & s_l_comments + & ( l__block_sequence (seq_spaces n c) + / l__block_mapping n ) +seq_spaces n c {- 201 -} = case c of + BlockOut -> n .- 1 + BlockIn -> n + +-- 9.1.1 Document Prefix + +l_document_prefix {- 202 -} = ( c_byte_order_mark ?) & ( nonEmpty l_comment *) + +-- 9.1.2 Document Markers + +c_directives_end {- 203 -} = token DirectivesEnd [ '-', '-', '-' ] +c_document_end {- 204 -} = token DocumentEnd [ '.', '.', '.' ] +l_document_suffix {- 205 -} = c_document_end & s_l_comments +c_forbidden {- 206 -} = sol + & ( c_directives_end / c_document_end ) + & ( b_char / s_white / eof ) + +-- 9.1.3 Explicit Documents + +l_bare_document {- 207 -} = "node" ^ s_l__block_node (-1) BlockIn + `forbidding` c_forbidden + +-- 9.1.4 Explicit Documents + +l_explicit_document {- 208 -} = c_directives_end ! "doc" + & ( ( l_bare_document + / e_node & ( s_l_comments ?) & unparsed 0 ) `recovery` unparsed 0 ) + +-- 9.1.5 Directives Documents + +l_directives_document {- 209 -} = ( l_directive +) + & l_explicit_document + +-- 9.2 Streams: + +l_any_document {- 210 -} = wrapTokens BeginDocument EndDocument + $ "doc" ^ ( l_directives_document + / l_explicit_document + / l_bare_document ) `recovery` unparsed 0 + +l_yaml_stream {- 211 -} = ( nonEmpty l_document_prefix *) + & ( eof / ( c_document_end & ( b_char / s_white / eof ) >?) / l_any_document ) + & ( nonEmpty ( "more" ^ ( ( l_document_suffix ! "more" +) & ( nonEmpty l_document_prefix *) & ( eof / l_any_document ) + / ( nonEmpty l_document_prefix *) & "doc" ^ ( wrapTokens BeginDocument EndDocument l_explicit_document ?) ) ) *) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +module Util + ( liftEither + , readMaybe + , readEither + , fromIntegerMaybe + + , module X + ) where + +import Control.Applicative as X +import Control.Monad as X +import Data.Int as X +import Data.Word as X + +import Control.Monad.Except +import Control.Monad.Identity as X + +import Data.Map as X (Map) +import Data.Monoid as X (Monoid (mappend, mempty)) +import Data.Set as X (Set) +import Data.Text as X (Text) + +import Text.ParserCombinators.ReadP as P +import Text.Read + +#if !MIN_VERSION_mtl(2,2,2) +liftEither :: MonadError e m => Either e a -> m a +liftEither = either throwError return +#endif + +#if !MIN_VERSION_base(4,6,0) +readMaybe :: Read a => String -> Maybe a +readMaybe = either (const Nothing) id . readEither + +readEither :: Read a => String -> Either String a +readEither s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = do x <- readPrec + Text.Read.lift P.skipSpaces + return x +#endif + + +fromIntegerMaybe :: forall n . (Integral n, Bounded n) => Integer -> Maybe n +fromIntegerMaybe j + | l <= j, j <= u = Just (fromInteger j) + | otherwise = Nothing + where + u = toInteger (maxBound :: n) + l = toInteger (minBound :: n) +