diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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/Symantic/RNC.hs b/Symantic/RNC.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC.hs @@ -0,0 +1,14 @@ +module Symantic.RNC + ( module Symantic.RNC.Sym + , module Symantic.RNC.Validate + , module Symantic.RNC.Write + , Functor(..) + , Applicative(..) + , Alternative((<|>)) + ) where +import Data.Functor +import Control.Applicative + +import Symantic.RNC.Sym +import Symantic.RNC.Write +import Symantic.RNC.Validate diff --git a/Symantic/RNC/Sym.hs b/Symantic/RNC/Sym.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC/Sym.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +module Symantic.RNC.Sym + ( module Symantic.RNC.Sym + , Functor(..), (<$>) + , Applicative(..) + , Alternative(..) + ) where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Data.Eq (Eq) +import Data.Function ((.), id) +import Data.Functor (Functor(..), (<$>)) +import Data.Maybe (Maybe(..)) +import Data.Sequence (Seq) +import Data.String (String) +import Text.Show (Show(..)) +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL + +import qualified Symantic.XML as XML + +-- * Class 'Sym_RNC' +class + ( Applicative repr + , Alternative repr + , Sym_Rule repr + , Sym_Permutation repr + ) => Sym_RNC repr where + namespace :: Maybe XML.NCName -> XML.Namespace -> repr () + element :: XML.QName -> repr a -> repr a + attribute :: XML.QName -> repr a -> repr a + any :: repr () + anyElem :: XML.Namespace -> (XML.NCName -> repr a) -> repr a + escapedText :: repr XML.EscapedText + text :: repr TL.Text + text = XML.unescapeText <$> escapedText + fail :: repr a + try :: repr a -> repr a + option :: a -> repr a -> repr a + optional :: repr a -> repr (Maybe a) + choice :: [repr a] -> repr a + intermany :: [repr a] -> repr [a] + intermany = many . choice . (try <$>) + manySeq :: repr a -> repr (Seq a) + manySeq r = Seq.fromList <$> many r + someSeq :: repr a -> repr (Seq a) + someSeq r = Seq.fromList <$> some r + +-- * Class 'Sym_Rule' +class Sym_Rule repr where + rule :: Show a => String -> repr a -> repr a + rule _n = id + arg :: String -> repr () + +-- ** Type 'RuleMode' +data RuleMode + = RuleMode_Body -- ^ Request to generate the body of the rule. + | RuleMode_Ref -- ^ Request to generate a reference to the rule. + | RuleMode_Def -- ^ Request to generate a definition of the rule. + deriving (Eq, Show) + +-- * Class 'Sym_Permutation' +class (Alternative repr, Applicative (Permutation repr)) => Sym_Permutation repr where + runPermutation :: Permutation repr a -> repr a + toPermutation :: repr a -> Permutation repr a + toPermutationWithDefault :: a -> repr a -> Permutation repr a + + (<$$>) :: (a -> b) -> repr a -> Permutation repr b + (<$?>) :: (a -> b) -> (a, repr a) -> Permutation repr b + (<$*>) :: ([a] -> b) -> repr a -> Permutation repr b + (<$:>) :: (Seq a -> b) -> repr a -> Permutation repr b + infixl 2 <$$>, <$?>, <$*>, <$:> + {-# INLINE (<$$>) #-} + {-# INLINE (<$?>) #-} + {-# INLINE (<$*>) #-} + {-# INLINE (<$:>) #-} + + (<||>) :: Permutation repr (a -> b) -> repr a -> Permutation repr b + (<|?>) :: Permutation repr (a -> b) -> (a, repr a) -> Permutation repr b + (<|*>) :: Permutation repr ([a] -> b) -> repr a -> Permutation repr b + (<|:>) :: Permutation repr (Seq a -> b) -> repr a -> Permutation repr b + infixl 1 <||>, <|?>, <|*>, <|:> + {-# INLINE (<||>) #-} + {-# INLINE (<|?>) #-} + {-# INLINE (<|*>) #-} + {-# INLINE (<|:>) #-} + + f <$$> x = f <$> toPermutation x + f <$?> (d,x) = f <$> toPermutationWithDefault d x + f <$*> x = f <$> toPermutationWithDefault [] (some x) + f <$:> x = f . Seq.fromList <$> toPermutationWithDefault [] (some x) + + f <||> x = f <*> toPermutation x + f <|?> (d,x) = f <*> toPermutationWithDefault d x + f <|*> x = f <*> toPermutationWithDefault [] (some x) + f <|:> x = f <*> toPermutationWithDefault Seq.empty (Seq.fromList <$> some x) + +-- ** Type family 'Permutation' +-- | Type of permutations, depending on the representation. +type family Permutation (repr:: * -> *) = (r :: * -> *) | r -> repr diff --git a/Symantic/RNC/Validate.hs b/Symantic/RNC/Validate.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC/Validate.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.RNC.Validate where + +import Control.Applicative (Applicative(..), Alternative(..), optional) +import Control.Monad (Monad(..)) +import Data.Bool +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), all) +import Data.Function (($), const, id) +import Data.Functor (Functor(..), (<$>)) +import Data.Maybe (Maybe(..), maybe) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Tuple (snd) +import Prelude (error) +import Data.Sequence (Seq) +import qualified Data.Char as Char +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text.Lazy as TL +import qualified Text.Megaparsec as P + +import Symantic.XML (XMLs) +import qualified Symantic.XML as XML +import qualified Symantic.RNC.Sym as RNC + +validateXML :: + Ord e => P.Parsec e (XMLs src) a -> XMLs src -> + Either (P.ParseErrorBundle (XMLs src) e) a +validateXML p stateInput = + snd $ + P.runParser' p P.State + { P.stateInput + , P.stateOffset = 0 + , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations" + -- NOTE: reporting the node number is less helpful + -- than the source text line and number where the node is; + -- P.statePosState is only used by P.getSourcePos. + } + +instance + ( Ord err + , Ord src + , XML.NoSource src + , P.Stream (Seq (XML.XML src)) + , P.Token (Seq (XML.XML src)) ~ XML.Tree (XML.Sourced src XML.Node) + ) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where + {- + none = P.label "none" $ P.eof + -} + namespace _p _n = pure () + element n p = do + ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected + p_XMLs p ts + where + expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty + check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) + | e == n + = Just $ removePI $ removeXMLNS $ removeSpaces ts + where + removePI xs = + (`Seq.filter` xs) $ \case + XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False + _ -> True + removeSpaces xs = + if (`all` xs) $ \case + XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts -> + all (\case + XML.EscapedPlain t -> TL.all Char.isSpace t + _ -> False) et + _ -> True + then (`Seq.filter` xs) $ \case + XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False + _ -> True + else xs + removeXMLNS xs = + let (attrs,rest) = (`Seq.spanl` xs) $ \case + XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True + _ -> False in + let attrs' = (`Seq.filter` attrs) $ \case + XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts -> + case a of + XML.QName "" "xmlns" -> False + XML.QName ns _l -> ns /= XML.xmlns_xmlns + _ -> True in + attrs' <> rest + check _t = Nothing + attribute n p = do + v <- P.token check $ Set.singleton $ P.Tokens $ pure expected + p_XMLs p v + where + expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n) + check (XML.Tree (XML.unSourced -> XML.NodeAttr k) + v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n = + Just v + check _t = Nothing + any = P.label "any" $ + P.token (const $ Just ()) Set.empty + anyElem ns p = P.label "anyElem" $ do + (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected + p_XMLs (p $ XML.qNameLocal n) ts + where + expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty + check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) + | XML.qNameSpace e == ns + = Just $ (e,ts) + check _t = Nothing + {- + comment = do + s <- P.getInput + case Seq.viewl s of + XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do + P.setInput ts + c <$ XML.setFilePosToNextNode + t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex + EmptyL -> P.failure Nothing ex + where + ex = Set.singleton $ P.Tokens $ pure expected + expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "") + -} + escapedText = do + P.token check $ Set.singleton $ P.Tokens $ pure expected + where + expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty) + check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t + check _t = Nothing + optional = P.optional + option = P.option + choice = P.choice + try = P.try + fail = P.label "fail" $ P.failure Nothing mempty + +-- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@, +-- updating 'P.stateOffset' and re-raising any exception. +p_XMLs :: + Ord err => Ord src => + P.Stream (Seq (XML.XML src)) => + P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a +p_XMLs p stateInput = do + st <- P.getParserState + let (st', res) = P.runParser' (p <* P.eof) st + { P.stateInput = stateInput + , P.stateOffset = P.stateOffset st + } + P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'}) + case res of + Right a -> return a + Left (P.ParseErrorBundle errs _) -> + case NonEmpty.head errs of + P.TrivialError _o us es -> P.failure us es + P.FancyError _o es -> P.fancyFailure es + +-- | Whether the given 'XML.Node' must be ignored by the RNC parser. +isIgnoredNode :: XML.Node -> Bool +isIgnoredNode = \case + XML.NodeComment{} -> True + XML.NodePI{} -> True + XML.NodeCDATA{} -> True + _ -> False + +instance + ( Ord err + , Ord src + , P.Stream (Seq (XML.XML src)) + ) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where + runPermutation (Perm value parser) = optional parser >>= f + where + -- NOTE: copy Control.Applicative.Permutations.runPermutation + -- to replace the commented empty below so that P.TrivialError + -- has the unexpected token. + f Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value + f (Just p) = RNC.runPermutation p + toPermutation p = Perm Nothing $ pure <$> p + toPermutationWithDefault v p = Perm (Just v) $ pure <$> p + +-- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'. +-- so that the 'P.TrivialError' has an unexpected token +-- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors. +data Perm m a = Perm (Maybe a) (m (Perm m a)) +type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Perm (P.ParsecT err (XMLs src) m) +instance Functor m => Functor (Perm m) where + fmap f (Perm v p) = Perm (f <$> v) (fmap f <$> p) +instance Alternative m => Applicative (Perm m) where + pure value = Perm (Just value) empty + lhs@(Perm f v) <*> rhs@(Perm g w) = Perm (f <*> g) (lhsAlt <|> rhsAlt) + where + lhsAlt = (<*> rhs) <$> v + rhsAlt = (lhs <*>) <$> w + +instance + ( Ord err + , Ord src + , P.Stream (Seq (XML.XML src)) + ) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where + -- rule n p = P.dbg s p {-(p P. s)-} where s = Text.unpack n + rule _n = id + arg _n = pure () diff --git a/Symantic/RNC/Write.hs b/Symantic/RNC/Write.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC/Write.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Symantic.RNC.Write + ( module Symantic.RNC.Write + , module Symantic.RNC.Write.Fixity + , module Symantic.RNC.Write.Namespaces + ) where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad +import Data.Bool +import Data.Function (($), (.), id) +import Data.Functor ((<$>)) +import Data.Functor.Compose (Compose(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (IsString(..)) +import Text.Show (Show(..)) +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +-- import qualified Data.Text.Lazy.Builder as TLB + +import Symantic.RNC.Sym +import Symantic.RNC.Write.Fixity +import Symantic.RNC.Write.Namespaces +import qualified Symantic.XML as XML + +-- | Get textual rendition of given 'RuleWriter'. +writeRNC :: [NS a] -> [Writer a] -> TL.Text +writeRNC ns ws = + let namespaces@XML.Namespaces{..} = runNS ns in + TL.unlines $ List.concat + [ [ "default namespace = \""<>XML.unNamespace namespaces_default<>"\"" + | not $ TL.null $ XML.unNamespace namespaces_default + ] + , [ "namespace "<>p<>" = \""<>n<>"\"" + | (XML.Namespace n, XML.NCName p) <- HM.toList namespaces_prefixes + ] + , runWriter namespaces <$> ws + ] + +-- * Type 'Writer' +newtype Writer a + = Writer { unWriter :: XML.Namespaces XML.NCName -> + RuleMode -> + (Infix, Side) -> + Pair -> TL.Text } + +-- | Get textual rendition of given 'Writer'. +runWriter :: XML.Namespaces XML.NCName -> Writer a -> TL.Text +runWriter ns (Writer w) = + w ns RuleMode_Def (infixN0, SideL) pairParen + +coerceWriter :: Writer a -> Writer b +coerceWriter = Writer . unWriter +{-# INLINE coerceWriter #-} + +{- +instance Show (Writer a) where + show = TL.unpack . runWriter +-} +instance Functor Writer where + fmap _f (Writer x) = Writer x +instance Applicative Writer where + pure _ = writeText $ "\"\"" + Writer f <*> Writer x = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + TL.intercalate ", " $ + List.filter (not . TL.null) $ + [ f ns rm (op, SideL) pairParen + , x ns rm (op, SideR) pairParen ] + where op = infixB SideL 2 +instance Alternative Writer where + empty = writeText "empty" + Writer wl <|> Writer wr = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + wl ns rm (op, SideL) pairParen <> " | " <> wr ns rm (op, SideR) pairParen + where op = infixB SideL 2 + many (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + w ns rm (op, SideL) pairParen <> "*" + where op = infixN 9 + some (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + w ns rm (op, SideL) pairParen <> "+" + where op = infixN 9 +instance Sym_Rule Writer where + rule n wr@(Writer w) = Writer $ \ns rm po pp -> + case rm of + RuleMode_Ref -> + pairIfNeeded pp po op $ + fromString n + where op = infixN 10 + RuleMode_Body -> w ns RuleMode_Ref po pp + RuleMode_Def -> + TL.intercalate " " + [ fromString n + , "=" + , unWriter (rule n wr) ns RuleMode_Body (infixN0, SideR) pp + ] + arg n = + Writer $ \_ns rm _po _pp -> + case rm of + RuleMode_Ref -> fromString n + RuleMode_Body -> "" + RuleMode_Def -> "" +type instance Permutation Writer = Compose [] Writer +instance Sym_Permutation Writer where + runPermutation (Compose []) = writeText "empty" + runPermutation (Compose [Writer w]) = Writer w + runPermutation (Compose l@(_:_)) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + TL.intercalate " & " $ + List.filter (not . TL.null) $ + (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen + where op = infixB SideL 1 + toPermutation = Compose . pure + toPermutationWithDefault _ = Compose . pure +instance Sym_RNC Writer where + namespace _p _n = writeText "" + element n (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + "element "<>TL.pack (show $ XML.prefixifyQName ns n) + <>" "<>w ns rm (op,SideR) pairBrace + where op = infixN 10 + anyElem (XML.Namespace n) f = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + (if TL.null n then "" else n<>":") <> + "* "<>w ns rm (op,SideR) pairBrace + where + op = infixN 0 + Writer w = f "" + attribute n (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + "attribute "<>TL.pack (show $ XML.prefixifyQName ns n) + <>" "<>w ns rm (op,SideR) pairBrace + where op = infixN 10 + try = id + fail = writeText "fail" + escapedText = writeText "text" + text = writeText "text" + any = writeText "any" + choice [] = writeText "empty" + choice [w] = w + choice l@(_:_) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + TL.intercalate " | " $ + (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen + where op = infixB SideL 2 + option _x (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + w ns rm (op, SideL) pairParen <> "?" + where op = infixN 9 + optional (Writer w) = Writer $ \ns rm po pp -> + pairIfNeeded pp po op $ + w ns rm (op, SideL) pairParen <> "?" + where op = infixN 9 + manySeq = coerceWriter . many + someSeq = coerceWriter . some + +-- | 'Writer' returns a constant rendition. +writeText :: TL.Text -> Writer a +writeText t = Writer $ \_ns _rm po pp -> + pairIfNeeded pp po op t + where op = infixN 10 diff --git a/Symantic/RNC/Write/Fixity.hs b/Symantic/RNC/Write/Fixity.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC/Write/Fixity.hs @@ -0,0 +1,110 @@ +module Symantic.RNC.Write.Fixity where + +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function ((.)) +import Data.Int (Int) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup +import Data.String (String, IsString(..)) +import Text.Show (Show(..)) + +-- * Type 'Fixity' +data Fixity + = Fixity1 Unifix + | Fixity2 Infix + deriving (Eq, Show) + +-- ** Type 'Unifix' +data Unifix + = Prefix { unifix_precedence :: Precedence } + | Postfix { unifix_precedence :: Precedence } + deriving (Eq, Show) + +-- ** Type 'Infix' +data Infix + = Infix + { infix_associativity :: Maybe Associativity + , infix_precedence :: Precedence + } deriving (Eq, Show) + +infixL :: Precedence -> Infix +infixL = Infix (Just AssocL) + +infixR :: Precedence -> Infix +infixR = Infix (Just AssocR) + +infixB :: Side -> Precedence -> Infix +infixB = Infix . Just . AssocB + +infixN :: Precedence -> Infix +infixN = Infix Nothing + +infixN0 :: Infix +infixN0 = infixN 0 + +infixN5 :: Infix +infixN5 = infixN 5 + +-- | Given 'Precedence' and 'Associativity' of its parent operator, +-- and the operand 'Side' it is in, +-- return whether an 'Infix' operator +-- needs to be enclosed by a 'Pair'. +isPairNeeded :: (Infix, Side) -> Infix -> Bool +isPairNeeded (po, lr) op = + infix_precedence op < infix_precedence po + || infix_precedence op == infix_precedence po + && not associate + where + associate = + case (lr, infix_associativity po) of + (_, Just AssocB{}) -> True + (SideL, Just AssocL) -> True + (SideR, Just AssocR) -> True + _ -> False + +-- | If 'isPairNeeded' is 'True', +-- enclose the given 'IsString' by given 'Pair', +-- otherwise returns the same 'IsString'. +pairIfNeeded :: + Semigroup s => IsString s => + Pair -> (Infix, Side) -> Infix -> + s -> s +pairIfNeeded (o,c) po op s = + if isPairNeeded po op + then fromString o <> s <> fromString c + else s + +-- * Type 'Precedence' +type Precedence = Int + +-- ** Class 'PrecedenceOf' +class PrecedenceOf a where + precedence :: a -> Precedence +instance PrecedenceOf Fixity where + precedence (Fixity1 uni) = precedence uni + precedence (Fixity2 inf) = precedence inf +instance PrecedenceOf Unifix where + precedence = unifix_precedence +instance PrecedenceOf Infix where + precedence = infix_precedence + +-- * Type 'Associativity' +data Associativity + = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@ + | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@ + | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading. + deriving (Eq, Show) + +-- ** Type 'Side' +data Side + = SideL -- ^ Left + | SideR -- ^ Right + deriving (Eq, Show) + +-- ** Type 'Pair' +type Pair = (String, String) +pairParen, pairBrace :: Pair +pairParen = ("(",")") +pairBrace = ("{","}") diff --git a/Symantic/RNC/Write/Namespaces.hs b/Symantic/RNC/Write/Namespaces.hs new file mode 100644 --- /dev/null +++ b/Symantic/RNC/Write/Namespaces.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Symantic.RNC.Write.Namespaces where + +import Control.Applicative (Applicative(..), Alternative(..), (<$>)) +import Control.Monad (Monad(..), forM, sequence) +import Data.Default.Class (Default(..)) +import Data.Function (($), (.), id) +import Data.Functor (Functor(..)) +import Data.Maybe (Maybe(..), maybe, isNothing) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Text.Show (Show(..)) +import Data.String (String) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Control.Monad.Trans.State.Strict as S + +import qualified Symantic.XML as XML +import Symantic.RNC.Sym + +-- | Collect 'XML.Namespace's used and get them a dedicated prefix. +runNS :: forall a. [NS a] -> XML.Namespaces XML.NCName +runNS ns = + namespaces + { XML.namespaces_prefixes = + (`S.evalState` HS.empty) $ + let prefixesByNamespace = + HM.delete "" $ -- NOTE: no prefix when there is no namespace. + HM.update -- NOTE: no prefix when this is the default namespace. + (\p -> if isNothing p then Nothing else Just p) + (XML.namespaces_default namespaces) $ + XML.namespaces_prefixes namespaces in + forM prefixesByNamespace $ \mp -> do + usedPrefixes <- S.get + let fp = maybe + (XML.freshNCName usedPrefixes) + (XML.freshifyNCName usedPrefixes) + mp + S.modify' $ HS.insert fp + return fp + } + where + namespaces :: XML.Namespaces (Maybe XML.NCName) + namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns + +coerceNS :: NS a -> NS b +coerceNS = NS . unNS +{-# INLINE coerceNS #-} + +-- * Type 'NS' +-- | Collect 'XML.Namespaces's and any prefixes associated with it, +-- using 'State' to avoid recurring into already visited 'rule's. +newtype NS a = NS { unNS :: S.State State (XML.Namespaces (Maybe XML.NCName)) } + +-- ** Type 'State' +newtype State = State + { state_rules :: {-!-}(HS.HashSet String) + } deriving (Show) +instance Default State where + def = State + { state_rules = HS.empty + } + +instance Show (NS a) where + showsPrec p = showsPrec p . runNS . pure +instance Semigroup (NS a) where + NS x <> NS y = NS $ (<>) <$> x <*> y +instance Monoid (NS a) where + mempty = NS $ return mempty + mappend = (<>) +instance Functor NS where + fmap _f = coerceNS +instance Applicative NS where + pure _ = mempty + NS f <*> NS x = NS f <> NS x + NS f <* NS x = NS f <> NS x + NS f *> NS x = NS f <> NS x +instance Alternative NS where + empty = mempty + NS f <|> NS x = NS f <> NS x + many = coerceNS + some = coerceNS +instance Sym_Rule NS where + rule n (NS ns) = NS $ do + -- NOTE: avoid infinite loops + -- by not reentering into already visited rules. + st@State{..} <- S.get + if HS.member n state_rules + then return mempty + else do + S.put $ st{state_rules = HS.insert n state_rules} + ns + arg _n = mempty +type instance Permutation NS = NS +instance Sym_Permutation NS where + runPermutation = coerceNS + toPermutation = id + toPermutationWithDefault _def = id +instance Sym_RNC NS where + -- namespace n ns = + -- NS $ return $ HM.singleton ns $ HS.singleton n + namespace mp n = + NS $ return $ + case mp of + Just p -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""} + Nothing -> def{XML.namespaces_default = n} + element XML.QName{..} (NS nsM) = + NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = + HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} + attribute XML.QName{..} (NS nsM) = + NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = + HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} + anyElem qNameSpace f = + let NS nsM = f $ XML.NCName "*" in + NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = + HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} + try = id + fail = mempty + escapedText = mempty + text = mempty + any = mempty + choice = mconcat + option _def = coerceNS + optional = coerceNS + manySeq = coerceNS + someSeq = coerceNS diff --git a/Symantic/XML.hs b/Symantic/XML.hs new file mode 100644 --- /dev/null +++ b/Symantic/XML.hs @@ -0,0 +1,11 @@ +module Symantic.XML + ( module Symantic.XML.Document + , readXML + , readFile + , writeXML + , writeXMLIndented + , writeFile + ) where +import Symantic.XML.Document +import Symantic.XML.Read +import Symantic.XML.Write diff --git a/Symantic/XML/Document.hs b/Symantic/XML/Document.hs new file mode 100644 --- /dev/null +++ b/Symantic/XML/Document.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Document + ( module Symantic.XML.Document + , TS.Tree(..) + , TS.Trees + , TS.tree0 + ) where + +import Control.Applicative (Alternative(..)) +import Data.Bool +import Data.Char (Char) +import Data.Default.Class (Default(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), all) +import Data.Function (($), (.), id) +import Data.Functor (Functor(..), (<$>)) +import Data.Hashable (Hashable(..)) +import Data.Int (Int) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (Seq) +import Data.String (String, IsString(..)) +import GHC.Generics (Generic) +import Prelude ((+), error) +import System.IO (FilePath) +import Text.Show (Show(..), showsPrec, showChar, showParen, showString) +import qualified Data.Char.Properties.XMLCharProps as XC +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL +import qualified Data.TreeSeq.Strict as TS + +-- * Type 'XML' +type XML src = TS.Tree (Sourced src Node) +type XMLs src = Seq (XML src) + +-- | Unify two 'XMLs', merging border 'NodeText's if any. +union :: Semigroup (Sourced src EscapedText) => XMLs src -> XMLs src -> XMLs src +union x y = + case (Seq.viewr x, Seq.viewl y) of + (xs Seq.:> x0, y0 Seq.:< ys) -> + case (x0,y0) of + ( Tree0 (Sourced sx (NodeText tx)) + , Tree0 (Sourced sy (NodeText ty)) ) -> + xs `union` + Seq.singleton (Tree0 $ (NodeText <$>) $ Sourced sx tx <> Sourced sy ty) `union` + ys + _ -> x <> y + (Seq.EmptyR, _) -> y + (_, Seq.EmptyL) -> x + +unions :: + Semigroup (Sourced src EscapedText) => + Foldable f => f (XMLs src) -> XMLs src +unions = foldl' union mempty + +pattern Tree0 :: a -> TS.Tree a +pattern Tree0 a <- TS.Tree a (null -> True) + where Tree0 a = TS.Tree a Seq.empty + +-- ** Type 'Node' +data Node + = NodeElem QName -- ^ Node with some 'NodeAttr' and then other 'Node's as children. + | NodeAttr QName -- ^ Node with a 'NodeText' child. + | NodePI PName TL.Text -- ^ Leaf (except for @@ which has 'NodeAttr's. + | NodeText EscapedText -- ^ Leaf. + | NodeComment TL.Text -- ^ Leaf. + | NodeCDATA TL.Text -- ^ Leaf. + deriving (Eq, Ord, Show) + +-- ** Type 'EscapedText' +newtype EscapedText = EscapedText (Seq Escaped) + deriving (Eq, Ord, Show) + +escapeText :: TL.Text -> EscapedText +escapeText s = + EscapedText $ + case TL.span (`List.notElem` ("<>&'\""::String)) s of + (t, r) | TL.null t -> escape r + | otherwise -> EscapedPlain t Seq.<| escape r + where + escape t = case TL.uncons t of + Nothing -> mempty + Just (c, cs) -> escapeChar c Seq.<| et where EscapedText et = escapeText cs + +escapeChar :: Char -> Escaped +escapeChar c = + case c of + '<' -> EscapedEntityRef entityRef_lt + '>' -> EscapedEntityRef entityRef_gt + '&' -> EscapedEntityRef entityRef_amp + '\'' -> EscapedEntityRef entityRef_apos + '"' -> EscapedEntityRef entityRef_quot + _ -> EscapedPlain $ TL.singleton c + +unescapeText :: EscapedText -> TL.Text +unescapeText (EscapedText et) = (`foldMap` et) $ \case + EscapedPlain t -> t + EscapedEntityRef EntityRef{..} -> entityRef_value + EscapedCharRef (CharRef c) -> TL.singleton c + +instance Semigroup EscapedText where + EscapedText x <> EscapedText y = + case (x,y) of + (xl Seq.:|> EscapedPlain xr, EscapedPlain yl Seq.:<|yr) -> + (EscapedText $ xl Seq.|> EscapedPlain (xr<>yl)) <> EscapedText yr + _ -> EscapedText $ x <> y +instance Monoid EscapedText where + mempty = EscapedText mempty + mappend = (<>) + +-- *** Type 'Escaped' +-- | 'EscapedText' lexemes. +data Escaped + = EscapedPlain TL.Text + | EscapedEntityRef EntityRef + | EscapedCharRef CharRef + deriving (Eq, Ord, Show) + +-- *** Type 'EntityRef' +data EntityRef = EntityRef + { entityRef_name :: NCName + , entityRef_value :: TL.Text + } deriving (Eq, Ord, Show) + +entityRef_lt, entityRef_gt, entityRef_amp, entityRef_quot, entityRef_apos :: EntityRef +entityRef_lt = EntityRef (NCName "lt") "<" +entityRef_gt = EntityRef (NCName "gt") ">" +entityRef_amp = EntityRef (NCName "amp") "&" +entityRef_quot = EntityRef (NCName "quot") "\"" +entityRef_apos = EntityRef (NCName "apos") "'" + +-- *** Type 'CharRef' +newtype CharRef = CharRef Char + deriving (Eq, Ord, Show) + +-- ** Type 'Name' +newtype Name = Name { unName :: TL.Text } + deriving (Eq, Ord, Hashable) +instance Show Name where + showsPrec _p = showString . TL.unpack . unName +instance IsString Name where + fromString s + | c:cs <- s + , XC.isXmlNameStartChar c + && all XC.isXmlNameChar cs + = Name (TL.pack s) + | otherwise = error $ "Invalid XML Name: "<>show s + +-- ** Type 'Namespace' +newtype Namespace = Namespace { unNamespace :: TL.Text } + deriving (Eq, Ord, Show, Hashable) +instance IsString Namespace where + fromString s = + if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s + then Namespace (fromString s) + else error $ "Invalid XML Namespace: "<>show s + +xmlns_xml, xmlns_xmlns, xmlns_empty :: Namespace +xmlns_xml = Namespace "http://www.w3.org/XML/1998/namespace" +xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/" +xmlns_empty = Namespace "" + +-- * Type 'Namespaces' +data Namespaces prefix = Namespaces + { namespaces_prefixes :: (HM.HashMap Namespace prefix) + , namespaces_default :: Namespace + } deriving (Show) +instance Default (Namespaces NCName) where + def = Namespaces + { namespaces_prefixes = HM.fromList + [ (xmlns_xml , "xml") + , (xmlns_xmlns, "xmlns") + ] + , namespaces_default = "" + } +instance Default (Namespaces (Maybe NCName)) where + def = Namespaces + { namespaces_prefixes = HM.fromList + [ (xmlns_xml , Just "xml") + , (xmlns_xmlns, Just "xmlns") + ] + , namespaces_default = "" + } +instance Semigroup (Namespaces NCName) where + x <> y = Namespaces + { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y + , namespaces_default = namespaces_default x + } +instance Semigroup (Namespaces (Maybe NCName)) where + x <> y = Namespaces + { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y) + , namespaces_default = namespaces_default x + } +instance Monoid (Namespaces NCName) where + mempty = def + mappend = (<>) +instance Monoid (Namespaces (Maybe NCName)) where + mempty = def + mappend = (<>) + +prefixifyQName :: Namespaces NCName -> QName -> PName +prefixifyQName Namespaces{..} QName{..} = + PName + { pNameSpace = + if qNameSpace == namespaces_default + then Nothing + else HM.lookup qNameSpace namespaces_prefixes + , pNameLocal = qNameLocal + } + +-- ** Type 'NCName' +-- | Non-colonized name. +newtype NCName = NCName { unNCName :: TL.Text } + deriving (Eq, Ord, Hashable) +instance Show NCName where + showsPrec _p = showString . TL.unpack . unNCName +instance IsString NCName where + fromString s = + fromMaybe (error $ "Invalid XML NCName: "<>show s) $ + ncName (TL.pack s) + +ncName :: TL.Text -> Maybe NCName +ncName t = + case TL.uncons t of + Just (c, cs) + | XC.isXmlNCNameStartChar c + , TL.all XC.isXmlNCNameChar cs + -> Just (NCName t) + _ -> Nothing + +poolNCNames :: [NCName] +poolNCNames = + [ NCName $ TL.pack ("ns"<>show i) + | i <- [1 :: Int ..] + ] + +freshNCName :: HS.HashSet NCName -> NCName +freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps + +freshifyNCName :: HS.HashSet NCName -> NCName -> NCName +freshifyNCName ns (NCName n) = + let ints = [1..] :: [Int] in + List.head + [ fresh + | suffix <- mempty : (show <$> ints) + , fresh <- [ NCName $ n <> TL.pack suffix] + , not $ fresh `HS.member` ns + ] + +-- ** Type 'PName' +-- | Prefixed name. +data PName = PName + { pNameSpace :: (Maybe NCName) -- ^ eg. Just "xml" + , pNameLocal :: NCName -- ^ eg. "stylesheet" + } deriving (Eq, Ord, Generic) +instance Show PName where + showsPrec p PName{pNameSpace=Nothing, ..} = + showsPrec p pNameLocal + showsPrec _p PName{pNameSpace=Just p, ..} = + showsPrec 10 p . + showChar ':' . + showsPrec 10 pNameLocal +instance IsString PName where + fromString "" = PName Nothing "" -- NOTE: NCName's fromString will raise an error. + fromString s = + case List.break (== ':') s of + (_, "") -> PName Nothing $ fromString s + (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local) +instance Hashable PName + +pName :: NCName -> PName +pName = PName Nothing +{-# INLINE pName #-} + +-- ** Type 'QName' +-- | Qualified name. +data QName = QName + { qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform" + , qNameLocal :: NCName -- ^ eg. "stylesheet" + } deriving (Eq, Ord, Generic) +instance Show QName where + showsPrec _p QName{..} = + (if TL.null $ unNamespace qNameSpace then id + else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}' + ) . showsPrec 10 qNameLocal +instance IsString QName where + fromString "" = QName "" "" -- NOTE: NCName's fromString will raise an error. + fromString full@('{':rest) = + case List.break (== '}') rest of + (_, "") -> error $ "Invalid XML Clark notation: "<>show full + (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local + fromString local = QName "" $ fromString local +instance Hashable QName + +qName :: NCName -> QName +qName = QName (Namespace "") +{-# INLINE qName #-} + +-- * Type 'Sourced' +data Sourced src a + = Sourced + { source :: src + , unSourced :: a + } deriving (Eq, Ord, Functor) +instance (Show src, Show a) => Show (Sourced src a) where + showsPrec p Sourced{..} = + showParen (p > 10) $ + showsPrec 11 unSourced . + showString " @" . showsPrec 10 source +instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where + (<>) + (Sourced rx@(FileRange xf xb xe :| xs) x) + (Sourced (FileRange yf yb ye :| _ys) y) + | xf == yf && xe == yb = Sourced (FileRange xf xb ye :| xs) $ x<>y + | otherwise = Sourced rx (x<>y) +{- +instance (FromPad a, Semigroup a) => Semigroup (Sourced (FileSource LineCol) a) where + (<>) + (Sourced rx@(FileRange xf xb xe :| xs) x) + (Sourced (FileRange yf yb ye :| _ys) y) + | xf == yf = Sourced (FileRange xf xb ye :| xs) $ x<>fromPad (LineColumn l c)<>y + | otherwise = Sourced rx (x<>y) + where + l = lineNum yb - lineNum xe + c = colNum yb - colNum (if l <= 0 then xe else xb) + +-- ** Class 'FromPad' +class FromPad a where + fromPad :: LineColumn -> a +instance FromPad T.Text where + fromPad LineColumn{..} = + T.replicate lineNum "\n" <> + T.replicate colNum " " +instance FromPad TL.Text where + fromPad LineColumn{..} = + TL.replicate (fromIntegral lineNum) "\n" <> + TL.replicate (fromIntegral colNum) " " +instance FromPad EscapedText where + fromPad = EscapedText . pure . fromPad +instance FromPad Escaped where + fromPad = EscapedPlain . fromPad +-} + +-- ** Class 'NoSource' +class NoSource src where + noSource :: src +instance Default pos => NoSource (FileSource pos) where + noSource = noSource :| [] +instance Default pos => NoSource (FileRange pos) where + noSource = FileRange "" def def +instance NoSource Offset where + noSource = Offset def +{- +instance (FromPad a, Semigroup a, Monoid a) => Monoid (Sourced a) where + mempty = sourced0 mempty + mappend = (<>) +-} + +notSourced :: NoSource src => a -> Sourced src a +notSourced = Sourced noSource + +-- * Type 'FileSource' +type FileSource pos = NonEmpty (FileRange pos) + +-- ** Type 'FileSourced' +type FileSourced = Sourced (FileSource Offset) + +-- ** Type 'FileRange' +data FileRange pos + = FileRange + { fileRange_file :: FilePath + , fileRange_begin :: pos + , fileRange_end :: pos + } deriving (Eq, Ord) +instance Default (FileRange Offset) where + def = FileRange "" def def +instance Default (FileRange LineColumn) where + def = FileRange "" def def +instance Show (FileRange Offset) where + showsPrec _p FileRange{..} = + showString fileRange_file . + showChar '@' . showsPrec 10 fileRange_begin . + showChar '-' . showsPrec 10 fileRange_end +instance Show (FileRange LineColumn) where + showsPrec _p FileRange{..} = + showString fileRange_file . + showChar '#' . showsPrec 10 fileRange_begin . + showChar '-' . showsPrec 10 fileRange_end + +-- *** Type 'Offset' +newtype Offset = Offset Int + deriving (Eq, Ord) +instance Show Offset where + showsPrec p (Offset o) = showsPrec p o +instance Default Offset where + def = Offset 0 +instance Semigroup Offset where + Offset x <> Offset y = Offset (x+y) +instance Monoid Offset where + mempty = def + mappend = (<>) + +-- *** Type 'LineColumn' +-- | Absolute text file position. +data LineColumn = LineColumn + { lineNum :: {-# UNPACK #-} Offset + , colNum :: {-# UNPACK #-} Offset + } deriving (Eq, Ord) +instance Default LineColumn where + def = LineColumn def def +instance Show LineColumn where + showsPrec _p LineColumn{..} = + showsPrec 11 lineNum . + showChar ':' . + showsPrec 11 colNum + +filePos1 :: LineColumn +filePos1 = def diff --git a/Symantic/XML/Read.hs b/Symantic/XML/Read.hs new file mode 100644 --- /dev/null +++ b/Symantic/XML/Read.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Read + ( module Symantic.XML.Read.Parser + , module Symantic.XML.Read + ) where + +import Control.Arrow (left) +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (Monad(..), void, unless, forM, join) +import Data.Bool +import Data.Char (Char) +import Data.Default.Class (Default(..)) +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.), const) +import Data.Functor ((<$>), (<$)) +import Data.Maybe (Maybe(..), maybe) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import Data.TreeSeq.Strict (Tree(..)) +import Data.Tuple (snd) +import Prelude (Num(..), Enum(..), Bounded(..), Integer, toInteger) +import System.IO (FilePath, IO) +import Text.Megaparsec (()) +import Text.Show (Show(..)) +import qualified Control.Exception as Exn +import qualified Control.Monad.Trans.Reader as R +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import qualified Data.Char.Properties.XMLCharProps as XC +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.Sequence as Seq +import qualified Data.Text.Encoding.Error as TL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.TreeSeq.Strict as TS +import qualified System.IO.Error as IO +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P + +import Symantic.XML.Document hiding (XML, XMLs) +import Symantic.XML.Read.Parser + +readXML :: FilePath -> TL.Text -> Either (P.ParseErrorBundle TL.Text Error) XMLs +readXML filePath stateInput = + snd $ + P.runParser' + (R.runReaderT p_document def) + P.State + { P.stateInput + , P.stateOffset = 0 + , P.statePosState = P.PosState + { P.pstateInput = stateInput + , P.pstateOffset = 0 + , P.pstateSourcePos = P.initialPos filePath + , P.pstateTabWidth = P.pos1 + , P.pstateLinePrefix = "" + } + } + +readFile :: FilePath -> IO (Either ErrorRead TL.Text) +readFile fp = + (left ErrorRead_Unicode . TL.decodeUtf8' <$> BSL.readFile fp) + `Exn.catch` \e -> + if IO.isAlreadyInUseError e + || IO.isDoesNotExistError e + || IO.isPermissionError e + then return $ Left $ ErrorRead_IO e + else IO.ioError e + +-- * Type 'ErrorRead' +data ErrorRead + = ErrorRead_IO IO.IOError + | ErrorRead_Unicode TL.UnicodeException + deriving (Show) + +-- * Document +p_document :: P.Tokens s ~ TL.Text => Parser Error s XMLs +p_document = do + ps <- p_prolog + e <- p_Element + ms <- P.many p_Misc + P.eof + return (ps <> pure e <> join (Seq.fromList ms)) + +-- ** Prolog +p_prolog :: P.Tokens s ~ TL.Text => Parser Error s XMLs +p_prolog = do + xmlDecl <- P.option Seq.empty $ pure <$> p_XMLDecl + ms <- P.many p_Misc + return (xmlDecl <> join (Seq.fromList ms)) + +-- ** Misc +p_Misc :: P.Tokens s ~ TL.Text => Parser Error s XMLs +p_Misc = + P.try (pure <$> p_Comment) + <|> P.try (pure <$> p_PI) + <|> pure <$> p_S + +-- ** XMLDecl +p_XMLDecl :: P.Tokens s ~ TL.Text => Parser Error s XML +p_XMLDecl = P.label "XMLDecl" $ do + Sourced src as <- p_Sourced $ P.between (P.string "") $ do + vi <- pure <$> p_VersionInfo + ed <- P.option Seq.empty $ pure <$> p_EncodingDecl + sd <- P.option Seq.empty $ pure <$> p_SDDecl + p_Spaces + return $ vi <> ed <> sd + return $ Tree (Sourced src $ NodePI "xml" "") as + +p_VersionInfo :: P.Tokens s ~ TL.Text => Parser Error s XML +p_VersionInfo = P.label "VersionInfo" $ do + Sourced c v <- p_Sourced $ do + P.try (() <$ p_Spaces1 <* P.string "version") + p_Eq + p_quoted $ const $ p_Sourced $ + (<>) + <$> P.string "1." + <*> P.takeWhile1P Nothing Char.isDigit + return $ Tree (Sourced c $ NodeAttr "version") $ pure $ + TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v + +p_EncodingDecl :: P.Tokens s ~ TL.Text => Parser Error s XML +p_EncodingDecl = P.label "EncodingDecl" $ do + Sourced c v <- p_Sourced $ do + P.try (() <$ p_Spaces1 <* P.string "encoding") + p_Eq + p_quoted $ const $ p_Sourced p_EncName + return $ Tree (Sourced c $ NodeAttr "encoding") $ pure $ + TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v + +p_EncName :: P.Tokens s ~ TL.Text => Parser Error s TL.Text +p_EncName = P.label "EncName" $ do + P.notFollowedBy (P.satisfy $ not . isAlpha) + P.takeWhile1P Nothing $ \c -> + isAlpha c || Char.isDigit c || + c=='.' || c=='_' || c=='-' + where isAlpha c = Char.isAsciiLower c || Char.isAsciiUpper c + +-- *** SDDecl +p_SDDecl :: P.Tokens s ~ TL.Text => Parser Error s XML +p_SDDecl = P.label "SDDecl" $ do + p_SourcedBegin $ do + Sourced ca () <- P.try (p_Sourced $ () <$ p_Spaces1 <* P.string "standalone") + p_Eq + v <- p_quoted $ const $ p_Sourced $ P.string "yes" <|> P.string "no" + return $ Tree (Sourced ca $ NodeAttr "standalone") $ pure $ + TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v + +-- ** CharData +p_CharData :: P.Tokens s ~ TL.Text => Parser e s EscapedText +p_CharData = + escapeText + <$> p_until1 (\c -> XC.isXmlChar c && c/='<' && c/='&') (']',"]>") + +-- ** Comment +p_Comment :: P.Tokens s ~ TL.Text => Parser Error s XML +p_Comment = p_SourcedBegin $ P.string "" + cell <- p_SourcedEnd + return $ TS.tree0 (cell $ NodeComment c) + +-- ** CDATA +p_CDSect :: P.Tokens s ~ TL.Text => Parser Error s XML +p_CDSect = p_SourcedBegin $ P.string " p_CDSect__ +p_CDSect_ :: P.Tokens s ~ TL.Text => Parser Error s XML +p_CDSect_ = P.string "[CDATA[" *> p_CDSect__ +p_CDSect__ :: P.Tokens s ~ TL.Text => Parser Error s XML +p_CDSect__ = P.label "CDSect" $ do + c <- p_until XC.isXmlChar (']', "]>") + void $ P.string "]]>" + cell <- p_SourcedEnd + return $ TS.tree0 $ cell $ NodeCDATA c + +-- ** PI +p_PI :: P.Tokens s ~ TL.Text => Parser Error s XML +p_PI = p_SourcedBegin $ P.string " p_PI__ +p_PI_ :: P.Tokens s ~ TL.Text => Parser Error s XML +p_PI_ = P.char '?' *> p_PI__ +p_PI__ :: P.Tokens s ~ TL.Text => Parser Error s XML +p_PI__ = P.label "PI" $ do + n <- p_PITarget + v <- P.option "" $ P.try $ p_Spaces1 *> p_until XC.isXmlChar ('?', ">") + void $ P.string "?>" + cell <- p_SourcedEnd + return $ TS.tree0 $ cell $ NodePI n v +p_PITarget :: P.Tokens s ~ TL.Text => Parser Error s PName +p_PITarget = do + n <- p_PName + case n of + PName{pNameSpace=Nothing, pNameLocal=NCName l} + | "xml" == TL.toLower l -> p_error $ Error_PI_reserved n + _ -> return n + +-- ** Element +p_Element :: P.Tokens s ~ TL.Text => Parser Error s XML +p_Element = p_SourcedBegin $ (P.char '<' *> p_Element_) +p_Element_ :: P.Tokens s ~ TL.Text => Parser Error s XML +p_Element_ = P.label "Element" p_STag + +-- *** STag +p_STag :: P.Tokens s ~ TL.Text => Parser Error s XML +p_STag = do + n <- p_PName + as <- P.many $ P.try $ p_Spaces1 *> p_Attribute + p_Spaces + ro <- R.ask + elemNS :: HM.HashMap NCName Namespace <- + (HM.fromList . List.concat <$>) $ forM as $ \case + Sourced _ (PName{..}, Sourced _ av) + | ns <- Namespace $ unescapeText av + , Nothing <- pNameSpace + , NCName "xmlns" <- pNameLocal -> + -- NOTE: default namespace declaration. + case ns of + _ | ns == xmlns_xml -- DOC: it MUST NOT be declared as the default namespace + || ns == xmlns_xmlns -- DOC: it MUST NOT be declared as the default namespace + -> p_error $ Error_Namespace_reserved ns + _ -> return [(NCName "" , ns)] + | ns <- Namespace $ unescapeText av + , Just (NCName "xmlns") <- pNameSpace -> + -- NOTE: namespace prefix declaration. + case unNCName pNameLocal of + "xml" -- DOC: It MAY, but need not, be declared, + -- and MUST NOT be bound to any other namespace name. + | ns == xmlns_xml -> return [] + | otherwise -> p_error $ Error_Namespace_reserved_prefix pNameLocal + "xmlns" -- DOC: It MUST NOT be declared + -> p_error $ Error_Namespace_reserved_prefix pNameLocal + local | "xml" <- TL.toLower $ TL.take 3 local -> return [] + -- DOC: All other prefixes beginning with the three-letter + -- sequence x, m, l, in any case combination, are reserved. + -- This means that: processors MUST NOT treat them as fatal errors. + _ | ns == xmlns_xml -- DOC: Other prefixes MUST NOT be bound to this namespace name. + || ns == xmlns_xmlns -- DOC: Other prefixes MUST NOT be bound to this namespace name. + -> p_error $ Error_Namespace_reserved ns + _ -> return [(pNameLocal, ns)] + | otherwise -> return [] + let scopeNS = elemNS <> reader_ns_scope ro + let defaultNS = HM.lookupDefault (reader_ns_default ro) (NCName "") scopeNS + let lookupNamePrefix prefix = + maybe (p_error $ Error_Namespace_prefix_unknown prefix) return $ + HM.lookup prefix scopeNS + elemName :: QName <- + -- NOTE: expand element's QName. + case pNameSpace n of + Nothing -> return QName{qNameSpace=defaultNS, qNameLocal=pNameLocal n} + -- DOC: If there is a default namespace declaration in scope, + -- the expanded name corresponding to an unprefixed element name + -- has the URI of the default namespace as its namespace name. + Just prefix + | NCName "xmlns" <- prefix -> + -- DOC: Element names MUST NOT have the prefix xmlns. + p_error $ Error_Namespace_reserved_prefix prefix + | otherwise -> do + ns <- lookupNamePrefix prefix + return QName{qNameSpace=ns, qNameLocal=pNameLocal n} + elemAttrs :: [FileSourced (QName, FileSourced EscapedText)] <- + -- NOTE: expand attributes' PName into QName. + forM as $ \s@Sourced{unSourced=(an, av)} -> do + ns <- maybe (return "") lookupNamePrefix $ pNameSpace an + let qn = QName{qNameSpace=ns, qNameLocal=pNameLocal an} + return s{unSourced=(qn, av)} + -- NOTE: check for attribute collision. + let attrsByQName :: HM.HashMap QName [FileSourced (QName, FileSourced EscapedText)] = + HM.fromListWith (<>) $ (<$> elemAttrs) $ \a@(Sourced _c (an, _av)) -> (an, [a]) + case HM.toList $ HM.filter (\x -> length x > 1) attrsByQName of + (an, _):_ -> p_error $ Error_Attribute_collision an + _ -> return () + elemAttrsXML :: XMLs <- (Seq.fromList <$>) $ + forM elemAttrs $ \(Sourced sa (an, av)) -> do + return $ TS.Tree (Sourced sa $ NodeAttr an) $ + pure $ TS.tree0 $ NodeText <$> av + content :: XMLs <- + elemAttrsXML <$ P.string "/>" <|> + R.local + (const ro + { reader_ns_scope = scopeNS + , reader_ns_default = defaultNS + }) + ((elemAttrsXML <>) <$ P.char '>' <*> p_content <* p_ETag elemName) + cell <- p_SourcedEnd + return $ Tree (cell $ NodeElem elemName) content + +-- *** Attribute +p_Attribute :: P.Tokens s ~ TL.Text => Parser Error s (FileSourced (PName, FileSourced EscapedText)) +p_Attribute = p_Sourced $ (,) <$> p_PName <* p_Eq <*> p_AttValue + +p_AttValue :: P.Tokens s ~ TL.Text => Parser Error s (FileSourced EscapedText) +p_AttValue = P.label "AttValue" $ p_quoted p_AttValueText + +p_AttValueText :: P.Tokens s ~ TL.Text => Char -> Parser Error s (FileSourced EscapedText) +p_AttValueText q = p_Sourced $ + EscapedText . Seq.fromList <$> P.many + ( p_Reference + <|> EscapedPlain <$> P.takeWhile1P Nothing (\c -> + XC.isXmlChar c && + c `List.notElem` (q:"<&'\">")) + <|> EscapedEntityRef entityRef_gt <$ P.char '>' + <|> (if q == '\'' + then EscapedEntityRef entityRef_quot <$ P.char '"' + else EscapedEntityRef entityRef_apos <$ P.char '\'') + ) + +-- * content +p_content :: P.Tokens s ~ TL.Text => Parser Error s XMLs +p_content = + (Seq.fromList <$>) $ P.many $ + (p_SourcedBegin $ do + P.try $ P.char '<' *> P.notFollowedBy (P.char '/') + p_Element_ <|> p_PI_ <|> (P.char '!' *> (p_Comment_ <|> p_CDSect_)) + ) + <|> ((tree0 <$>) $ p_Sourced $ NodeText . mconcat + <$> P.some (p_CharData <|> EscapedText . pure <$> p_Reference)) + +-- *** ETag +p_ETag :: P.Tokens s ~ TL.Text => QName -> Parser Error s () +p_ETag expected = do + got <- P.string " p_QName <* p_Spaces <* P.char '>' + unless (got == expected) $ + p_error $ Error_Closing_tag_unexpected got expected + +-- * Name +p_Name :: P.Tokens s ~ TL.Text => Parser Error s Name +p_Name = P.label "Name" $ + Name + <$ P.notFollowedBy (P.satisfy $ not . XC.isXmlNameStartChar) + <*> P.takeWhile1P Nothing XC.isXmlNameChar + +-- * PName +p_PName :: P.Tokens s ~ TL.Text => Parser e s PName +p_PName = P.label "PName" $ do + n <- p_NCName + s <- P.optional $ P.try $ P.char ':' *> p_NCName + return $ case s of + Nothing -> PName{pNameSpace=Nothing, pNameLocal=n} + Just l -> PName{pNameSpace=Just n , pNameLocal=l} + +-- * QName +p_QName :: P.Tokens s ~ TL.Text => Parser Error s QName +p_QName = P.label "QName" $ do + n <- p_NCName + s <- P.optional $ P.try $ P.char ':' *> p_NCName + Reader{..} <- R.ask + case s of + Nothing -> return QName{qNameSpace=reader_ns_default, qNameLocal=n} + Just l -> + case HM.lookup n reader_ns_scope of + Nothing -> p_error $ Error_Namespace_prefix_unknown n + Just ns -> return QName{qNameSpace=ns, qNameLocal=l} + +-- ** NCName +p_NCName :: P.Tokens s ~ TL.Text => Parser e s NCName +p_NCName = P.label "NCName" $ + NCName + <$ P.notFollowedBy (P.satisfy $ not . XC.isXmlNCNameStartChar) + <*> P.takeWhile1P Nothing XC.isXmlNCNameChar + +-- * Reference +p_Reference :: P.Tokens s ~ TL.Text => Parser Error s Escaped +p_Reference = + EscapedCharRef <$> p_CharRef <|> + EscapedEntityRef <$> p_EntityRef + +-- ** EntityRef +p_EntityRef :: P.Tokens s ~ TL.Text => Parser Error s EntityRef +p_EntityRef = P.label "EntityRef" $ do + ref <- P.char '&' *> p_NCName <* P.char ';' + EntityRef ref <$> lookupEntityRef ref + where + lookupEntityRef (NCName "lt" ) = pure "<" + lookupEntityRef (NCName "gt" ) = pure ">" + lookupEntityRef (NCName "amp" ) = pure "&" + lookupEntityRef (NCName "apos") = pure "'" + lookupEntityRef (NCName "quot") = pure "\"" + lookupEntityRef n = p_error $ Error_EntityRef_unknown n + +-- ** CharRef +p_CharRef :: P.Tokens s ~ TL.Text => Parser Error s CharRef +p_CharRef = P.label "CharRef" $ + do + ref <- readHexadecimal + <$ P.string "&#x" + <*> P.some P.hexDigitChar + <* P.char ';' + check ref + <|> do + ref <- readDecimal + <$ P.string "&#" + <*> P.some P.digitChar + <* P.char ';' + check ref + where + check i = + let c = toEnum (fromInteger i) in + if i <= toInteger (fromEnum (maxBound::Char)) + && XC.isXmlChar c + then pure $ CharRef c + else p_error $ Error_CharRef_invalid i + +readInt :: Integer -> String -> Integer +readInt base digits = + sign * List.foldl' acc 0 (List.concatMap digToInt digits1) + where + acc q r = q*base + r + (sign, digits1) = + case digits of + [] -> (1, digits) + c:ds | c == '-' -> (-1, ds) + | c == '+' -> ( 1, ds) + | otherwise -> ( 1, digits) + ord = toInteger . Char.ord + digToInt c + | Char.isDigit c = [ord c - ord '0'] + | Char.isAsciiLower c = [ord c - ord 'a' + 10] + | Char.isAsciiUpper c = [ord c - ord 'A' + 10] + | otherwise = [] + +readDecimal :: String -> Integer +readDecimal = readInt 10 + +readHexadecimal :: String -> Integer +readHexadecimal = readInt 16 + +-- * Char +p_Char :: P.Tokens s ~ TL.Text => Parser e s Char +p_Char = P.label "Char" $ P.satisfy XC.isXmlCharCR <|> p_CRLF +{-# INLINE p_Char #-} + +-- ** Space +-- | Map '\r' and '\r\n' to '\n'. +p_CRLF :: P.Tokens s ~ TL.Text => Parser e s Char +p_CRLF = P.label "CRLF" $ + P.char '\r' *> P.option '\n' (P.char '\n') + +p_Space :: P.Tokens s ~ TL.Text => Parser e s Char +p_Space = P.label "Space" $ + P.satisfy XC.isXmlSpaceCharCR <|> p_CRLF +{-# INLINE p_Space #-} + +p_Spaces :: P.Tokens s ~ TL.Text => Parser e s () +p_Spaces = P.label "Spaces" $ + void $ P.takeWhileP Nothing XC.isXmlSpaceChar +{-# INLINE p_Spaces #-} + +p_S :: P.Tokens s ~ TL.Text => Parser Error s XML +p_S = P.label "Spaces" $ + (\ts -> TS.tree0 (NodeText . EscapedText . pure . EscapedPlain . TL.concat <$> ts)) + <$> p_Sourced (P.some $ + P.takeWhile1P Nothing XC.isXmlSpaceCharCR <|> + TL.singleton <$> p_CRLF) + +p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s () +p_Spaces1 = P.label "Spaces1" $ + void $ P.takeWhile1P Nothing XC.isXmlSpaceChar +{-# INLINE p_Spaces1 #-} + +-- * Eq +p_separator :: P.Tokens s ~ TL.Text => Char -> Parser e s () +p_separator c = P.try (() <$ p_Spaces <* P.char c) <* p_Spaces [c] + +p_Eq :: P.Tokens s ~ TL.Text => Parser e s () +p_Eq = p_separator '=' "Eq" diff --git a/Symantic/XML/Read/Parser.hs b/Symantic/XML/Read/Parser.hs new file mode 100644 --- /dev/null +++ b/Symantic/XML/Read/Parser.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +module Symantic.XML.Read.Parser where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (Monad(..)) +import Data.Bool +import Data.Char (Char) +import Data.Default.Class (Default(..)) +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord(..)) +import Data.String (IsString) +import Prelude (Integer) +import Text.Show (Show(..)) +import qualified Control.Monad.Trans.Reader as R +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as Set +import qualified Data.Text.Lazy as TL +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P + +import Symantic.XML.Document hiding (XML, XMLs) +import qualified Symantic.XML.Document as XML + +-- | Specify |XML.XML|'s 'src' type parameter for parsing. +type XML = XML.XML (FileSource Offset) +-- | Specify |XML.XMLs|'s 'src' type parameter for parsing. +type XMLs = XML.XMLs (FileSource Offset) + +-- * Type 'Parser' +-- | Convenient alias. +type Parser e s a = + Parsable e s a => + R.ReaderT Reader (P.Parsec e s) a + +-- ** Type 'Parsable' +type Parsable e s a = + ( P.Stream s + , P.Token s ~ Char + , Ord e + , IsString (P.Tokens s) + , P.ShowErrorComponent e + ) + +-- ** Type 'Reader' +data Reader = Reader + { reader_source :: FileSource Offset + , reader_ns_scope :: HM.HashMap NCName Namespace + , reader_ns_default :: Namespace + } deriving (Show) +instance Default Reader where + def = Reader + { reader_source = pure def + , reader_ns_scope = HM.fromList + [ ("xml" , xmlns_xml) + , ("xmlns", xmlns_xmlns) + ] + , reader_ns_default = "" + } + +p_Offset :: Parser e s Offset +p_Offset = Offset <$> P.getOffset +{-# INLINE p_Offset #-} + +p_Sourced :: Parser e s a -> Parser e s (Sourced (FileSource Offset) a) +p_Sourced pa = do + Reader{reader_source} <- R.ask + b <- P.getParserState + let fileRange_file = P.sourceName $ P.pstateSourcePos $ P.statePosState b + let fileRange_begin = Offset $ P.stateOffset b + a <- pa + e <- P.getParserState + let fileRange_end = Offset $ P.stateOffset e + return $ Sourced (setSource FileRange{..} reader_source) a + +setSource :: FileRange pos -> FileSource pos -> FileSource pos +setSource fileRange (_curr:|next) = fileRange :| next + +-- | Like 'p_Sourced' but uncoupled (through the use of 'p_SourcedEnd') for more flexibility. +p_SourcedBegin :: Parser e s a -> Parser e s a +p_SourcedBegin pa = do + b <- P.getParserState + let fileRange_file = P.sourceName $ P.pstateSourcePos $ P.statePosState b + let fileRange_begin = Offset $ P.stateOffset b + let fileRange_end = fileRange_begin + (`R.local` pa) $ \ro@Reader{..} -> + ro{ reader_source = setSource FileRange{..} reader_source } + +-- | WARNING: Only to be used within a 'p_SourcedBegin'. +p_SourcedEnd :: Parser e s (a -> Sourced (FileSource Offset) a) +p_SourcedEnd = do + Reader{..} <- R.ask + e <- P.getParserState + let fileRange_end = Offset $ P.stateOffset e + return $ Sourced $ + (\(curr:|path) -> curr{fileRange_end}:|path) + reader_source + +{- +-- ** Type 'StreamSourced' +-- | Wrap 'TL.Text' to have a 'P.Stream' instance +-- whose 'P.advance1' method abuses the tab width state +-- to instead pass the line indent. +-- This in order to report correct 'P.SourcePos' +-- when parsing a 'Sourced' containing newlines. +newtype StreamSourced = StreamSourced { unStreamSourced :: TL.Text } + deriving (IsString,Eq,Ord) +instance P.Stream StreamSourced where + type Token StreamSourced = Char + type Tokens StreamSourced = TL.Text + take1_ (StreamSourced t) = (StreamSourced <$>) <$> P.take1_ t + takeN_ n (StreamSourced t) = (StreamSourced <$>) <$> P.takeN_ n t + takeWhile_ f (StreamSourced t) = StreamSourced <$> P.takeWhile_ f t + tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text) + chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text) + chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text) + {- + advance1 _s indent (P.SourcePos n line col) c = + case c of + '\n' -> P.SourcePos n (line <> P.pos1) indent + _ -> P.SourcePos n line (col <> P.pos1) + advanceN s indent = TL.foldl' (P.advance1 s indent) + -} + +-- | Wrapper around |P.runParser'| +-- to use given 'Sourced' as starting position. +runParserOnSourced :: + Parsable e StreamSourced a => + Parser e StreamSourced a -> + Sourced FileSource TL.Text -> + Either (P.ParseError (P.Token StreamSourced) e) a +runParserOnSourced p (Sourced (FileRange inp bp _ep :| path) s) = + snd $ + P.runParser' (R.runReaderT p ro <* P.eof) + P.State + { P.stateInput = StreamSourced s + , P.statePos = pure $ P.SourcePos inp (P.mkPos $ filePos_line bp) indent + , P.stateTabWidth = indent + , P.stateTokensProcessed = 0 + } + where + indent = P.mkPos $ filePos_column bp + ro = def{ reader_source = fromMaybe (pure def) $ nonEmpty path } +-} + +-- * Type 'Error' +data Error + = Error_CharRef_invalid Integer + -- ^ Well-formedness constraint: Legal Character. + -- + -- Characters referred to using character references MUST match the production for Char. + | Error_EntityRef_unknown NCName + -- ^ Well-formedness constraint: Entity Declared + -- + -- In a document without any DTD, a document with only an internal DTD + -- subset which contains no parameter entity references, or a document + -- with " standalone='yes' ", for an entity reference that does not occur + -- within the external subset or a parameter entity, the Name given in the + -- entity reference MUST match that in an entity declaration that does not + -- occur within the external subset or a parameter entity, except that + -- well-formed documents need not declare any of the following entities: + -- amp, lt, gt, apos, quot. The declaration of a general entity MUST + -- precede any reference to it which appears in a default value in an + -- attribute-list declaration. + -- + -- Note that non-validating processors are not obligated to read and + -- process entity declarations occurring in parameter entities or in the + -- external subset; for such documents, the rule that an entity must be + -- declared is a well-formedness constraint only if standalone='yes'. + | Error_Closing_tag_unexpected QName QName + -- ^ Well-formedness constraint: Element Type Match. + -- + -- The Name in an element's end-tag MUST match the element type in the start-tag. + | Error_Attribute_collision QName + -- ^ Well-formedness constraint: Unique Att Spec. + -- + -- An attribute name MUST NOT appear more than once in the same start-tag or empty-element tag. + | Error_PI_reserved PName + -- ^ The target names " XML ", " xml ", and so on are reserved for standardization. + | Error_Namespace_prefix_unknown NCName + -- ^ Namespace constraint: Prefix Declared + -- + -- The namespace prefix, unless it is xml or xmlns, MUST have been declared in a namespace declaration attribute in either the start-tag of the element where the prefix is used or in an ancestor element (i.e., an element in whose content the prefixed markup occurs). + | Error_Namespace_empty NCName + -- ^ Namespace constraint: No Prefix Undeclaring + -- + -- In a namespace declaration for a prefix (i.e., where the NSAttName is a PrefixedAttName), the attribute value MUST NOT be empty. + | Error_Namespace_reserved Namespace + | Error_Namespace_reserved_prefix NCName + -- ^ Namespace constraint: Reserved Prefixes and Namespace Names + -- + -- The prefix xml is by definition bound to the namespace name + -- http://www.w3.org/XML/1998/namespace. It MAY, but need not, be + -- declared, and MUST NOT be bound to any other namespace name. Other + -- prefixes MUST NOT be bound to this namespace name, and it MUST NOT be + -- declared as the default namespace. + -- + -- The prefix xmlns is used only to declare namespace bindings and is by + -- definition bound to the namespace name http://www.w3.org/2000/xmlns/. + -- It MUST NOT be declared . Other prefixes MUST NOT be bound to this + -- namespace name, and it MUST NOT be declared as the default namespace. + -- Element names MUST NOT have the prefix xmlns. + -- + -- All other prefixes beginning with the three-letter sequence x, m, l, in + -- any case combination, are reserved. This means that: + -- + -- - users SHOULD NOT use them except as defined by later specifications + -- - processors MUST NOT treat them as fatal errors. + deriving (Eq,Ord,Show) +instance P.ShowErrorComponent Error where + showErrorComponent = show + +-- * Helpers +p_error :: e -> Parser e s a +p_error = P.fancyFailure . Set.singleton . P.ErrorCustom + +p_quoted :: P.Tokens s ~ TL.Text => (Char -> Parser e s a) -> Parser e s a +p_quoted p = + P.between (P.char '"') (P.char '"') (p '"') <|> + P.between (P.char '\'') (P.char '\'') (p '\'') + +p_until :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text +p_until content (end, end_) = + (TL.concat <$>) $ P.many $ + P.takeWhile1P Nothing (\c -> content c && c /= end) <|> + P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) + +p_until1 :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text +p_until1 content (end, end_) = + (TL.concat <$>) $ P.some $ + P.takeWhile1P Nothing (\c -> content c && c /= end) <|> + P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) diff --git a/Symantic/XML/Write.hs b/Symantic/XML/Write.hs new file mode 100644 --- /dev/null +++ b/Symantic/XML/Write.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +module Symantic.XML.Write where + +import Control.Applicative (Applicative(..), liftA2) +import Control.Monad (Monad(..)) +import Data.Bool +import Data.Default.Class (Default(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), all) +import Data.Function (($), (.), const) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String, IsString(..)) +import Data.Traversable (Traversable(..)) +import System.IO (IO, FilePath) +import Text.Show (Show(..)) +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State as S +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Encoding as TL + +import Symantic.XML.Document as XML + +writeXML :: NoSource src => XMLs src -> TL.Text +writeXML xs = TLB.toLazyText $ write xs `R.runReader` def + +writeXMLIndented :: NoSource src => TL.Text -> XMLs src -> TL.Text +writeXMLIndented ind xs = + TLB.toLazyText $ + write xs `R.runReader` def + { reader_indent = if TL.null ind then mempty else "\n" + , reader_indent_delta = ind + } + +writeFile :: FilePath -> TL.Text -> IO () +writeFile fp t = BSL.writeFile fp $ TL.encodeUtf8 t + +-- * Type 'Write' +type Write = R.Reader Reader TLB.Builder +instance Semigroup Write where + (<>) = liftA2 (<>) +instance Monoid Write where + mempty = return "" + mappend = (<>) +instance IsString Write where + fromString = return . fromString + +-- ** Type 'Reader' +data Reader = Reader + { reader_ns_scope :: Namespaces NCName + , reader_indent :: TLB.Builder + , reader_indent_delta :: TL.Text + , reader_no_text :: Bool + } +instance Default Reader where + def = Reader + { reader_ns_scope = def + , reader_indent = "" + , reader_indent_delta = "" + , reader_no_text = False + } + +-- * Class 'Buildable' +class Buildable a where + build :: a -> TLB.Builder +instance Buildable Char.Char where + build = TLB.singleton +instance Buildable String where + build = TLB.fromString +instance Buildable TL.Text where + build = TLB.fromLazyText +instance Buildable NCName where + build = build . unNCName +instance Buildable Name where + build = build . unName +instance Buildable PName where + build PName{..} = + case pNameSpace of + Nothing -> build pNameLocal + Just p -> build p<>":"<> build pNameLocal +instance Buildable Namespace where + build = build . unNamespace +instance Buildable EntityRef where + build EntityRef{..} = "&"<>build entityRef_name<>";" +instance Buildable CharRef where + build (CharRef c) = "&#"<>build (show (Char.ord c))<>";" +instance Buildable EscapedText where + build (EscapedText et) = (`foldMap` et) $ \case + EscapedPlain t -> build t + EscapedEntityRef r -> build r + EscapedCharRef r -> build r + +-- * Class 'Writable' +class Writeable a where + write :: a -> Write +instance Writeable NCName where + write = return . TLB.fromLazyText . unNCName +instance NoSource src => Writeable (XMLs src) where + write xs = do + ro <- R.ask + if TL.null (reader_indent_delta ro) + then foldMap write xs + else + R.local (const ro{reader_no_text}) $ + foldMap write xs + where reader_no_text = + (`all` xs) $ \case + Tree (Sourced _ (NodeText (EscapedText et))) _ts -> + all (\case + EscapedPlain t -> TL.all Char.isSpace t + _ -> False) et + _ -> True +instance NoSource src => Writeable (XML src) where + write (Tree (Sourced _src nod) xs) = do + ro <- R.ask + case nod of + NodeAttr an + | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do + return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av + | otherwise -> mempty + NodeCDATA t -> + return $ + reader_indent ro <> + "<[CDATA[["<>build t<>"]]>" + NodeComment t -> + return $ + reader_indent ro <> + "" + NodeElem elemQName -> do + let (elemAttrs, elemChilds) = + (`Seq.spanl` xs) $ \case + Tree (Sourced _ NodeAttr{}) _ -> True + _ -> False + let (usedNS, declNS) :: + ( HS.HashSet Namespace + , Namespaces NCName + ) = + foldl' go (initUsedNS, initDeclNS) elemAttrs + where + initUsedNS + | qNameSpace elemQName == xmlns_empty = mempty + | otherwise = HS.singleton $ qNameSpace elemQName + initDeclNS = def{namespaces_default = namespaces_default $ reader_ns_scope ro} + go (!uNS, !dNS) = \case + Tree (Sourced _ (NodeAttr QName{..})) vs + -- xmlns:prefix="namespace" + | qNameSpace == xmlns_xmlns + , [Tree (Sourced _ (NodeText t)) _] <- toList vs -> + let n = unescapeText t in + (uNS,) dNS + { namespaces_prefixes = + (if TL.null n + then HM.delete + -- NOTE: empty namespace means removal of the prefix from scope. + else (`HM.insert` qNameLocal)) + (Namespace n) + (namespaces_prefixes dNS) + } + -- xmlns="namespace" + | qNameSpace == xmlns_empty + , qNameLocal == NCName "xmlns" + , [Tree (Sourced _ (NodeText t)) _] <- toList vs -> + (uNS,) + dNS{namespaces_default = Namespace $ unescapeText t} + -- name="value" + | qNameSpace == xmlns_empty -> (uNS, dNS) + -- {namespace}name="value" + | otherwise -> (HS.insert qNameSpace uNS, dNS) + _ -> (uNS, dNS) + let inhNS = + -- NOTE: the inherited namespaces, + -- including those declared at this element. + HM.union + (namespaces_prefixes declNS) + (namespaces_prefixes (reader_ns_scope ro)) + let autoNS = + -- NOTE: the namespaces used but not declared nor default, + -- with fresh prefixes. + HM.delete (namespaces_default declNS) $ + (`S.evalState` HS.empty) $ + traverse + (\() -> S.gets freshNCName) + (HS.toMap usedNS `HM.difference` inhNS) + let autoAttrs = + -- NOTE: XMLify autoNS + HM.foldlWithKey' + (\acc (Namespace v) p -> + (acc Seq.|>) $ + Tree (notSourced $ NodeAttr QName{qNameSpace=xmlns_xmlns, qNameLocal=p}) $ + pure $ tree0 $ notSourced $ NodeText $ EscapedText $ pure $ EscapedPlain v + ) mempty autoNS + let scopeNS = declNS { namespaces_prefixes = autoNS <> inhNS } + return $ + let build_elemPName = build $ prefixifyQName scopeNS elemQName in + let build_elemAttrs = + (`foldMap` (autoAttrs <> elemAttrs)) $ \case + Tree (Sourced _ (NodeAttr an)) vs + | [Tree (Sourced _ (NodeText av)) _] <- toList vs -> + " "<>buildAttr (prefixifyQName scopeNS{namespaces_default=""} an) av + _ -> mempty in + reader_indent ro + <> "<"<>build_elemPName + <> build_elemAttrs <> + let build_elemChilds = write elemChilds + `R.runReader` ro + { reader_ns_scope = scopeNS + , reader_indent = reader_indent ro <> build (reader_indent_delta ro) + } in + if null elemChilds + then "/>" + else ">" + <> build_elemChilds + <> ( + if TL.null (reader_indent_delta ro) + || noIndent elemChilds + then mempty + else reader_indent ro + ) + <> "build_elemPName<>">" + where + noIndent = + all $ \case + Tree (Sourced _ (NodeText _txt)) _ts -> True + _ -> False + NodePI pn pv + | pn == "xml" -> do + write_xs <- write xs + return $ + "build pn<>s<>write_xs<>"?>" + | otherwise -> + return $ + reader_indent ro <> + "build pn<>s<>build pv<>"?>" + where s | TL.null pv = "" + | otherwise = " " + NodeText t -> do + return $ + if reader_no_text ro + then mempty + else build t + +buildAttr :: PName -> EscapedText -> TLB.Builder +buildAttr n v = build n<>"=\""<>buildAttrValue v<>"\"" + +buildAttrValue :: EscapedText -> TLB.Builder +buildAttrValue (EscapedText et) = (`foldMap` et) $ \case + EscapedPlain p -> build p + EscapedEntityRef EntityRef{..} -> + build $ TL.replace "\"" """ entityRef_value + EscapedCharRef (CharRef c) + | c == '\"' -> """ + | otherwise -> build c + +removeSpaces :: XMLs src -> XMLs src +removeSpaces xs = + if (`all` xs) $ \case + Tree (Sourced _ (NodeText (EscapedText et))) _ts -> + all (\case + EscapedPlain t -> TL.all Char.isSpace t + _ -> False) et + _ -> True + then (`Seq.filter` xs) $ \case + Tree (Sourced _ NodeText{}) _ts -> False + _ -> True + else xs diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,9 @@ +resolver: lts-13.19 +packages: +- '.' +- location: '../treeseq' + extra-dep: true +- location: '../symantic/symantic-grammar' + extra-dep: true +extra-deps: +- megaparsec-7.0.4@sha256:a7397151601cbe6b8f831f8bdad1a10118dcd6d9a7ee50d6bbdcfbd1181b4ba2 diff --git a/symantic-xml.cabal b/symantic-xml.cabal new file mode 100644 --- /dev/null +++ b/symantic-xml.cabal @@ -0,0 +1,131 @@ +name: symantic-xml +-- PVP: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.0.0.20190223 +category: Data Structures +synopsis: Library for reading, validating and writing a subset of the XML format. +description: Symantics for an approximative implementation + of XML (eXtensible Markup Language) and RNC (RelaxNG Compact). + . + Motivation: Other Haskell libraries do not fit my needs or are too heavy/complex. + I like the principle to parse XML using some symantics, + which can both generate a Megaparsec parser to validate the XML tree, + and a RNC rendition of the schema it validates. + . + DISCLAMER: My life being's too short, I'm NOT burning my brain + on seriously conforming to the too complex XML and RNC formats. + Still I try to respect a vague subset of those, + unless it makes the code more complex than I am comfortable with. + . + WARNING: It's currently using an old symantic approach, + not the one developped in . + This may change when I'll get to it. +extra-doc-files: +license: GPL-3 +license-file: COPYING +stability: experimental +author: Julien Moutinho +maintainer: Julien Moutinho +bug-reports: Julien Moutinho +-- homepage: + +build-type: Simple +cabal-version: 1.24 +tested-with: GHC==8.6.4 +extra-source-files: + stack.yaml +extra-tmp-files: + +Source-Repository head + location: git://git.autogeree.net/symantic-xml + type: git + +Library + exposed-modules: + Symantic.RNC + Symantic.RNC.Sym + Symantic.RNC.Validate + Symantic.RNC.Write + Symantic.RNC.Write.Fixity + Symantic.RNC.Write.Namespaces + Symantic.XML + Symantic.XML.Document + Symantic.XML.Read + Symantic.XML.Read.Parser + Symantic.XML.Write + default-language: Haskell2010 + default-extensions: + FlexibleContexts + FlexibleInstances + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + RecordWildCards + ScopedTypeVariables + TupleSections + -- TypeFamilies + ghc-options: + -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -fno-warn-tabs + -- -fhide-source-paths + build-depends: + base >= 4.10 && < 5 + , bytestring >= 0.10 + , containers >= 0.5 + , data-default-class >= 0.1 + , filepath >= 1.4 + , hashable >= 1.2.6 + , hxt-charproperties >= 9.2 + , megaparsec >= 7.0.4 + -- , parser-combinators >= 1.0 + , safe >= 0.3 + , text >= 1.2 + , transformers >= 0.5 + , treeseq >= 1.0 + , unordered-containers >= 0.2.8 + +Test-Suite symantic-xml-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + RNC.Parser + RNC.Commoning + Golden + -- HUnit + -- QuickCheck + default-language: Haskell2010 + default-extensions: + LambdaCase + NamedFieldPuns + NoImplicitPrelude + RecordWildCards + ViewPatterns + ghc-options: + -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -fno-warn-tabs + -fhide-source-paths + build-depends: + symantic-xml + , base >= 4.10 && < 5 + , bytestring >= 0.10 + , containers >= 0.5 + , data-default-class >= 0.1 + , deepseq >= 1.4 + , filepath >= 1.4 + , hashable >= 1.2.6 + , megaparsec >= 7.0.4 + , tasty >= 0.11 + , tasty-golden >= 2.3 + , text >= 1.2 + , transformers >= 0.4 + , treeseq >= 1.0 + -- , QuickCheck >= 2.0 + -- , tasty-hunit + -- , tasty-quickcheck diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Golden where + +import Control.Arrow (left) +import Control.Monad (Monad(..), sequence) +import Data.Bool +import Data.Either (Either(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import Data.Void (Void) +import System.FilePath (FilePath) +import System.IO (IO) +import Text.Show (Show(..)) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Text.Megaparsec as P +import qualified Data.TreeSeq.Strict as TS + +import Test.Tasty +import Test.Tasty.Golden + +import Symantic.XML.Read.Parser (XMLs) +import qualified Symantic.XML as XML +import qualified Symantic.RNC as RNC +import RNC.Parser () +import qualified RNC.Commoning + +-- * Golden testing utilities +testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree +testGolden inputFile expectedExt = + goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt) + . (>>= unLeft) + +diffGolden :: FilePath -> FilePath -> [String] +diffGolden ref new = ["diff", "-u", ref, new] + +unLeft :: Either String BSL.ByteString -> IO BSL.ByteString +unLeft = \case + Left err -> return $ TL.encodeUtf8 $ TL.pack err + Right a -> return a + +goldensIO :: IO TestTree +goldensIO = + testGroup "Golden" <$> + sequence + [ goldensXML + , goldensRNC + ] + +goldensXML :: IO TestTree +goldensXML = do + inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML" + return $ testGroup "XML" + [ testGroup "Read" + [ testGolden inputFile ".read" $ + readXML inputFile >>= \ast -> + return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast + | inputFile <- inputFiles + ] + , testGroup "Write" $ List.concat + [ + [ testGolden inputFile ".write" $ + readXML inputFile >>= \ast -> + return $ TL.encodeUtf8 . XML.writeXML <$> ast + , testGolden inputFile ".write.indented" $ + readXML inputFile >>= \ast -> + return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack " ") <$> ast + ] + | inputFile <- inputFiles + , not $ List.isInfixOf "/Error/" inputFile + ] + ] + +readXML :: FilePath -> IO (Either String XMLs) +readXML inputFile = + XML.readFile inputFile >>= \case + Left err -> return $ Left $ show err + Right input -> + return $ left P.errorBundlePretty $ + XML.readXML inputFile input + +goldensRNC :: IO TestTree +goldensRNC = do + inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC" + return $ testGroup "RNC" + [ testGroup "Validate" + [ testGolden inputFile ".read" $ + validateXML inputFile RNC.Commoning.commoning >>= \a -> + return $ TL.encodeUtf8 . TL.pack . show <$> a + | inputFile <- inputFiles + , List.isInfixOf "/Commoning/" inputFile + ] + ] + +validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a) +validateXML inputFile rnc = + (<$> readXML inputFile) $ \case + Left err -> Left err + Right xml -> do + case RNC.validateXML rnc xml of + Right a -> Right a + Left err -> + Left $ List.unlines $ toList $ + P.parseErrorTextPretty <$> P.bundleErrors err diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +module Main where + +import System.IO (IO) +import Data.Function (($)) + +import Test.Tasty +import Golden + +main :: IO () +main = do + goldens <- goldensIO + defaultMain $ + testGroup "Symantic" + [ goldens + ] diff --git a/test/RNC/Commoning.hs b/test/RNC/Commoning.hs new file mode 100644 --- /dev/null +++ b/test/RNC/Commoning.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StrictData #-} +module RNC.Commoning where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (Monad, void) +import Data.Default.Class (Default(..)) +import Data.Eq (Eq) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Hashable (Hashable) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord) +import Data.Sequence (Seq) +import Text.Show (Show) +import qualified Data.Text.Lazy as TL +import qualified Data.TreeSeq.Strict as TS +import qualified Text.Megaparsec as P + +import Symantic.RNC (Sym_Permutation(..)) +import qualified Symantic.RNC as RNC +import qualified Symantic.XML as XML + +import RNC.Parser + +-- * Type 'Commoning' +data Commoning = Commoning + { commoning_persons :: Persons + , commoning_opinions :: Opinions + , commoning_groups :: Groups + , commoning_operations :: Operations + , commoning_resources :: Resources + } deriving (Show) + +-- ** Type 'Person' +data Person = Person + { person_id :: Ident + , person_fields :: Seq Fields + } deriving (Show) +-- *** Type 'Persons' +type Persons = [Person] + +-- ** Type 'Group' +type Group = TS.Tree NodeGroup +-- *** Type 'NodeGroup' +data NodeGroup = NodeGroup + { group_id :: Ident + , group_name :: Maybe Name + , group_fields :: Seq Fields + , group_members :: Members + } deriving (Show) +-- *** Type 'Groups' +type Groups = Seq Group + +-- ** Type 'Member' +newtype Member = Member + { member_person :: Ident + } deriving (Show) +-- *** Type 'Members' +type Members = [Member] + +-- ** Type 'Resource' +type Resource = TS.Tree NodeResource +-- *** Type 'NodeResource' +data NodeResource = NodeResource + { resource_name :: Name + , resource_policies :: Policies + } deriving (Show) +-- *** Type 'Resources' +type Resources = Seq Resource + +-- ** Type 'Policy' +data Policy = Policy + { policy_operation :: Name + , policy_by :: Ident + , policy_toward :: (Maybe Ident) + , policy_rules :: Rules + } deriving (Show) +-- *** Type 'Policies' +type Policies = [Policy] + +-- ** Type 'Rule' +data Rule = Rule + { rule_grades :: Ident + , rule_gradeRange :: GradeRange + } deriving (Show) +-- *** Type 'Rules' +type Rules = [Rule] + +-- *** Type 'GradeRange' +data GradeRange + = GradeRange_Single Name + | GradeRange_Min Name + | GradeRange_Max Name + | GradeRange Name Name + deriving (Show) + +-- * Type 'Opinions' +type Opinions = [Grades] + +-- ** Type 'Grade' +data Grade = Grade + { grade_name :: Name + , grade_abbrev :: Maybe Name + , grade_color :: Maybe Color + } deriving (Show) +-- *** Type 'Grades' +data Grades = Grades + { grades_id :: Ident + , grades_name :: Maybe Name + , grades_list :: [Grade] + } deriving (Show) +-- *** Type 'Color' +type Color = TL.Text + +-- ** Type 'Operation' +type Operation = TS.Tree NodeOperation +-- *** Type 'NodeOperation' +newtype NodeOperation = NodeOperation + { operation_id :: Ident + } deriving (Show) +-- *** Type 'Operations' +type Operations = Seq Operation + +-- ** Type 'Field' +data Field = Field + { field_name :: Name + , field_value :: TL.Text + } deriving (Show) +-- *** Type 'Fields' +type Fields = TS.Tree NodeField +-- **** Type 'NodeField' +data NodeField + = NodeField Field + | NodeFields { fields_name :: Name } + deriving (Show) + +-- * Type 'Ident' +newtype Ident = Ident TL.Text + deriving (Eq,Ord,Show,Hashable) +-- * Type 'Name' +newtype Name = Name TL.Text + deriving (Eq,Ord,Show,Hashable) + +-- * Class 'Sym_Commoning' +xmlns_commoning :: XML.Namespace +xmlns_commoning = "http://commonsoft.org/xml/2018/commoning.rnc" +element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a +element = RNC.element . XML.QName xmlns_commoning +attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a +attribute = RNC.attribute . XML.QName "" + +class RNC.Sym_RNC repr => Sym_Commoning repr where + commoning :: repr Commoning + persons :: repr Persons + person :: repr Person + opinions :: repr Opinions + grades :: repr Grades + grade :: repr Grade + fields :: repr Fields + field :: repr Field + groups :: repr Groups + group :: repr Group + members :: repr Members + member :: repr Member + operations :: repr Operations + operation :: repr Operation + resources :: repr Resources + resource :: repr Resource + policy :: repr Policy + rule :: repr Rule + ident :: repr Ident + name :: repr Name + color :: repr Color + + commoning = RNC.rule "commoning" $ + element "commoning" $ + runPermutation $ + Commoning + <$$> persons + <||> opinions + <||> groups + <||> operations + <||> resources + persons = RNC.rule "persons" $ + element "persons" $ RNC.many person + person = RNC.rule "person" $ + element "person" $ attrs <*> RNC.manySeq fields + where + attrs = + runPermutation $ + Person + <$$> attribute "id" ident + opinions = RNC.rule "opinions" $ + element "opinions" $ + RNC.many grades + grades = RNC.rule "grades" $ + element "grades" $ attrs <*> RNC.many grade + where + attrs = + runPermutation $ + Grades + <$$> attribute "id" ident + <|?> (def, Just <$> attribute "name" name) + grade = RNC.rule "grade" $ + element "grade" $ attrs + where + attrs = + runPermutation $ + Grade + <$$> attribute "name" name + <|?> (def, Just <$> attribute "abbrev" name) + <|?> (def, Just <$> attribute "color" color) + fields = RNC.rule "fields" $ + element "fields" $ + (TS.Tree <$> attrs <*>) $ + RNC.manySeq $ + TS.tree0 . NodeField <$> field + <|> fields + where + attrs = + runPermutation $ + NodeFields + <$$> attribute "name" name + field = RNC.rule "field" $ + element "field" $ attrs <*> RNC.text + where + attrs = + runPermutation $ + Field + <$$> attribute "name" name + groups = RNC.rule "groups" $ + element "groups" $ RNC.manySeq group + group = RNC.rule "group" $ + element "group" $ + (((TS.Tree <$>) $ attrs <*> RNC.manySeq fields <*> members) <*>) $ + RNC.manySeq group + where + attrs = + runPermutation $ + NodeGroup + <$$> attribute "id" ident + <|?> (def, Just <$> attribute "name" name) + members = RNC.rule "members" $ RNC.many member + member = RNC.rule "member" $ + element "member" $ attrs + where + attrs = + runPermutation $ + Member + <$$> attribute "person" ident + operations = RNC.rule "operations" $ + element "operations" $ RNC.manySeq operation + operation = RNC.rule "operation" $ + element "operation" $ + (((TS.Tree <$>) $ attrs) <*>) $ + RNC.manySeq operation + where + attrs = + runPermutation $ + NodeOperation + <$$> attribute "id" ident + resources = RNC.rule "resources" $ + element "resources" $ RNC.manySeq resource + resource = RNC.rule "resource" $ + element "resource" $ + (((TS.Tree <$>) $ attrs <*> RNC.many policy) <*>) $ + RNC.manySeq resource + where + attrs = + runPermutation $ + NodeResource + <$$> attribute "name" name + policy = RNC.rule "policy" $ + element "policy" $ attrs + where + attrs = + runPermutation $ + Policy + <$$> attribute "operation" name + <||> attribute "by" ident + <|?> (def, Just <$> attribute "toward" ident) + <|*> rule + rule = RNC.rule "rule" $ + element "rule" $ attrs + where + attrs + = RNC.try attrsGrade + <|> RNC.try attrsGradeMin + <|> attrsGradeMax + attrsGrade = + runPermutation $ + Rule + <$$> attribute "grades" ident + <||> (GradeRange_Single <$> attribute "grade" name) + attrsGradeMin = + runPermutation $ + (\gs gMin mgMax -> Rule gs $ case mgMax of + Nothing -> GradeRange_Min gMin + Just gMax -> GradeRange gMin gMax) + <$$> attribute "grades" ident + <||> attribute "gradeMin" name + <|?> (def, Just <$> attribute "gradeMax" name) + attrsGradeMax = + runPermutation $ + (\gs mgMin gMax -> Rule gs $ case mgMin of + Nothing -> GradeRange_Max gMax + Just gMin -> GradeRange gMin gMax) + <$$> attribute "grades" ident + <|?> (def, Just <$> attribute "gradeMin" name) + <||> attribute "gradeMax" name + + ident = RNC.rule "ident" $ Ident <$> RNC.text + name = RNC.rule "name" $ Name <$> RNC.text + color = RNC.rule "color" $ RNC.text +instance Sym_Commoning RNC.NS +instance Sym_Commoning RNC.Writer +instance + ( Ord err + , Ord src + , XML.NoSource src + ) => Sym_Commoning (P.Parsec err (XML.XMLs src)) + +-- newtype Forall cl a = Forall { unForall :: forall repr. cl repr => repr a } +rnc :: forall repr. Sym_Commoning repr => [repr ()] +rnc = + [ void $ RNC.namespace Nothing xmlns_commoning + , void $ commoning + , void $ persons + , void $ person + , void $ opinions + , void $ grades + , void $ grade + , void $ fields + , void $ field + , void $ groups + , void $ group + , void $ members + , void $ member + , void $ resources + , void $ resource + , void $ policy + , void $ rule + , void $ ident + , void $ name + , void $ color + ] diff --git a/test/RNC/Parser.hs b/test/RNC/Parser.hs new file mode 100644 --- /dev/null +++ b/test/RNC/Parser.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module RNC.Parser where + +import Control.Applicative (Applicative(..)) +import Control.Monad (Monad(..)) +import Data.Bool +import Data.Either (Either(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (ViewL(..)) +import Prelude (error) +import Text.Show (Show(..)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Sequence as Seq +import qualified Text.Megaparsec as P + +import Symantic.XML.Document (XML, XMLs) +import qualified Symantic.XML.Document as XML +import qualified Symantic.RNC.Validate as RNC + +instance Ord src => P.Stream (XMLs src) where + type Token (XMLs src) = XML src + type Tokens (XMLs src) = XMLs src + take1_ s = + case Seq.viewl s of + EmptyL -> Nothing + t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts + | RNC.isIgnoredNode n -> P.take1_ ts + | otherwise -> Just (t, ts) + takeN_ n s | n <= 0 = Just (mempty, s) + | null s = Nothing + | otherwise = + let (ns,rs) = Seq.splitAt n s in + let (ko,ok) = Seq.partition (RNC.isIgnoredNode . XML.unSourced . XML.unTree) ns in + case P.takeN_ (Seq.length ko) rs of + Nothing -> Just (ok, rs) + Just (ns',rs') -> Just (ok<>ns', rs') + tokensToChunk _s = Seq.fromList + chunkToTokens _s = toList + chunkLength _s = Seq.length + takeWhile_ = Seq.spanl + -- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'. + reachOffset = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations" + -- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'. + reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations" + showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks + where + showTree (XML.Tree (XML.Sourced _src a) _ts) = + case a of + XML.NodeElem n -> "element "<>show n<>"" + XML.NodeAttr n -> "attribute "<>show n<>"" + XML.NodeText _t -> "text" + XML.NodeComment _c -> "comment" + XML.NodePI n _t -> "processing-instruction "<>show n<>"" + XML.NodeCDATA _t -> "cdata"