diff --git a/COPYING.GPL b/COPYING.GPL new file mode 100644 --- /dev/null +++ b/COPYING.GPL @@ -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/COPYING.LGPL b/COPYING.LGPL new file mode 100644 --- /dev/null +++ b/COPYING.LGPL @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain + diff --git a/Text/GrammarCombinators/Base.hs b/Text/GrammarCombinators/Base.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base.hs @@ -0,0 +1,34 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +module Text.GrammarCombinators.Base ( + module Text.GrammarCombinators.Base.Domain, + module Text.GrammarCombinators.Base.Grammar, + module Text.GrammarCombinators.Base.Processor, + module Text.GrammarCombinators.Base.ProductionRule, + module Text.GrammarCombinators.Base.MultiRec, + module Text.GrammarCombinators.Base.Token + ) where + +import Text.GrammarCombinators.Base.Domain +import Text.GrammarCombinators.Base.Grammar +import Text.GrammarCombinators.Base.Processor +import Text.GrammarCombinators.Base.ProductionRule +import Text.GrammarCombinators.Base.MultiRec hiding (cast) +import Text.GrammarCombinators.Base.Token diff --git a/Text/GrammarCombinators/Base/Domain.hs b/Text/GrammarCombinators/Base/Domain.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/Domain.hs @@ -0,0 +1,132 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Text.GrammarCombinators.Base.Domain ( + DomainMap(supIx, subIx), + DomainEmbedding(supPF), + SubVal(MkSubVal, unSubVal), + IxMapId, IxMapBase, IxMapSeq, ApplyIxMap, + MemoFam(toMemo, fromMemo), Memo, memoFamily, + FoldFam(foldFam), + EqFam(overrideIdx, eqIdx), overrideIdxK, + ShowFam(showIdx), + Domain, + memoFamilyK, toMemoK, fromMemoK, + LiftFam(liftIdxE, liftIdxP) + ) where + +import Generics.MultiRec.Base +import Generics.MultiRec.HFunctor + +import Language.Haskell.TH.Syntax (Exp, Pat) + +data IxMapId +data IxMapBase (m :: * -> *) +data IxMapSeq (l1 :: *) (l2 :: * -> *) +type family ApplyIxMap (m :: *) ix +type instance ApplyIxMap (IxMapBase m) ix = m ix +type instance ApplyIxMap (IxMapSeq l1 l2) ix = ApplyIxMap l1 (l2 ix) +type instance ApplyIxMap IxMapId ix = ix + +class MemoFam (phi :: * -> *) where + data Memo phi :: (* -> *) -> * + fromMemo :: Memo phi v -> (forall ix. phi ix -> v ix) + toMemo :: (forall ix. phi ix -> v ix) -> Memo phi v + +memoFamily :: (MemoFam phi) => + (forall ix. phi ix -> v ix) -> (forall ix. phi ix -> v ix) +memoFamily f = fromMemo (toMemo f) + +memoFamilyK :: (MemoFam phi) => + (forall ix. phi ix -> v) -> (forall ix. phi ix -> v) +memoFamilyK f = fromMemoK (toMemoK f) +toMemoK :: (MemoFam phi) => + (forall ix. phi ix -> v) -> Memo phi (K0 v) +toMemoK f = toMemo (K0 . f) +fromMemoK :: (MemoFam phi) => + Memo phi (K0 v) -> phi ix -> v +fromMemoK m = unK0 . fromMemo m + +-- | A domain 'phi' that is an instance of the 'FoldFam' type class supports +-- folding over all non-terminals in the domain using the 'foldFam' function. +class FoldFam phi where + -- | Fold a given function over all non-terminals in the domain 'phi'. + foldFam :: (forall ix. phi ix -> b -> b) -> b -> b + +-- | A domain 'phi' that is an instance of the 'ShowFam' type class supports +-- conversion of non-terminal proof terms to Strings using the 'showIdx' function. +class ShowFam phi where + -- | Convert a given non-terminal proof term to a String representation. + showIdx :: forall ix. phi ix -> String + +-- | A domain 'phi' that is an instance of the 'EqFam' type class supports +-- overriding a function over the full domain at a single non-terminal using +-- the |overrideIdx| function. +class EqFam phi where + -- | Test equality of two given non-terminal proof terms. + eqIdx :: forall ix1 ix2. phi ix1 -> phi ix2 -> Bool + eqIdx idx1 = overrideIdxK (const False) idx1 True + -- | Override a function over the full domain at a single non-terminal. + overrideIdx :: (forall ix'. phi ix' -> r ix') -> phi oix -> + r oix -> phi ix -> r ix + +-- | Similar to the 'overrideIdx' function, but limited to functions whose result type is +-- the same for all non-terminals. +overrideIdxK :: (EqFam phi) => (forall ix'. phi ix' -> v) -> phi oix -> v -> phi ix -> v +overrideIdxK f idx v = unK0 . overrideIdx (K0 . f) idx (K0 v) + +-- | A decent Domain 'phi' should instantiate the 'FoldFam', 'ShowFam', 'EqFam' and 'MemoFam'. Avoid +-- using this type class in constraints, use more specific type classes whenever possible. +-- +-- Note: instances for this type class are not automatically derived, and you have to manually instantiate +-- it with an empty implementation block. +class (FoldFam phi, + ShowFam phi, + EqFam phi, + MemoFam phi) => Domain phi + +class DomainMap phi phi' supIxT where + supIx :: phi' ix -> phi (supIxT ix) + subIx :: phi (supIxT ix) -> phi' ix + +class (DomainMap phi phi' supIxT) => + DomainEmbedding phi phi' supIxT where + supPF :: (HFunctor phi (PF phi)) => + phi' ix -> phi (supIxT ix) -> + PF phi' (SubVal supIxT r) ix -> PF phi r (supIxT ix) + +-- | A generic wrapper type that restricts a semantic value family over a bigger domain +-- to a smaller domain. +data SubVal (supIxT :: * -> *) v ix = MkSubVal { + unSubVal :: v (supIxT ix) + } deriving (Show) + +class LiftFam phi where + liftIdxE :: phi ix -> Exp + liftIdxP :: phi ix -> Pat diff --git a/Text/GrammarCombinators/Base/Grammar.hs b/Text/GrammarCombinators/Base/Grammar.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/Grammar.hs @@ -0,0 +1,70 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Base.Grammar where + +import Text.GrammarCombinators.Base.ProductionRule +import Text.GrammarCombinators.Base.MultiRec + +type RegularRule phi r t v = + forall p. (ProductionRule p, EpsProductionRule p, TokenProductionRule p t) => + p v + +type ContextFreeRule phi r t v = + forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) => + p v + +type ExtendedContextFreeRule phi r t v = + forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r) => + p v + +type LiftableContextFreeRule phi r t v = + forall p. (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) => + p v + +type ExtendedLiftableContextFreeRule phi r t v = + forall p. (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r) => + p v + +type GGrammar rt phi t r rr = + forall ix. phi ix -> rt phi r t (rr ix) +type AGrammar rt phi t = forall r. GGrammar rt phi t r (PF phi r) +type PGrammar rt phi t r = GGrammar rt phi t r r + +type GRegularGrammar phi t r rr = GGrammar RegularRule phi t r rr +type GContextFreeGrammar phi t r rr = GGrammar ContextFreeRule phi t r rr +type GLContextFreeGrammar phi t r rr = GGrammar LiftableContextFreeRule phi t r rr +type GExtendedContextFreeGrammar phi t r rr = GGrammar ExtendedContextFreeRule phi t r rr +type GLExtendedContextFreeGrammar phi t r rr = GGrammar ExtendedLiftableContextFreeRule phi t r rr + +type ContextFreeGrammar phi t = AGrammar ContextFreeRule phi t +type LContextFreeGrammar phi t = AGrammar LiftableContextFreeRule phi t +type ExtendedContextFreeGrammar phi t = AGrammar ExtendedContextFreeRule phi t +type LExtendedContextFreeGrammar phi t = AGrammar ExtendedLiftableContextFreeRule phi t + +type ProcessingRegularGrammar phi t r = PGrammar RegularRule phi t r +type ProcessingContextFreeGrammar phi t r = PGrammar ContextFreeRule phi t r +type ProcessingLContextFreeGrammar phi t r = PGrammar LiftableContextFreeRule phi t r +type ProcessingExtendedContextFreeGrammar phi t r = PGrammar ExtendedContextFreeRule phi t r +type ProcessingLExtendedContextFreeGrammar phi t r = PGrammar ExtendedLiftableContextFreeRule phi t r diff --git a/Text/GrammarCombinators/Base/MultiRec.hs b/Text/GrammarCombinators/Base/MultiRec.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/MultiRec.hs @@ -0,0 +1,86 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Base.MultiRec( + module Generics.MultiRec.Base, + module Generics.MultiRec.HFunctor, + IL(IL, unIL), + SubPF(SubPF) + ) where + +import Text.GrammarCombinators.Base.Domain + +import Control.Applicative + +import Generics.MultiRec.Base +import Generics.MultiRec.HFunctor + +-- Similar to MultiRec's I type functor, but represents a list of elements +-- of the given type instead of a single value +data IL xi r ix = IL { + unIL :: [r xi] + } + +instance (El phi xi) => HFunctor phi (IL xi) where + hmapA = hmapAIL + +hmapAIL :: forall phi a r r' xi ix. (Applicative a, El phi xi) => (forall ix1. phi ix1 -> r ix1 -> a (r' ix1)) + -> phi ix -> IL xi r ix -> a (IL xi r' ix) +hmapAIL f _ (IL l) = + let + as :: [a (r' xi)] + as = map (f proof) l + as' :: a [r' xi] + as' = foldr (liftA2 (:)) (pure []) as + in liftA IL as' + +-- SubPF allows including an embedded domain's PF instance in the PF +-- instance for the enclosing domain. + +-- unusedPhi' is unused, but is here to avoid the need for the +-- UndecidableInstances extension in e.g. the HFunctor instance below +data SubPF (phi :: * -> *) (phi' :: * -> *) unusedPhi' supIxT r ix where + SubPF :: phi' ix -> PF phi' (SubVal supIxT r) ix -> SubPF phi phi' phi' supIxT r (supIxT ix) + +instance (HFunctor phi' (PF phi'), DomainEmbedding phi phi' supIxT) => + HFunctor phi (SubPF phi phi' phi' supIxT) where + hmapA = hmapSubPF + +hmapSubPF :: forall phi r a r' phi' supIxT ix. + (Applicative a, HFunctor phi' (PF phi'), DomainEmbedding phi phi' supIxT) => + (forall ix1. phi ix1 -> r ix1 -> a (r' ix1)) -> + phi ix -> + SubPF phi phi' phi' supIxT r ix -> + a (SubPF phi phi' phi' supIxT r' ix) +hmapSubPF f _ (SubPF (idx :: phi' ix') pfb) = + let + subF :: forall ix2. phi' ix2 -> SubVal supIxT r ix2 -> a (SubVal supIxT r' ix2) + subF idx' v = liftA MkSubVal $ f (supIx idx') $ unSubVal v + pfm :: a (PF phi' (SubVal supIxT r') ix') + pfm = hmapA subF idx pfb + in liftA (SubPF idx) pfm + diff --git a/Text/GrammarCombinators/Base/Processor.hs b/Text/GrammarCombinators/Base/Processor.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/Processor.hs @@ -0,0 +1,94 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Text.GrammarCombinators.Base.Processor ( + GProcessor, + Processor, + identityProcessor, + trivialProcessor, + applyProcessor, + applyProcessorL, + applyProcessorLE, + applyProcessorE + ) where + +import Text.GrammarCombinators.Base.Grammar +import Text.GrammarCombinators.Base.Domain +import Text.GrammarCombinators.Base.MultiRec +import Text.GrammarCombinators.Base.ProductionRule + +import Language.Haskell.TH.Syntax (Q, Exp) + +type GProcessor phi r rr = forall ix. phi ix -> rr ix -> r ix +type Processor phi r = GProcessor phi r (PF phi r) + +-- | A trivial identity processor that keeps current production +-- rule results unmodified. +identityProcessor :: GProcessor phi r r +identityProcessor _ v = v + +applyProcessor' :: + (ProductionRule p, EpsProductionRule p) => + (forall ix . phi ix -> p (r ix)) -> + GProcessor phi r' r -> + (forall ix . phi ix -> p (r' ix)) +applyProcessor' grammar proc idx = + proc idx $>> grammar idx + +-- | Apply a given processor to a given context-free grammar. +applyProcessor :: + GContextFreeGrammar phi t r rr -> + GProcessor phi rr' rr -> + GContextFreeGrammar phi t r rr' +applyProcessor gram proc idx = applyProcessor' gram proc idx + +applyProcessorL :: + (LiftFam phi) => + GLContextFreeGrammar phi t r rr -> + GProcessor phi rr' rr -> + Q Exp -> + GLContextFreeGrammar phi t r rr' +applyProcessorL gram proc q idx = (proc idx, [| $(q) $(return $ liftIdxE idx) |]) $|>> gram idx + +-- | Apply a given processor to a given extended context-free +-- grammar. +applyProcessorE :: + GExtendedContextFreeGrammar phi t r rr -> + GProcessor phi rr' rr -> + GExtendedContextFreeGrammar phi t r rr' +applyProcessorE gram proc idx = applyProcessor' gram proc idx + +-- | Apply a given processor to a given extended liftable context-free +-- grammar. +applyProcessorLE :: + (LiftFam phi) => + GLExtendedContextFreeGrammar phi t r rr -> + GProcessor phi rr' rr -> + Q Exp -> + GLExtendedContextFreeGrammar phi t r rr' +applyProcessorLE gram proc q idx = (proc idx, [| $(q) $(return $ liftIdxE idx) |]) $|>> gram idx + +-- | A trivial processor that throws everything away and returns +-- a value of the type K0 (). +trivialProcessor :: Processor phi (K0 ()) +trivialProcessor _ _ = K0 () diff --git a/Text/GrammarCombinators/Base/ProductionRule.hs b/Text/GrammarCombinators/Base/ProductionRule.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/ProductionRule.hs @@ -0,0 +1,164 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Text.GrammarCombinators.Base.ProductionRule where + +import Text.GrammarCombinators.Base.Domain +import Text.GrammarCombinators.Base.Token +import Text.GrammarCombinators.Base.MultiRec + +import Language.Haskell.TH.Syntax (Q, Exp, Lift, lift) + +infixl 1 ||| +infixl 3 >>> +infixl 3 *>>> +infixl 3 >>>* +infixl 3 $>> +infixl 3 $>>* + +-- | Base type class for production rule interpretations. A production rule +-- interpretation that is an instance of the 'ProductionRule' type class supports +-- sequencing and disjunction of rules, empty rules, dead rules and end-of-input +-- rules. +class ProductionRule p where + -- | Sequence two rules. Result of the sequenced rule is the application + -- of the result of the first rule to the result of the second. + (>>>) :: p (a -> b) -> p a -> p b + -- | Disjunction of two rules. + (|||) :: p va -> p va -> p va + -- | End of input rule. Matches only at end of input, consumes nothing, + -- produces '()' as result. + endOfInput :: p () + -- | Dead rule. Never matches. + die :: p a + +class (ProductionRule p) => LiftableProductionRule p where + -- | Epsilon rule with lifted value. Always matches, consumes nothing, produces + -- the given value (with its lifted version) as result. + epsilonL :: a -> Q Exp -> p a + -- | Optionally match a given rule. + optionally :: p v -> p (Maybe v) + optionally r = epsilonL Just [|Just|] >>> r + ||| epsilonL Nothing [|Nothing|] + +epsilonLS :: (Lift v, LiftableProductionRule p) => v -> p v +epsilonLS v = epsilonL v $ lift v + +class (LiftableProductionRule p) => EpsProductionRule p where + -- | Epsilon rule. Always matches, consumes nothing, produces + -- the given value as result. + epsilon :: a -> p a + +-- | Type class for production rules matching tokens of a certain +-- token type 't'. +-- 't' should be an instance of the 'Token' type class. +class TokenProductionRule p t | p -> t where + -- | Match a given token of type 't' and produce its concrete + -- value (of type 'ConcreteToken' t). + token :: t -> p (ConcreteToken t) + +-- | Sequence two rules, but drop the result of the first. +(*>>>) :: (ProductionRule p, LiftableProductionRule p) => p a -> p b -> p b +a *>>> b = epsilonL (flip const) [| flip const |] >>> a >>> b +-- | Sequence two rules, but drop the result of the second. +(>>>*) :: (ProductionRule p, LiftableProductionRule p) => p a -> p b -> p a +a >>>* b = epsilonL const [|const|] >>> a >>> b + +-- | Apply a given function to the result of a given rule. +($>>) :: EpsProductionRule p => (a -> b) -> p a -> p b +v $>> r = epsilon v >>> r +-- | Replace a rule's result value with a given value. +($>>*) :: EpsProductionRule p => a -> p b -> p a +v $>>* r = epsilon v >>>* r + +-- | Apply a given function to the result of a given rule. +($|>>) :: LiftableProductionRule p => (a -> b, Q Exp) -> p a -> p b +(v,q) $|>> r = epsilonL v q >>> r +-- | Replace a rule's result value with a given value. +($|>>*) :: LiftableProductionRule p => (a, Q Exp) -> p b -> p a +(v,q) $|>>* r = epsilonL v q >>>* r + +-- | Production rule interpretations supporting the 'RecProductionRule' type class support references +-- to non-terminals in a given domain 'phi'. The type of the result values of the rules is determined +-- by semantic value family 'r'. +class RecProductionRule p phi r | p -> phi, p -> r where + -- | Reference a given non-terminal in a production rule. + ref :: phi ix -> p (r ix) + +-- | Production rule interpretations supporting the 'LoopProductionRule' +-- type class allow for Kleene-star quantified references to +-- non-terminals (zero or more, see the 'manyRef' function) as well +-- as '+'-quantified references to non-terminals (one or more, see +-- the 'many1Ref' function). +-- +-- An instance can implement either manyRef or many1Ref, +-- both or neither. Not implementing either produces +-- old-style many and many1 combinator behaviour (discouraged +-- for most situations) +class (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r) => + LoopProductionRule p phi r | p -> phi, p -> r where + -- | Match a given non-terminal zero or more times. + manyRef :: phi ix -> p [r ix] + manyRef idx = epsilonL [] [| [] |] ||| many1Ref idx + -- | Match a given non-terminal one or more times. + many1Ref :: phi ix -> p [r ix] + many1Ref idx = ((:), [| (:) |]) $|>> ref idx >>> manyRef idx + +-- | The 'SuperProductionRule| type class is in an experimental state, and +-- currently not intended for general use. +class SuperProductionRule p where + subref :: (DomainEmbedding phi phi' supIxT, + HFunctor phi (PF phi), + ProductionRule (p phi ixT r t), + ProductionRule (p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t)) => + (forall ix'. phi' ix' -> p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix')) -> + phi' ix -> phi (supIxT ix) -> + p phi ixT r t (PF phi r (supIxT ix)) + +-- | Match any token in a given range of tokens. +tokenRange :: forall p t . (ProductionRule p, TokenProductionRule p t) => [t] -> p (ConcreteToken t) +tokenRange [] = error "empty range" +tokenRange [c] = token c +tokenRange (c : r) = token c ||| tokenRange r + +-- | Consecutively match a given list of tokens and return their concrete token values as a list. +string :: forall p t . (ProductionRule p, LiftableProductionRule p, TokenProductionRule p t) => [t] -> p [ConcreteToken t] +string = foldr ((>>>) . (((:),[|(:)|]) $|>>) . token) (epsilonL [] [|[]|]) + +-- | An old style 'many' combinator. Produces an infinite rule similar to Parsec's many rule. +-- Prefer to use the 'manyRef' function whenever possible. +manyInf :: (ProductionRule p, LiftableProductionRule p) => p a -> p [a] +manyInf r = epsilonL (:) [|(:)|] >>> r >>> manyInf r + ||| epsilonL [] [|[]|] + + +-- | An old style 'many' combinator. Produces an infinite rule similar to Parsec's many rule. +-- Prefer to use the 'manyRef' function whenever possible. +many1Inf :: (ProductionRule p, LiftableProductionRule p) => p a -> p [a] +many1Inf r = epsilonL (:) [|(:)|] >>> r >>> manyInf r + diff --git a/Text/GrammarCombinators/Base/Token.hs b/Text/GrammarCombinators/Base/Token.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Base/Token.hs @@ -0,0 +1,73 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Text.GrammarCombinators.Base.Token where + +import Language.Haskell.TH.Syntax (Lift) + +import Data.Enumerable + +-- | The 'Token' class identifies a type that can be used as terminal +-- identifier in a grammar definition. The type 't' itself is an +-- abstract identifier, identifying a certain type of terminals, but +-- any value of type 't' can correspond to a possibly infinite numer +-- of values of type 'ConcreteToken t'. For example, if you use a lexer +-- in a simple arithmetic expressions grammar, your lexer would typically +-- return values like 'PLUS', 'MINUS', but also 'INTEGER 42' when a +-- number is lexed. In this case, a separate Token type t would be defined, +-- such that a value 'INTEGER_T' of the 'Token' type t could +-- correspond to all values of the form 'INTEGER n' (for n an Integer) +-- of type 'ConcreteToken t'. A production rule defined as +-- 'token' INTEGER_T would then produce result values of type +-- 'ConcreteToken' t (e.g. INTEGER 42). +-- +-- The requirements on 'Token' types are relatively strict, but this is +-- necessary to make it usable in table-based parser algorithms. +-- We reference the 'Lift' class to allow for compile-time +-- precalculation of tables using Template Haskell (See the LL1 and +-- RealLL1 parsers). +-- +-- Note that in some cases it is inefficient to use Char directly as +-- token type, because of the big amount of tokens. For example when using +-- 'transformLeftCorner', the new domain will contain O(n*t + n^2) +-- non-terminals where n is the amount of non-terminals and t is th +-- number of tokens, so when using this transformation, it is beneficial to +-- use a token type with less token values than 'Char', at +-- least if you will use algorithms that fold over the full new grammar's domain +-- (e.g. 'printGrammar' does, 'printReachableGrammar' doesn't). +class (Show (ConcreteToken t), Eq (ConcreteToken t), Eq t, + Show t, Ord t, Lift t, Enumerable t) => + Token t where + type ConcreteToken t + -- | The 'classify' function classifies a given 'ConcreteToken' t into + -- the value of type t it is represented by. + classify :: ConcreteToken t -> t + -- | The 'enumConcreteTokens' function returns a (possibly infinite) + -- list of all concrete tokens of type 'ConcreteToken t' + -- corresponding to a given token of 'Token' type t + enumConcreteTokens :: t -> [ConcreteToken t] + +instance Token Char where + type ConcreteToken Char = Char + classify = id + enumConcreteTokens c = [c] + diff --git a/Text/GrammarCombinators/Parser/LL1.hs b/Text/GrammarCombinators/Parser/LL1.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/LL1.hs @@ -0,0 +1,206 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Text.GrammarCombinators.Parser.LL1 ( + LL1Table(LL1Table), + calcLL1Table, + parseLL1 + ) where + +import Data.Set (Set, union, singleton) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe + +import Control.Monad +import Control.Monad.State + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Parser.TopDown + +data FirstSet t = + FS { + firstSet :: Set t, + canBeEmpty :: Bool, + canBeEOI :: Bool + } + +type FirstSetGrammar phi t = forall ix. phi ix -> [FirstSet t] + +newtype (Domain phi, Token t) => FSCalculator phi ixT (r :: * -> *) t v = MkFSCalculator { + calcFS :: FirstSetGrammar phi t -> [FirstSet t] + } +type FirstSetGrammarRec phi ixT r t rr = forall ix. phi ix -> FSCalculator phi ixT r t (rr ix) + +unionL :: (Ord a) => [Set a] -> Set a +unionL = foldr Set.union Set.empty + +instance (Domain phi, Token t) => ProductionRule (FSCalculator phi ixT r t) where + a >>> b = MkFSCalculator $ \g -> + do FS fsa ea fa <- calcFS a g + FS fsb eb fb <- calcFS b g + return $ FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb)) + a ||| b = MkFSCalculator disjFS where + disjFS :: FirstSetGrammar phi t -> [FirstSet t] + disjFS g = calcFS a g ++ calcFS b g + die = MkFSCalculator $ \_ -> [FS Set.empty False False] + endOfInput = MkFSCalculator $ \_ -> [FS Set.empty False True] + +instance (Domain phi, Token t) => EpsProductionRule (FSCalculator phi ixT r t) where + epsilon _ = MkFSCalculator $ \_ -> [FS Set.empty True False] + +instance (Domain phi, Token t) => LiftableProductionRule (FSCalculator phi ixT r t) where + epsilonL v _ = epsilon v + +instance (Token t, Domain phi) => TokenProductionRule (FSCalculator phi ixT r t) t where + token c = MkFSCalculator $ \_ -> [FS (singleton c) False False] +instance (Domain phi, Token t) => RecProductionRule (FSCalculator phi ixT r t) phi r where + ref idx = MkFSCalculator $ \g -> [FS (unionL $ map firstSet $ g idx) (any canBeEmpty $ g idx) (any canBeEOI $ g idx)] + +fixFSGrammar :: (Domain phi, Token t) => FirstSetGrammarRec phi ixT r t rr -> FirstSetGrammar phi t +fixFSGrammar g idx = calcFS (g idx) $ fixFSGrammar g + +data (Token t) => LL1Table phi t = LL1Table { + ruleForTokenTable :: Memo phi (K0 (Map t Int)), + ruleForEOITable :: Memo phi (K0 (Maybe Int)), + ruleForEmptyTable :: Memo phi (K0 (Maybe Int)) + } + +calcLL1Table :: forall phi r t rr. (Token t, Domain phi) => + GContextFreeGrammar phi t r rr -> LL1Table phi t +calcLL1Table grammar = + let + g :: FirstSetGrammar phi t + g = fixFSGrammar grammar + fss :: forall ix. phi ix -> [Set t] + fss = map firstSet . g + n :: forall ix. phi ix -> Int + n = length . fss + ttableContents :: forall ix. phi ix -> [(t,Int)] + ttableContents idx = do (fs,i) <- zip (fss idx) [0..n idx-1] + c <- Set.toList fs + return (c,i) + rftTable :: forall ix. phi ix -> Map t Int + rftTable idx = Map.fromListWith notLL1Error $ ttableContents idx + cbe :: forall ix. phi ix -> [Bool] + cbe = map canBeEOI . g + etableContents :: forall ix. phi ix -> [Int] + etableContents idx = do (True, i) <- zip (cbe idx) [0..n idx-1] + return i + rfeTable :: forall ix. phi ix -> Maybe Int + rfeTable = listToMaybe . etableContents + rfnTable :: forall ix. phi ix -> Maybe Int + rfnTable = listToMaybe . ntableContents + cbn :: forall ix. phi ix -> [Bool] + cbn = map canBeEmpty . g + ntableContents :: forall ix. phi ix -> [Int] + ntableContents idx = do (True, i) <- zip (cbn idx) [0..n idx-1] + return i + notLL1Error = error "Not LL1" + in LL1Table (toMemoK rftTable) (toMemoK rfeTable) (toMemoK rfnTable) + +newtype LLRule phi ixT r t v = MkLLRule { + llRuleAlts :: [NonBranchingRule phi r t v] + } + +instance Functor (LLRule phi ixT r t) where + fmap f (MkLLRule rules) = MkLLRule [fmap f rule | rule <- rules] +instance ProductionRule (LLRule phi ixT r t) where + (MkLLRule rulesa) >>> (MkLLRule rulesb) = + let + seqrule = liftM2 ($) + in MkLLRule [seqrule rulea ruleb | rulea <- rulesa, ruleb <- rulesb] + (MkLLRule rulesa) ||| (MkLLRule rulesb) = + MkLLRule $ rulesa ++ rulesb + die = MkLLRule [] + endOfInput = MkLLRule [nbrEndOfInput] + +instance EpsProductionRule (LLRule phi ixT r t) where + epsilon v = MkLLRule [return v] + +instance LiftableProductionRule (LLRule phi ixT r t) where + epsilonL v _ = MkLLRule [return v] + +instance (Token t) => TokenProductionRule (LLRule phi ixT r t) t where + token t = + let + rule = do (c:r) <- MkNBR $ \_ -> get + if classify c == t + then do MkNBR $ \_ -> put r + return c + else fail $ errWrongToken c + errWrongToken c = show c ++ " read when " ++ show t ++ " expected." + in MkLLRule [rule] + +instance RecProductionRule (LLRule phi ixT r t) phi r where + ref idx = MkLLRule [MkNBR $ \g -> get >>= \s -> unNBR (g idx s) g] + +newtype WrapNonBranchingRuleList phi r t ix = WrapNBRL { + unWrapNBRL :: [NonBranchingRule phi r t (r ix)] + } + +ll1Disambiguate :: forall phi r t. (Domain phi, Token t) => + ProcessingContextFreeGrammar phi t r -> + LL1Table phi t -> + UnambiguousTopDownGrammar phi r t +ll1Disambiguate gram table = + let + tableidx :: phi ix -> K0 (Map t Int) ix + tableidx = fromMemo (ruleForTokenTable table) + ttable :: phi ix -> Map t Int + ttable idx = unK0 $ tableidx idx + eoitable :: phi ix -> Maybe Int + eoitable idx = unK0 $ fromMemo (ruleForEOITable table) idx + emptytable :: phi ix -> Maybe Int + emptytable idx = unK0 $ fromMemo (ruleForEmptyTable table) idx + tidx :: phi ix -> ConcreteToken t -> Int + tidx idx c = fromMaybe (emptyidx idx) $ Map.lookup (classify c) $ ttable idx + eoiidx :: phi ix -> Int + eoiidx idx = fromMaybe (emptyidx idx) $ eoitable idx + emptyidx :: phi ix -> Int + emptyidx idx = fromJust $ emptytable idx + candidateRules :: phi ix -> [NonBranchingRule phi r t (r ix)] + candidateRules idx = llRuleAlts $ gram idx + memoCR :: phi ix -> [NonBranchingRule phi r t (r ix)] + memoCR = unWrapNBRL . memoFamily (WrapNBRL . candidateRules) + ruleForString :: phi ix -> [ConcreteToken t] -> NonBranchingRule phi r t (r ix) + ruleForString idx (c:_) = memoCR idx !! tidx idx c + ruleForString idx [] = memoCR idx !! eoiidx idx + in ruleForString + +parseLL1 :: forall phi ixT r t ix. (Domain phi, Token t, ProductionRule (LLRule phi ixT r t)) => + ProcessingContextFreeGrammar phi t r -> + LL1Table phi t -> phi ix -> [ConcreteToken t] -> Maybe (r ix) +parseLL1 gram table = + let + unambGram :: UnambiguousTopDownGrammar phi r t + unambGram = ll1Disambiguate gram table + in parseTopDown unambGram + diff --git a/Text/GrammarCombinators/Parser/LL1TH.hs b/Text/GrammarCombinators/Parser/LL1TH.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/LL1TH.hs @@ -0,0 +1,52 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RelaxedPolyRec #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Text.GrammarCombinators.Parser.LL1TH ( + prepareLL1TableTH + ) where + +import Language.Haskell.TH.Syntax + +import Data.Map + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Parser.LL1 + +instance (Lift k, Lift a) => Lift (Map k a) where + lift v = [| fromAscList $(lift $ toAscList v)|] + +prepareLL1TableTH :: (Domain phi, + Token t, + Lift (Memo phi (K0 (Map t Int))), + Lift (Memo phi (K0 (Maybe Int))) + ) => + GContextFreeGrammar phi t r rr -> Q Exp +prepareLL1TableTH grammar = liftLL1Table $ calcLL1Table grammar + +liftLL1Table :: (MemoFam phi, + Token t, + Lift (Memo phi (K0 (Map t Int))), + Lift (Memo phi (K0 (Maybe Int)))) => + LL1Table phi t -> Q Exp +liftLL1Table (LL1Table a b c) = [| LL1Table $(lift a) $(lift b) $(lift c)|] diff --git a/Text/GrammarCombinators/Parser/Packrat.hs b/Text/GrammarCombinators/Parser/Packrat.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/Packrat.hs @@ -0,0 +1,195 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Text.GrammarCombinators.Parser.Packrat ( + Result (Parsed, NoParse), + Derivs, + parsePackrat + ) where + +import Text.GrammarCombinators.Base + +data Result phi r t v = Parsed v (Derivs phi r t) | + NoParse +instance (Show v) => Show (Result phi r t v) where + show (Parsed v _) = "Parsed " ++ show v ++ " _" + show NoParse = "NoParse" + +instance Functor (Result phi r t) where + fmap f (Parsed v d) = Parsed (f v) d + fmap _ NoParse = NoParse + +data PRPrimTokenIx +data PREndOfInputIx +data PRBaseIx ix + +data PackratDomain phi ix where + PackratDomainBase :: phi ix -> PackratDomain phi (PRBaseIx ix) + PackratDomainPrimToken :: PackratDomain phi PRPrimTokenIx + PackratDomainEndOfInput :: PackratDomain phi PREndOfInputIx + +instance DomainMap (PackratDomain phi) phi PRBaseIx where + supIx = PackratDomainBase + subIx (PackratDomainBase idx) = idx + +instance (MemoFam phi) => MemoFam (PackratDomain phi) where + data Memo (PackratDomain phi) v = PRMemo (v PRPrimTokenIx, v PREndOfInputIx, Memo phi (SubVal PRBaseIx v)) + toMemo f = PRMemo (f PackratDomainPrimToken, f PackratDomainEndOfInput, toMemo $ \idx -> MkSubVal $ f $ PackratDomainBase idx) + fromMemo (PRMemo (_, _, bm)) (PackratDomainBase idx) = unSubVal $ fromMemo bm idx + fromMemo (PRMemo (v, _, _)) (PackratDomainPrimToken) = v + fromMemo (PRMemo (_, v, _)) (PackratDomainEndOfInput) = v + +data PackratValue phi t r ix where + PRPrimTokenValue :: ConcreteToken t -> PackratValue phi t r PRPrimTokenIx + PREndOfInputValue :: PackratValue phi t r PREndOfInputIx + PRBaseValue :: r ix -> PackratValue phi t r (PRBaseIx ix) + +unPRPrimTokenValue :: PackratValue phi t r PRPrimTokenIx -> ConcreteToken t +unPRPrimTokenValue (PRPrimTokenValue c) = c + +newtype PRResult phi r t ix = PRResult { + unPRResult :: Result phi r t (PackratValue phi t r ix) + } + +newtype Derivs phi r t = Derivs { + unDerivs :: forall ix. PackratDomain phi ix -> PRResult phi r t ix + } + +buildDerivs :: forall phi r t. (Token t, MemoFam phi) => (forall ix. PackratDomain phi ix -> PRResult phi r t ix) -> Derivs phi r t +buildDerivs f = Derivs memoizedF where + memoizedF :: forall ix. PackratDomain phi ix -> PRResult phi r t ix + memoizedF = memoFamily f + +type InternalPRRule phi r t v = Derivs phi r t -> Result phi r t v +type InternalGrammar phi r t = forall ix. phi ix -> InternalPRRule phi r t (r ix) +data PackratRule phitop rtop phi ixT r t v = + PackratRule { + runParse :: InternalGrammar phitop rtop t -> + (forall ix. phi ix -> rtop (ApplyIxMap ixT ix) -> r ix) -> + (forall ix. phi ix -> phitop (ApplyIxMap ixT ix)) -> + InternalPRRule phitop rtop t v + } +type PackratGrammar phitop rtop phi ixT rr r t = forall ix. phi ix -> PackratRule phitop rtop phi ixT rr t (r ix) + +instance ProductionRule (PackratRule phitop rtop phi ixT r t) where + a >>> b = PackratRule $ \g rd si d0 -> + case runParse a g rd si d0 of + Parsed f d1 -> case runParse b g rd si d1 of + Parsed x d2 -> Parsed (f x) d2 + _ -> NoParse + _ -> NoParse + -- TODO : parameterise disambiguation (keeping only 1st match or all)? + a ||| b = PackratRule $ \g rd si d -> + case runParse a g rd si d of + Parsed v1 d1 -> Parsed v1 d1 + _ -> case runParse b g rd si d of + Parsed v2 d2 -> Parsed v2 d2 + _ -> NoParse + die = PackratRule $ \_ _ _ _ -> NoParse + endOfInput = PackratRule $ \_ _ _ d -> + case unPRResult $ unDerivs d PackratDomainEndOfInput of + Parsed _ d' -> Parsed () d' + _ -> NoParse + +instance EpsProductionRule (PackratRule phitop rtop phi ixT r t) where + epsilon v = PackratRule $ \_ _ _ -> Parsed v + +instance LiftableProductionRule (PackratRule phitop rtop phi ixT r t) where + epsilonL v _ = epsilon v + +instance (Token t) => TokenProductionRule (PackratRule phitop rtop phi ixT r t) t where + token c = PackratRule $ \_ _ _ d -> + case unPRResult$ unDerivs d PackratDomainPrimToken of + Parsed v' d' | classify (unPRPrimTokenValue v') == c -> Parsed (unPRPrimTokenValue v') d' + _ -> NoParse + +instance RecProductionRule (PackratRule phitop rtop phi ixT r t) phi r where + ref (idx :: phi ix) = + PackratRule $ \grammar rd si d -> + fmap (rd idx) $ grammar (si idx) d + + +toInternalGrammar :: PackratGrammar phi r phi IxMapId r r t -> InternalGrammar phi r t +toInternalGrammar g idx = + runParse (g idx) (toInternalGrammar g) (\_ -> id) id + +parsePackratAll :: forall phi r t. (Token t, MemoFam phi) => InternalGrammar phi r t -> [ConcreteToken t] -> Derivs phi r t +parsePackratAll grammar s = + let + derivs :: forall ix. PackratDomain phi ix -> PRResult phi r t ix + derivs (PackratDomainPrimToken) = case s of + (c:s') -> PRResult $ Parsed (PRPrimTokenValue c) (parsePackratAll grammar s') + _ -> PRResult NoParse + derivs (PackratDomainBase ruleId) = PRResult $ fmap PRBaseValue $ grammar ruleId (buildDerivs derivs) + derivs (PackratDomainEndOfInput) = case s of + [] -> PRResult $ Parsed PREndOfInputValue $ Derivs $ const $ PRResult NoParse + _ -> PRResult NoParse + in buildDerivs derivs + +instance SuperProductionRule (PackratRule phitop rtop) where + subref = prSubRef + +prSubRef :: forall phitop phi phi' rtop r ixT t ix supIxT . (DomainEmbedding phi phi' supIxT, HFunctor phi (PF phi)) => + (forall ix'. phi' ix' -> PackratRule phitop rtop phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix')) -> + phi' ix -> phi (supIxT ix) -> + PackratRule phitop rtop phi ixT r t (PF phi r (supIxT ix)) +prSubRef subgram idxb idx = PackratRule $ \outgram rd supIxTop -> + let + subrule :: PackratRule phitop rtop phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix) + subrule = subgram idxb + rd' :: forall ix' . phi' ix' -> rtop (ApplyIxMap ixT (supIxT ix')) -> SubVal supIxT r ix' + rd' idx' v = MkSubVal $ rd (supIx idx') v + supIx' :: forall ix' . phi' ix' -> phitop (ApplyIxMap ixT (supIxT ix')) + supIx' idx' = supIxTop (supIx idx' :: phi (supIxT ix')) + oprrule :: InternalPRRule phitop rtop t (PF phi' (SubVal supIxT r) ix) + oprrule = runParse subrule outgram rd' supIx' + nprrule :: InternalPRRule phitop rtop t (PF phi r (supIxT ix)) + nprrule = fmap (supPF idxb idx) . oprrule + in nprrule + +instance LoopProductionRule (PackratRule phitop rtop phi ixT r t) phi r where + manyRef = manyInf . ref + +-- | Parse a given string according to a given grammar, starting from a given start non-terminal, +-- with a backtracking Packrat parser algorithm (like backtracking recursive descent, but with +-- linear performance in the length of the input). +parsePackrat :: forall phi r ix t. (Token t, MemoFam phi) => + ProcessingContextFreeGrammar phi t r -> + phi ix -> [ConcreteToken t] -> Result phi r t (r ix) +parsePackrat usergram ruleId s = + let + grammar :: forall ix'. phi ix' -> Derivs phi r t -> Result phi r t (r ix') + grammar = toInternalGrammar usergram + result :: Result phi r t (PackratValue phi t r (PRBaseIx ix)) + result = unPRResult $ unDerivs (parsePackratAll grammar s) (PackratDomainBase ruleId) + in case result of + Parsed (PRBaseValue v) d -> Parsed v d + _ -> NoParse + diff --git a/Text/GrammarCombinators/Parser/Parsec.hs b/Text/GrammarCombinators/Parser/Parsec.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/Parsec.hs @@ -0,0 +1,74 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Compatibility component for the Parsec library. +module Text.GrammarCombinators.Parser.Parsec ( + parseParsec + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.UnfoldRecursion + +import Text.Parsec +import Text.Parsec.Pos +import qualified Text.Parsec as Parsec +--import Text.ParserCombinators.Parsec.Prim + +newtype WrapGenParser t v = WGP { unWGP :: Parsec [ConcreteToken t] () v } + +instance (Token t) => ProductionRule (WrapGenParser t) where + a >>> b = WGP $ do f <- unWGP a; x <- unWGP b; return $ f x + a ||| b = WGP $ try (unWGP a) <|> unWGP b + endOfInput = WGP eof + die = WGP parserZero + +instance (Token t) => EpsProductionRule (WrapGenParser t) where + epsilon v = WGP $ return v + +instance (Token t) => LiftableProductionRule (WrapGenParser t) where + epsilonL v _ = epsilon v + +instance (Token t) => TokenProductionRule (WrapGenParser t) t where + token tt = WGP $ tokenPrim show nextPos testToken + where + testToken t = if classify t == tt then Just t else Nothing + nextPos p _ _ = newPos (sourceName p) (sourceLine p) (sourceColumn p+1) + +-- | Parse a given string according to a given grammar, starting from a given start +-- non-terminal, using the Parsec parser library. Currently uses backtracking for +-- every branch. +-- +-- It is probably possible to automatically approximate +-- branches where backtracking is required, which would be neat and really go beyond +-- what is currently possible in Parsec. Help welcome! +parseParsec :: forall phi t r ix. + (Token t) => + ProcessingContextFreeGrammar phi t r -> + phi ix -> SourceName -> [ConcreteToken t] -> Either ParseError (r ix) +parseParsec gram idx = + let irule :: WrapGenParser t (r ix) + irule = unfoldRecursion gram idx + parser = unWGP irule + in Parsec.parse parser diff --git a/Text/GrammarCombinators/Parser/RealLL1.hs b/Text/GrammarCombinators/Parser/RealLL1.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/RealLL1.hs @@ -0,0 +1,194 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} + +-- | This is an experiment, do not use. +module Text.GrammarCombinators.Parser.RealLL1 ( + FirstSet(FS,firstTokens,canBeEmpty,canBeEOI), + BranchSelectorMemo(DefaultBranchSelectorMemo,SplitBranchSelectorMemoL, FlipBS), + RealLL1Table (MkRealLL1Table), + parseRealLL1, + prepareLL1Parser, + ) where + +import Text.GrammarCombinators.Base + +import Control.Monad.Maybe +import Control.Monad.State + +import Data.Set +import qualified Data.Set as Set + +data (Token t) => FirstSet t = + FS { + firstTokens :: Set t, + canBeEmpty :: Bool, + canBeEOI :: Bool + } deriving (Show) + +data BranchSelector t = MkBS { + selectBranch :: forall a. [ConcreteToken t] -> a -> a -> (a, BranchSelector t) + } + +defaultBranchSelector :: BranchSelector t +defaultBranchSelector = + MkBS (error "defaultBranchSelector selecting branch???") + +data BranchSelectorMemo t = + DefaultBranchSelectorMemo + | SplitBranchSelectorMemoL (FirstSet t) (BranchSelectorMemo t) (BranchSelectorMemo t) + | FlipBS (BranchSelectorMemo t) + +unBranchSelectorMemo :: (Token t) => BranchSelectorMemo t -> BranchSelector t +unBranchSelectorMemo DefaultBranchSelectorMemo = defaultBranchSelector +unBranchSelectorMemo (SplitBranchSelectorMemoL fs bsm1 bsm2) = + let bs1 = unBranchSelectorMemo bsm1 + bs2 = unBranchSelectorMemo bsm2 + selBranch fts _ (t:_) b1 b2 = if classify t `member` fts then (b1,bs1) else (b2,bs2) + selBranch _ f [] b1 b2 = if f then (b1,bs1) else (b2,bs2) + in MkBS $ selBranch (firstTokens fs) (canBeEOI fs) +unBranchSelectorMemo (FlipBS bsm) = + let bs = unBranchSelectorMemo bsm + in MkBS $ \s b1 b2 -> selectBranch bs s b2 b1 + +data BranchData t = MkBD { + branchSelector :: BranchSelectorMemo t, + seqBS :: BranchSelectorMemo t -> BranchSelectorMemo t, + firstSet :: FirstSet t + } + +type BranchSelectorGrammar phi t = forall ix. phi ix -> BranchData t + +newtype (Domain phi, Token t) => BranchSelectorComputer phi (r :: * -> *) t v = MkBSC { + branchData :: BranchSelectorGrammar phi t -> BranchData t + } + +type BSCGrammar phi r t rr = forall ix. phi ix -> BranchSelectorComputer phi r t (rr ix) + +instance (Domain phi, Token t) => ProductionRule (BranchSelectorComputer phi r t) where + a >>> b = MkBSC $ \g -> + let + bs = seqBS (branchData a g) (branchSelector (branchData b g)) + (FS fsa ea fa) = firstSet $ branchData a g + (FS fsb eb fb) = firstSet $ branchData b g + fs = FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb)) + nseqbs = seqBS (branchData a g) . seqBS (branchData b g) + in MkBD bs nseqbs fs + a ||| b = MkBSC $ \g -> + let + fsa = firstSet $ branchData a g + fsb = firstSet $ branchData b g + (FS ftsa ea fa) = fsa + (FS ftsb eb fb) = fsb + fs = FS (ftsa `union` ftsb) (ea || eb) (fa || fb) + bsa = branchSelector $ branchData a g + bsb = branchSelector $ branchData b g + sb bsa' bsb' = if not ea + then SplitBranchSelectorMemoL fsa bsa' bsb' + else FlipBS $ SplitBranchSelectorMemoL fsb bsb' bsa' + seqbs rbs = sb (seqBS (branchData a g) rbs) (seqBS (branchData a g) rbs) + in MkBD (sb bsa bsb) seqbs fs + die = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False False + endOfInput = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False True + +instance (Domain phi, Token t) => LiftableProductionRule (BranchSelectorComputer phi r t) where + epsilonL v _ = epsilon v + +instance (Domain phi, Token t) => EpsProductionRule (BranchSelectorComputer phi r t) where + epsilon _ = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty True False + +instance (Token t, Domain phi) => TokenProductionRule (BranchSelectorComputer phi r t) t where + token tt = MkBSC $ \_ -> + MkBD DefaultBranchSelectorMemo id $ FS (singleton tt) False False + +instance (Token t, Domain phi) => RecProductionRule (BranchSelectorComputer phi r t) phi r where + ref idx = MkBSC $ \g -> + MkBD DefaultBranchSelectorMemo id $ firstSet $ g idx + +instance (Token t, Domain phi) => LoopProductionRule (BranchSelectorComputer phi r t) phi r where + manyRef idx = MkBSC $ \g -> + let + singleFS = firstSet $ g idx + multFS = FS (firstTokens singleFS) True (canBeEOI singleFS) + in MkBD DefaultBranchSelectorMemo id multFS + +fixBSC :: (Domain phi, Token t) => BSCGrammar phi r t rr -> BranchSelectorGrammar phi t +fixBSC gram idx = branchData (gram idx) (fixBSC gram) + +data RealLL1Rule phi ixT r t v = MkRealLL1Rule { + runLL1Rule :: BranchSelector t -> + (forall ix. phi ix -> BranchSelector t) -> + (forall ix. phi ix -> RealLL1Rule phi ixT r t (r ix)) -> + MaybeT (State [ConcreteToken t]) v + } + +type RealLL1Grammar phi ixT rr r t = (Domain phi, Token t) => phi ix -> RealLL1Rule phi ixT r t (rr ix) + +instance ProductionRule (RealLL1Rule phi ixT r t) where + a >>> b = MkRealLL1Rule $ \cs selg g -> do f <- runLL1Rule a cs selg g + x <- runLL1Rule b cs selg g + return $ f x + a ||| b = MkRealLL1Rule $ \cs selg g -> + do s <- get + let (r,ns) = selectBranch cs s a b + runLL1Rule r ns selg g + die = MkRealLL1Rule $ \_ _ _ -> fail "die" + endOfInput = MkRealLL1Rule $ \_ _ _ -> do [] <- get; return () + +instance LiftableProductionRule (RealLL1Rule phi ixT r t) where + epsilonL v _ = epsilon v + +instance EpsProductionRule (RealLL1Rule phi ixT r t) where + epsilon v = MkRealLL1Rule $ \_ _ _ -> return v + +instance (Token t) => TokenProductionRule (RealLL1Rule phi ixT r t) t where + token tt = MkRealLL1Rule $ \_ _ _ -> + let + errWrongToken c = show c ++ " read when " ++ show tt ++ " expected." + in do (c:r) <- get + if classify c == tt + then put r >> return c + else fail $ errWrongToken c + +instance RecProductionRule (RealLL1Rule phi ixT r t) phi r where + ref idx = MkRealLL1Rule $ \_ selg g -> + runLL1Rule (g idx) (selg idx) selg g + +newtype RealLL1Table phi t = MkRealLL1Table { + unRealLL1Table :: Memo phi (K0 (BranchSelectorMemo t)) + } + +prepareLL1Parser :: (Domain phi, Token t) => BSCGrammar phi r t rr -> RealLL1Table phi t +prepareLL1Parser gram = MkRealLL1Table $ toMemoK $ branchSelector . fixBSC gram + +parseRealLL1 :: (Domain phi, Token t) => RealLL1Grammar phi ixT r r t -> RealLL1Table phi t -> + phi ix -> [ConcreteToken t] -> Maybe (r ix) +parseRealLL1 gram selgmemo idx s = + let + selg = unBranchSelectorMemo . fromMemoK (unRealLL1Table selgmemo) + m = runLL1Rule (gram idx) (selg idx) selg gram + in evalState (runMaybeT m) s diff --git a/Text/GrammarCombinators/Parser/RecursiveDescent.hs b/Text/GrammarCombinators/Parser/RecursiveDescent.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/RecursiveDescent.hs @@ -0,0 +1,88 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Text.GrammarCombinators.Parser.RecursiveDescent ( + parseRecDec + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.UnfoldRecursion + +import Control.Monad.State +import Control.Monad.Maybe + +import Data.Maybe + +newtype RecDecRule t v = RecDecRule { runRD :: MaybeT (State [ConcreteToken t]) v } deriving (Monad) + +instance MonadPlus (RecDecRule t) where + mzero = RecDecRule $ fail "mzero" + ma `mplus` mb = + RecDecRule $ MaybeT $ do olds <- get + result <- runMaybeT $ runRD ma + if isNothing result + then put olds >> runMaybeT (runRD mb) + else return result + +instance ProductionRule (RecDecRule t) where + (>>>) = liftM2 ($) + (|||) = mplus + die = mzero + endOfInput = RecDecRule $ do [] <- get; return () + +instance EpsProductionRule (RecDecRule t) where + epsilon = return + +instance LiftableProductionRule (RecDecRule t) where + epsilonL v _ = return v + +instance (Token t) => TokenProductionRule (RecDecRule t) t where + token c = + let + primToken = RecDecRule $ do (c':r) <- get + put r + return c' + in do cr <- primToken + if c == classify cr + then return cr + else fail $ "unexpected token " ++ show c ++ ", expecting " ++ show cr + +parseRecDecBase :: RecDecRule t a -> [ConcreteToken t] -> Maybe a +parseRecDecBase parser s = + case flip runState s $ runMaybeT $ runRD parser of + (v,[]) -> v + _ -> error "No full parse" + +-- | Parse a given string according to a given grammar, starting from a given start non-terminal, +-- with a simple backtracking recursive descent parser algorithm. +parseRecDec :: forall phi t r ix. (Token t) => + ProcessingContextFreeGrammar phi t r -> phi ix -> [ConcreteToken t] -> Maybe (r ix) +parseRecDec gram = + let + rpwgram :: phi ix -> RecDecRule t (r ix) + rpwgram = unfoldRecursion gram + in parseRecDecBase . rpwgram diff --git a/Text/GrammarCombinators/Parser/TopDown.hs b/Text/GrammarCombinators/Parser/TopDown.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/TopDown.hs @@ -0,0 +1,67 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This was intended as a common library for top-down parser algorithms, but it +-- is a bit outdated and currently only used by the LL1 parser. +module Text.GrammarCombinators.Parser.TopDown where + +import Control.Monad.Maybe +import Control.Monad.State + +import Text.GrammarCombinators.Base + +newtype NonBranchingRule phi r t v = MkNBR { + unNBR :: (forall ix. phi ix -> [ConcreteToken t] -> NonBranchingRule phi r t (r ix)) -> MaybeT (State [ConcreteToken t]) v + } + +instance Functor (NonBranchingRule phi r t) where + fmap f r = MkNBR $ \g -> fmap f $ unNBR r g + +instance Monad (NonBranchingRule phi r t) where + ra >> rb = MkNBR $ \g -> unNBR ra g >> unNBR rb g + ra >>= f = MkNBR $ \g -> unNBR ra g >>= \v -> unNBR (f v) g + return v = MkNBR $ \_ -> return v + +nbrEndOfInput :: NonBranchingRule phi r t () +nbrEndOfInput = MkNBR $ \_ -> do [] <- get; return () + +type UnambiguousTopDownGrammar phi r t = (Domain phi, Token t) => phi ix -> [ConcreteToken t] -> NonBranchingRule phi r t (r ix) + +newtype WrapLookaheadNBR phi r t ix = WrapLNBR { + unWrapLNBR :: [ConcreteToken t] -> NonBranchingRule phi r t (r ix) + } + +parseTopDown :: forall phi r t ix. (Domain phi, Token t) => UnambiguousTopDownGrammar phi r t -> phi ix -> [ConcreteToken t] -> Maybe (r ix) +parseTopDown gram idx s = + let + memoGram :: UnambiguousTopDownGrammar phi r t + memoGram = unWrapLNBR . memoFamily (WrapLNBR . gram) + currule :: NonBranchingRule phi r t (r ix) + currule = memoGram idx s + exec :: State [ConcreteToken t] (Maybe (r ix)) + exec = runMaybeT $ unNBR currule gram + in evalState exec s + diff --git a/Text/GrammarCombinators/Parser/UUParse.hs b/Text/GrammarCombinators/Parser/UUParse.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Parser/UUParse.hs @@ -0,0 +1,100 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | UUParse compatibility module. +module Text.GrammarCombinators.Parser.UUParse ( + parseUU, + parseUUR, + parseUURule, + parseUUE + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.UnfoldRecursion +import Text.GrammarCombinators.Transform.UnfoldLoops + +import Text.ParserCombinators.UU hiding (Token) + +-- We just count tokens for now (not lines and colums with handling here for newlines etc), +-- locations cannot be used atm anyway... +instance IsLocationUpdatedBy Int t where + advance p _ = p + 1 + +newtype WrapP t v = WP { unWP :: P (Str (ConcreteToken t) Int) v } + +instance (Token t) => ProductionRule (WrapP t) where + a >>> b = WP $ unWP a <*> unWP b + a ||| b = WP $ unWP a <|> unWP b + endOfInput = WP $ const () <$> pEnd + die = WP empty + +instance (Token t) => EpsProductionRule (WrapP t) where + epsilon v = WP $ pure v + +instance (Token t) => LiftableProductionRule (WrapP t) where + epsilonL v _ = epsilon v + +instance (Token t) => TokenProductionRule (WrapP t) t where + token tt = + let + sat :: ConcreteToken t -> Bool + sat t = classify t == tt + in WP $ pSym (sat, show tt, head $ enumConcreteTokens tt) + +-- | Parse a given string according to a given regular grammar, starting from a given +-- start symbol using the UUParse error-correcting parsing library (always +-- produces a result) +parseUUR :: forall phi t r ix. + (Token t) => + ProcessingRegularGrammar phi t r -> + phi ix -> [ConcreteToken t] -> r ix +parseUUR gram idx = parseUURule $ gram idx + +-- | Parse a given string according to a given grammar, starting from a given +-- start symbol using the UUParse error-correcting parsing library (always +-- produces a result) +parseUU :: forall phi t r ix. + (Token t) => + ProcessingContextFreeGrammar phi t r -> + phi ix -> [ConcreteToken t] -> r ix +parseUU gram = parseUUR (unfoldRecursion gram) + +-- | Parse a given string according to a given regular production rule using the +-- UUParse error-correcting parsing library (always produces a result). +parseUURule :: forall phi t r v. + (Token t) => + RegularRule phi r t v -> + [ConcreteToken t] -> v +parseUURule rule s = + parse (unWP rule) $ listToStr s 0 + +-- | Parse a given string according to a given extended grammar, starting from a given +-- start symbol using the UUParse error-correcting parsing library (always +-- produces a result) +parseUUE :: forall phi t r ix. + (Token t) => + ProcessingExtendedContextFreeGrammar phi t r -> + phi ix -> [ConcreteToken t] -> r ix +parseUUE gram = parseUU (unfoldLoops gram) diff --git a/Text/GrammarCombinators/TH/Base.hs b/Text/GrammarCombinators/TH/Base.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/TH/Base.hs @@ -0,0 +1,41 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} + +module Text.GrammarCombinators.TH.Base where + +import Text.GrammarCombinators.Base + +import Language.Haskell.TH.Syntax + +import Data.Set +import qualified Data.Set as Set + +instance (Lift v) => Lift (Set v) where + lift s = [| Set.fromDistinctAscList $(lift $ toAscList s) |] + + +instance Lift v => Lift (K0 v ix) where + lift (K0 v) = [| K0 $(lift v) |] + +instance (Lift (v (supIxT ix))) => + Lift (SubVal supIxT v ix) where + lift (MkSubVal v) = [| MkSubVal $(lift v) |] diff --git a/Text/GrammarCombinators/TH/FoldLoops.hs b/Text/GrammarCombinators/TH/FoldLoops.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/TH/FoldLoops.hs @@ -0,0 +1,35 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Text.GrammarCombinators.TH.FoldLoops where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.FoldLoops + +import Language.Haskell.TH.Syntax + +instance (Lift (Memo phi (SubVal FLBaseIx v)), + Lift (Memo phi (SubVal FLManyIx v))) => + Lift (Memo (FoldLoopsDomain phi) v) where + lift (FLM mb mm) = [| FLM $(lift mb) $(lift mm) |] diff --git a/Text/GrammarCombinators/TH/RealLL1.hs b/Text/GrammarCombinators/TH/RealLL1.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/TH/RealLL1.hs @@ -0,0 +1,41 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} + +module Text.GrammarCombinators.TH.RealLL1 where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Parser.RealLL1 + +import Text.GrammarCombinators.TH.Base () + +import Language.Haskell.TH.Syntax + +instance (Token t) => Lift (FirstSet t) where + lift (FS fts e f) = [| FS $(lift fts) $(lift e) $(lift f) |] + +instance (Token t) => Lift (BranchSelectorMemo t) where + lift DefaultBranchSelectorMemo = [| DefaultBranchSelectorMemo |] + lift (SplitBranchSelectorMemoL fs bsa bsb) = [| SplitBranchSelectorMemoL $(lift fs) $(lift bsa) $(lift bsb) |] + lift (FlipBS bsn) = [| FlipBS $(lift bsn) |] + +liftRealLL1Table :: (Lift (Memo phi (K0 (BranchSelectorMemo t)))) => RealLL1Table phi t -> Q Exp +liftRealLL1Table (MkRealLL1Table memo) = [| MkRealLL1Table $(lift memo) |] diff --git a/Text/GrammarCombinators/Transform/CombineEpsilons.hs b/Text/GrammarCombinators/Transform/CombineEpsilons.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/CombineEpsilons.hs @@ -0,0 +1,86 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Transform.CombineEpsilons ( + combineEpsilons, + combineEpsilonsE + ) where + +import Text.GrammarCombinators.Base + +data CombineEpsilonsRule p (phi :: * -> *) (r :: * -> *) t v where + CERule :: (v' -> v) -> p v' -> CombineEpsilonsRule p phi r t v + CEEpsRule :: v -> CombineEpsilonsRule p phi r t v + +instance (ProductionRule p, EpsProductionRule p) => + ProductionRule (CombineEpsilonsRule p phi r t) where + endOfInput = CERule id endOfInput + (CEEpsRule va) >>> (CEEpsRule vb) = CEEpsRule $ va vb + (CEEpsRule va) >>> (CERule fb rb) = CERule (va . fb) rb + (CERule fa ra) >>> (CEEpsRule vb) = CERule (flip ($) vb . fa) ra + (CERule fa ra) >>> (CERule fb rb) = CERule (uncurry fa) ((\va vb -> (va, fb vb)) $>> ra >>> rb) + ra ||| rb = CERule id $ runCERule ra ||| runCERule rb + die = CERule id die + +instance (EpsProductionRule p) => EpsProductionRule (CombineEpsilonsRule p phi r t) where + epsilon = CEEpsRule + +instance (EpsProductionRule p) => LiftableProductionRule (CombineEpsilonsRule p phi r t) where + epsilonL v _ = CEEpsRule v + +instance (TokenProductionRule p t) => + TokenProductionRule (CombineEpsilonsRule p phi r t) t where + token = CERule id . token + +instance (RecProductionRule p phi r) => + RecProductionRule (CombineEpsilonsRule p phi r t) phi r where + ref = CERule id . ref + +instance (EpsProductionRule p, LoopProductionRule p phi r) => + LoopProductionRule (CombineEpsilonsRule p phi r t) phi r where + manyRef = CERule id . manyRef + many1Ref = CERule id . many1Ref + +runCERule :: (ProductionRule p, EpsProductionRule p) => + CombineEpsilonsRule p phi r t v -> p v +runCERule (CERule f r) = f $>> r +runCERule (CEEpsRule v) = epsilon v + +-- | Combine consecutive epsilon rules in a given grammar into a single +-- epsilon rule. +combineEpsilons :: forall phi t r rr. + GContextFreeGrammar phi t r rr -> + GContextFreeGrammar phi t r rr +combineEpsilons gram idx = runCERule $ gram idx + +-- | Combine consecutive epsilon rules in a given extended +-- grammar into a single epsilon rule. +combineEpsilonsE :: forall phi t r rr. + GExtendedContextFreeGrammar phi t r rr -> + GExtendedContextFreeGrammar phi t r rr +combineEpsilonsE gram idx = runCERule $ gram idx + diff --git a/Text/GrammarCombinators/Transform/FilterDies.hs b/Text/GrammarCombinators/Transform/FilterDies.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/FilterDies.hs @@ -0,0 +1,94 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Transform.FilterDies ( + filterDies, + filterDiesE, + filterDiesLE + ) where + +import Text.GrammarCombinators.Base + +data FilterDiesRule p (phi :: * -> *) (r :: * -> *) t v = + FDBaseRule (p v) + | FDDieRule + +instance ProductionRule p => + ProductionRule (FilterDiesRule p phi r t) where + endOfInput = FDBaseRule endOfInput + FDDieRule >>> _ = FDDieRule + _ >>> FDDieRule = FDDieRule + (FDBaseRule ra) >>> (FDBaseRule rb) = FDBaseRule $ ra >>> rb + FDDieRule ||| rb = rb + (FDBaseRule ra) ||| fdrb = + FDBaseRule $ case fdrb of FDDieRule -> ra + (FDBaseRule rb) -> ra ||| rb + die = FDDieRule + +instance (EpsProductionRule p) => + EpsProductionRule (FilterDiesRule p phi r t) where + epsilon = FDBaseRule . epsilon + +instance (LiftableProductionRule p) => + LiftableProductionRule (FilterDiesRule p phi r t) where + epsilonL v q = FDBaseRule $ epsilonL v q + +instance (TokenProductionRule p t) => + TokenProductionRule (FilterDiesRule p phi r t) t where + token = FDBaseRule . token + +instance (RecProductionRule p phi r) => + RecProductionRule (FilterDiesRule p phi r t) phi r where + ref = FDBaseRule . ref + +instance (LoopProductionRule p phi r) => + LoopProductionRule (FilterDiesRule p phi r t) phi r where + manyRef = FDBaseRule . manyRef + many1Ref = FDBaseRule . many1Ref + +runFDRule :: (ProductionRule p) => + FilterDiesRule p phi r t v -> p v +runFDRule FDDieRule = die +runFDRule (FDBaseRule r) = r + +-- | Filter dead branches from a given context-free grammar. +filterDies :: forall phi t r rr. + GContextFreeGrammar phi t r rr -> + GContextFreeGrammar phi t r rr +filterDies gram idx = runFDRule $ gram idx + +-- | Filter dead branches from a given extended context-free grammar. +filterDiesE :: forall phi t r rr. + GExtendedContextFreeGrammar phi t r rr -> + GExtendedContextFreeGrammar phi t r rr +filterDiesE gram idx = runFDRule $ gram idx + +-- | Filter dead branches from a given extended context-free grammar. +filterDiesLE :: forall phi t r rr. + GLExtendedContextFreeGrammar phi t r rr -> + GLExtendedContextFreeGrammar phi t r rr +filterDiesLE gram idx = runFDRule $ gram idx + diff --git a/Text/GrammarCombinators/Transform/FoldLoops.hs b/Text/GrammarCombinators/Transform/FoldLoops.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/FoldLoops.hs @@ -0,0 +1,186 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Text.GrammarCombinators.Transform.FoldLoops ( + FLBaseIx, FLManyIx, + Memo (FLM), + FoldLoopsDomain (FLBase, FLMany), + FoldLoopsValue (..), + FoldLoopsResultValue (..), + processFoldLoops, + foldLoops, + foldAndProcessLoops + ) where + +import Text.GrammarCombinators.Base + +-- | A parametrised type such that 'FLBaseIx' ix represents +-- base non-terminal ix. +data FLBaseIx ix +-- | A parametrised type such that 'FLBaseIx' ix represents +-- the Kleene-'*' version of base non-terminal ix. +data FLManyIx ix + +-- | FoldLoopsDomain phi defines, for base domain phi, an +-- extended domain containing non-terminal types +-- 'FLBaseIx' ix representing base non-terminal ix, and +-- 'FLManyIx' ix representing a Kleene-* version of base +-- non-terminal ix. +data FoldLoopsDomain phi ix where + + FLBase :: phi ix -> FoldLoopsDomain phi (FLBaseIx ix) + FLMany :: phi ix -> FoldLoopsDomain phi (FLManyIx ix) + +instance (FoldFam phi) => FoldFam (FoldLoopsDomain phi) where + foldFam f n = + foldFam (f . FLMany) $ + foldFam (f . FLBase) n + +instance (ShowFam phi) => ShowFam (FoldLoopsDomain phi) where + showIdx (FLBase idx) = showIdx idx + showIdx (FLMany idx) = showIdx idx ++ "*" + +instance (EqFam phi) => EqFam (FoldLoopsDomain phi) where + overrideIdx f (FLBase idx) v (FLBase idx') = unSubVal $ overrideIdx (MkSubVal . f . FLBase) idx (MkSubVal v) idx' + overrideIdx f (FLMany idx) v (FLMany idx') = unSubVal $ overrideIdx (MkSubVal . f . FLMany) idx (MkSubVal v) idx' + overrideIdx f _ _ idx = f idx + +instance DomainMap (FoldLoopsDomain phi) phi FLBaseIx where + supIx = FLBase + subIx (FLBase idx) = idx + +instance DomainMap (FoldLoopsDomain phi) phi FLManyIx where + supIx = FLMany + subIx (FLMany idx) = idx + +instance (MemoFam phi) => MemoFam (FoldLoopsDomain phi) where + data Memo (FoldLoopsDomain phi) v = FLM (Memo phi (SubVal FLBaseIx v)) (Memo phi (SubVal FLManyIx v)) + fromMemo (FLM mb _) (FLBase idx) = unSubVal $ fromMemo mb idx + fromMemo (FLM _ mm) (FLMany idx) = unSubVal $ fromMemo mm idx + toMemo f = FLM (toMemo $ MkSubVal . f . FLBase) (toMemo $ MkSubVal . f . FLMany) + +instance Domain phi => Domain (FoldLoopsDomain phi) + +-- | FoldLoopsValue defines, for a semantic value family +-- r over base domain phi, a semantic value family +-- 'FoldLoopsValue' r over domain 'FoldLoopsDomain' r, such +-- that the semantic value for base non-terminal 'FLBaseIx' +-- is a wrapped version of type r ix, and for Kleene-* non-terminal +-- 'FLManyIx' a wrapped version of type [r ix]. +data family FoldLoopsValue (r :: * -> *) ix +newtype instance FoldLoopsValue r (FLBaseIx ix) = FLBV { unFLBV :: r ix } deriving (Show) +newtype instance FoldLoopsValue r (FLManyIx ix) = FLMV { unFLMV :: [r ix] } deriving (Show) + +-- | FoldLoopsResultValue defines, for semantic value families +-- r and rr over base domain phi, a semantic value family +-- 'FoldLoopsResultValue' r rr over domain 'FoldLoopsDomain' r. +-- such that the semantic value for base non-terminal 'FLBaseIx' +-- is a wrapped version of type rr ix, and for Kleene-* non-terminal +-- 'FLManyIx' a wrapped version of type [r ix]. +data family FoldLoopsResultValue (r :: * -> *) (rr :: * -> *) ix +newtype instance FoldLoopsResultValue r rr (FLBaseIx ix) = FLRBV { unFLRBV :: rr ix } +newtype instance FoldLoopsResultValue r rr (FLManyIx ix) = FLRMV { unFLRMV :: [r ix] } + +data FLWrap p unused1 unused2 phi r t v where + FLW :: p v -> FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v +unFLW :: FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v -> p v +unFLW (FLW p) = p + +instance (ProductionRule p) => + ProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where + (FLW a) >>> (FLW b) = FLW $ a >>> b + (FLW a) ||| (FLW b) = FLW $ a ||| b + die = FLW die + endOfInput = FLW endOfInput + +instance (EpsProductionRule p) => + EpsProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where + epsilon = FLW . epsilon + +instance (LiftableProductionRule p) => + LiftableProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where + epsilonL v q = FLW $ epsilonL v q + +instance (TokenProductionRule p t) => + TokenProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) t where + token = FLW . token + +instance (RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r), + ProductionRule p, EpsProductionRule p) => + RecProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where + ref idx = FLW $ epsilon (\(FLBV v) -> v) >>> ref (FLBase idx) + +instance (ProductionRule p, EpsProductionRule p, LiftableProductionRule p, + TokenProductionRule p t, RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r)) => + LoopProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where + manyRef idx = FLW $ epsilon (\(FLMV lv) -> lv) >>> ref (FLMany idx) + +-- | Construct a processor for a grammar transformed using the 'foldLoops' algorithm, +-- given a processor for the original grammar. +processFoldLoops :: forall phi r rr. GProcessor phi r rr -> GProcessor (FoldLoopsDomain phi) (FoldLoopsValue r) (FoldLoopsResultValue r rr) +processFoldLoops proc (FLBase (idx :: phi ix')) (FLRBV v) = FLBV $ proc idx v +processFoldLoops _ (FLMany _) (FLRMV vs) = FLMV vs + +-- | Transform a given extended context-free grammar over a domain 'phi' into a standard +-- context-free grammar over the extended domain 'FoldLoopsDomain' 'phi'. +-- Calls to 'manyRef' idx are transformed into calls to 'ref' ('FLMany' idx), +-- where 'FLMany' idx is a new non-terminal representing the +-- Kleene-* version of underlying non-terminal 'idx'. Normal +-- calls to 'ref' idx are transformed into calls to 'ref' +-- ('FLBase' idx) where 'FLBase' idx represents the unmodified +-- underlying non-terminal 'idx'. The 'foldLoops' algorithm +-- constructs appropriate production rules for both types of +-- new non-terminals. +-- Values are wrapped in the 'FoldLoopsResultValue' 'r' 'rr' +-- semantic value family. +foldLoops :: + GExtendedContextFreeGrammar phi t r rr -> + GContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r) (FoldLoopsResultValue r rr) +foldLoops bgram (FLBase (idx :: phi ix)) = + epsilon FLRBV >>> unFLW (bgram idx) +foldLoops _ (FLMany idx) = + epsilon (\(FLBV v) (FLMV vs) -> FLRMV (v:vs)) >>> + ref (FLBase idx) >>> ref (FLMany idx) + ||| epsilon (FLRMV []) + +-- | Transform a given processing extended context-free +-- grammar over a domain 'phi' into a standard context-free +-- grammar over the extended domain 'FoldLoopsDomain phi'. +-- Completely similar to 'foldLoops', but wraps values in the +-- 'FoldLoopsValue' 'r' semantic value family. +foldAndProcessLoops :: + forall phi t r . Token t => + ProcessingExtendedContextFreeGrammar phi t r-> + ProcessingContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r) +foldAndProcessLoops gram = + let + loopsproc = processFoldLoops identityProcessor + in applyProcessor (foldLoops gram) loopsproc diff --git a/Text/GrammarCombinators/Transform/LeftCorner.hs b/Text/GrammarCombinators/Transform/LeftCorner.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/LeftCorner.hs @@ -0,0 +1,263 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Text.GrammarCombinators.Transform.LeftCorner ( + LCBaseIx, LCNTMinNTIx, LCNTMinTIx, + LCDomain (LCBase, LCNTMinNT, LCNTMinT), + LCValue( LCBV, LCNTMinNTV, LCNTMinTV ), + transformLeftCorner, + transformLeftCornerE + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.CalcFirst + +import Data.Map (Map, (!)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Enumerable +import Control.Applicative ((<*>)) + +-- NOTES: +-- recursion only through list of left-corner terminals, so we can handle non-processing CFG's? + +data LCBaseIx ix +data LCNTMinNTIx ix' ix +data LCNTMinTIx t ix + +-- | 'LCDomain' defines, for a base domain phi an extended +-- domain containing the non-terminals used by the left- +-- corner transform. +data LCDomain phi t ix where + LCBase :: phi ix -> LCDomain phi t (LCBaseIx ix) + LCNTMinNT :: phi ix' -> phi ix -> LCDomain phi t (LCNTMinNTIx ix' ix) + LCNTMinT :: t -> phi ix -> LCDomain phi t (LCNTMinTIx t ix) + +instance (ShowFam phi, Show t) => ShowFam (LCDomain phi t) where + showIdx (LCBase idx) = showIdx idx + showIdx (LCNTMinNT idx' idx) = showIdx idx ++ "-" ++ showIdx idx' + showIdx (LCNTMinT tt idx) = showIdx idx ++ "-" ++ show tt + +instance (Token t, FoldFam phi) => FoldFam (LCDomain phi t) where + foldFam (f :: forall ix. LCDomain phi t ix -> b -> b) n = + let n' = foldFam (f . LCBase) n + f' idx = foldFam (f . (LCNTMinNT `flip` idx)) + n'' = foldFam f' n' + f'' tt = foldFam (f . LCNTMinT tt) + n''' = foldr f'' n'' enumerate + in n''' + +newtype WrapLCNTMinNTMemo phi r ix' = + WLCNTMNTM { unWLCNTMNT :: Memo phi (SubVal (LCNTMinNTIx ix') r) } + +instance (MemoFam phi, Token t) => + MemoFam (LCDomain phi t) where + data Memo (LCDomain phi t) r = + MemoLCD (Memo phi (SubVal LCBaseIx r)) + (Memo phi (WrapLCNTMinNTMemo phi r)) + (Map t (Memo phi (SubVal (LCNTMinTIx t) r))) + toMemo f = MemoLCD (toMemo (MkSubVal . f . LCBase)) + (toMemo (WLCNTMNTM . (\idx' -> toMemo (MkSubVal . f . LCNTMinNT idx')))) + (Map.fromList (map (\tt -> (tt, toMemo (MkSubVal . f . LCNTMinT tt))) enumerate)) + fromMemo (MemoLCD mb _ _) (LCBase idx) = unSubVal $ fromMemo mb idx + fromMemo (MemoLCD _ mnmn _) (LCNTMinNT idx' idx) = + unSubVal $ fromMemo (unWLCNTMNT $ fromMemo mnmn idx') idx + fromMemo (MemoLCD _ _ mnmt) (LCNTMinT tt idx) = + unSubVal $ fromMemo (mnmt ! tt) idx + +instance (Domain phi, Token t) => Domain (LCDomain phi t) + +newtype WrapFSect phi r ix = WFS { + unWFS :: forall ix'. phi ix' -> r (LCNTMinNTIx ix ix') + } + +instance (EqFam phi, Token t) => EqFam (LCDomain phi t) where + overrideIdx f (LCBase idx) v (LCBase idx') = + unSubVal $ overrideIdx (MkSubVal . f . LCBase) idx (MkSubVal v) idx' + overrideIdx (f :: forall ix. LCDomain phi t ix -> r ix) (LCNTMinNT idx idxm) v (LCNTMinNT idx' idxm') = + let + fc :: forall ix ixm. phi ix -> phi ixm -> r (LCNTMinNTIx ix ixm) + fc idx'' idxm'' = f $ LCNTMinNT idx'' idxm'' + fsect' idxm'' = unSubVal $ overrideIdx (MkSubVal . fc idx) idxm (MkSubVal v) idxm'' + fc' :: forall ix ixm. phi ix -> phi ixm -> r (LCNTMinNTIx ix ixm) + fc' idxm'' = unWFS $ overrideIdx (\idx'' -> WFS $ fc idx'') idx (WFS fsect') idxm'' + in fc' idx' idxm' + overrideIdx f (LCNTMinT tt idx) v (LCNTMinT tt' idx') = + if tt == tt' + then unSubVal $ overrideIdx (MkSubVal . f . LCNTMinT tt) idx (MkSubVal v) idx' + else f (LCNTMinT tt' idx') + overrideIdx f _ _ idx' = f idx' + +instance DomainMap (LCDomain phi t) phi LCBaseIx where + supIx = LCBase + subIx (LCBase idx) = idx + +data family LCValue (r :: * -> *) t ix +data instance LCValue r t (LCBaseIx ix) = LCBV { unLCBV :: r ix } deriving (Show) +data instance LCValue r t (LCNTMinNTIx ix' ix) = LCNTMinNTV { unLCNTMinNTV :: r ix' -> r ix} +data instance LCValue r t (LCNTMinTIx t ix) = LCNTMinTV { unLCNTMinTV :: ConcreteToken t -> r ix } + +data TransformLCRule p (unused1 :: * -> *) (unused2 :: * -> *) (phi :: * -> *) (r :: * -> *) t v = + MkTLCIR { + tlcEmpty :: Maybe v, + tlcFull :: p v, + tlcNTMinNT :: forall ix'. phi ix' -> p (r ix' -> v), + tlcNTMinT :: t -> p (ConcreteToken t -> v) + } + +instance (ProductionRule p, + EpsProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + ProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where + ra >>> rb = + let + es = tlcEmpty ra <*> tlcEmpty rb + emptyA = maybe die epsilon $ tlcEmpty ra + f = tlcFull ra >>> tlcFull rb + rNTMinNT idx' = flip $>> tlcNTMinNT ra idx' >>> tlcFull rb + ||| (.) $>> emptyA >>> tlcNTMinNT rb idx' + rNTMinT tt = flip $>> tlcNTMinT ra tt >>> tlcFull rb + ||| (.) $>> emptyA >>> tlcNTMinT rb tt + in MkTLCIR es f rNTMinNT rNTMinT + ra ||| rb = + let + es = case (tlcEmpty ra, tlcEmpty rb) of + (Just _, Just _) -> error "Ambiguous: empty disjunction" + (Just va, Nothing) -> Just va + (Nothing, Just vb) -> Just vb + (Nothing, Nothing) -> Nothing + f = tlcFull ra ||| tlcFull rb + rNTMinNT idx' = tlcNTMinNT ra idx' ||| tlcNTMinNT rb idx' + rNTMinT tt = tlcNTMinT ra tt ||| tlcNTMinT rb tt + in MkTLCIR es f rNTMinNT rNTMinT + endOfInput = MkTLCIR Nothing endOfInput (const die) (const die) + die = MkTLCIR Nothing die (const die) (const die) + +instance (ProductionRule p, + EpsProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + EpsProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where + epsilon v = MkTLCIR (Just v) (epsilon v) (const die) (const die) + +instance (ProductionRule p, + EpsProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + LiftableProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where + epsilonL v _ = epsilon v + +instance (Token t, TokenProductionRule p t, ProductionRule p, + LiftableProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + TokenProductionRule (TransformLCRule p unused1 unused2 phi r t) t where + token tt = + let rNTMinT tt' = if tt == tt' then epsilonL id [|id|] else die + in MkTLCIR Nothing (token tt) (const die) rNTMinT + +newtype WrapNTMinNTP p r ix surrIx = + WNTMinNTP { unWNTMinNTP :: p (r surrIx -> r ix) } + +instance (ProductionRule p, EqFam phi, + EpsProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + RecProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where + ref idx = + let f = unLCBV $>> ref (LCBase idx) + rNTMinNT idxm = unWNTMinNTP $ overrideIdx (\_ -> WNTMinNTP die) idx (WNTMinNTP $ epsilon id) idxm + in MkTLCIR Nothing f rNTMinNT (const die) + +newtype WrapNTMinNTPs p r ix surrIx = + WNTMinNTPs { unWNTMinNTPs :: p (r surrIx -> [r ix]) } +instance (EqFam phi, + EpsProductionRule p, + LoopProductionRule p (LCDomain phi t) (LCValue r t)) => + LoopProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where + manyRef (idx :: phi ix) = + let f = map unLCBV $>> manyRef (LCBase idx) + rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx)) + rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm + in MkTLCIR Nothing f rNTMinNT (const die) + many1Ref (idx :: phi ix) = + let f = map unLCBV $>> many1Ref (LCBase idx) + rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx)) + rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm + in MkTLCIR Nothing f rNTMinNT (const die) + +transformLeftCorner' :: + forall p phi r t ix. + (Domain phi, Token t, TokenProductionRule p t, + ProductionRule p, + EpsProductionRule p, + RecProductionRule p (LCDomain phi t) (LCValue r t)) => + (forall ix'. phi ix' -> + TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t (r ix')) -> + (forall ix'. phi ix' -> FirstSet t) -> + LCDomain phi t ix -> + p (LCValue r t ix) +transformLeftCorner' _ cfs (LCBase idx) = + let FS fs _ _ = cfs idx -- TODO: what if it can be empty? + ruleT tt = flip ($) $>> token tt >>> (unLCNTMinTV $>> ref (LCNTMinT tt idx)) + ruleTs = LCBV $>> Set.fold ((|||) . ruleT) die fs + in ruleTs +transformLeftCorner' bgram _ (LCNTMinT tt idx) = + let + bMinT idxB = flip (.) $>> tlcNTMinT (bgram idxB) tt >>> (unLCNTMinNTV $>> ref (LCNTMinNT idxB idx)) + bMinTs = foldFam ((|||) . bMinT) die + in LCNTMinTV $>> bMinTs + ||| LCNTMinTV $>> tlcNTMinT (bgram idx) tt +transformLeftCorner' bgram _ (LCNTMinNT idxm idx) = + let + cMinB idxC = LCNTMinNTV $>> (flip (.) $>> tlcNTMinNT (bgram idxC) idxm >>> follow idxC) + baseFollow idxC = unLCNTMinNTV $>> ref (LCNTMinNT idxC idx) + follow idxC = unWNTMinNTP $ overrideIdx (WNTMinNTP . baseFollow) idx (WNTMinNTP $ baseFollow idx ||| epsilon id) idxC + in -- flip (|||) produces alternatives in a better order, typically + foldFam (flip (|||) . cMinB) die + +-- | Apply the left-corner transform to a given grammar, removing direct and indirect left recursion. +-- +-- Note that the new domain will contain O(n*t + n^2) +-- non-terminals where n is the amount of non-terminals and t is the +-- number of tokens, so when using this transformation, it can be beneficial to +-- use a token type with a more limited amount of token values than 'Char', at +-- least if you will use algorithms that fold over the full new grammar's domain +-- (e.g. 'printGrammar' does, 'printReachableGrammar' doesn't). +transformLeftCorner :: + (Domain phi, Token t) => + ProcessingContextFreeGrammar phi t r -> + ProcessingContextFreeGrammar (LCDomain phi t) t (LCValue r t) +transformLeftCorner gram idx = transformLeftCorner' gram (calcFirst gram) idx + +-- | Apply the left-corner transform to a given extended grammar, removing direct and indirect left recursion. +transformLeftCornerE :: + forall phi t r. (Domain phi, Token t) => + ProcessingExtendedContextFreeGrammar phi t r -> + ProcessingExtendedContextFreeGrammar (LCDomain phi t) t (LCValue r t) +transformLeftCornerE gram idx = transformLeftCorner' gram (calcFirst gram) idx diff --git a/Text/GrammarCombinators/Transform/OptimizeGrammar.hs b/Text/GrammarCombinators/Transform/OptimizeGrammar.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/OptimizeGrammar.hs @@ -0,0 +1,39 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Text.GrammarCombinators.Transform.OptimizeGrammar where + +-- just a combination of some transforms (in a correct order) +-- TODO: check order + +import Text.GrammarCombinators.Base + +import Text.GrammarCombinators.Transform.CombineEpsilons +import Text.GrammarCombinators.Transform.FilterDies +import Text.GrammarCombinators.Transform.UnfoldDead +import Text.GrammarCombinators.Transform.UniformPaull +import Text.GrammarCombinators.Transform.UnfoldChainNTs + +optimizeGrammarE :: (Token t, Domain phi) => + ProcessingExtendedContextFreeGrammar phi t r -> + ProcessingExtendedContextFreeGrammar (UPDomain phi) t (UPValue r) +optimizeGrammarE g = combineEpsilonsE (unfoldChainNTsE (filterDiesE (unfoldDeadE (transformUniformPaullE g)))) diff --git a/Text/GrammarCombinators/Transform/UnfoldChainNTs.hs b/Text/GrammarCombinators/Transform/UnfoldChainNTs.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/UnfoldChainNTs.hs @@ -0,0 +1,107 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Transform.UnfoldChainNTs ( + unfoldChainNTs, + unfoldChainNTsE + ) where + +import Text.GrammarCombinators.Base + +import Text.GrammarCombinators.Utils.IsChainNT +import Text.GrammarCombinators.Transform.UnfoldRecursion +import Text.GrammarCombinators.Transform.UnfoldLoops + +-- | Unfold chain non-terminals in a given context- +-- free grammar. +-- A chain non-terminal is a terminal such that its +-- production rule is a numer of epsilons followed by a +-- single normal reference to another non-terminal. +unfoldChainNTs :: forall phi r t. (EqFam phi) => + ProcessingContextFreeGrammar phi r t -> + ProcessingContextFreeGrammar phi r t +unfoldChainNTs gram idx = + let + gram' :: ProcessingContextFreeGrammar phi r t + gram' idx' = if isChainNT (unfoldChainNTs gram) idx' + then unfoldChainNTs gram idx' + else ref idx' + in unfoldRule (gram idx) gram' + +data RuleToManyWrapper p (phi :: * -> *) (r :: * -> *) t v = + RTMEps v | + RTMW { ruleToManyRule :: p [v], + ruleToMany1Rule :: p [v] } + +instance (ProductionRule p, EpsProductionRule p) => + ProductionRule (RuleToManyWrapper p phi r t) where + (RTMEps va) >>> (RTMEps vb) = RTMEps $ va vb + (RTMEps va) >>> (RTMW rmb rm1b) = RTMW (map va $>> rmb) (map va $>> rm1b) + (RTMW rma rm1a) >>> (RTMEps vb) = RTMW (map ($ vb) $>> rma) (map ($ vb) $>> rm1a) + (RTMW _ _ ) >>> (RTMW _ _) = RTMW die die + _ ||| _ = RTMW die die + die = RTMW die die + endOfInput = RTMW die die + +instance (ProductionRule p, EpsProductionRule p) => EpsProductionRule (RuleToManyWrapper p phi r t) where + epsilon = RTMEps + +instance (ProductionRule p, EpsProductionRule p) => LiftableProductionRule (RuleToManyWrapper p phi r t) where + epsilonL v _ = RTMEps v + +instance (ProductionRule p) => TokenProductionRule (RuleToManyWrapper p phi r t) t where + token _ = RTMW die die + +instance (LoopProductionRule p phi r) => + RecProductionRule (RuleToManyWrapper p phi r t) phi r where + ref idx = RTMW (manyRef idx) (many1Ref idx) + +instance (ProductionRule p, EpsProductionRule p, LoopProductionRule p phi r) => + LoopProductionRule (RuleToManyWrapper p phi r t) phi r where + manyRef _ = RTMW die die + many1Ref _ = RTMW die die + +-- | Unfold chain non-terminals in a given extended +-- context-free grammar. +-- A chain non-terminal is a terminal such that its +-- production rule is a numer of epsilons followed by a +-- single normal reference to another non-terminal. +unfoldChainNTsE :: forall phi r t. (EqFam phi) => + ProcessingExtendedContextFreeGrammar phi r t -> + ProcessingExtendedContextFreeGrammar phi r t +unfoldChainNTsE gram idx = + let gramm' idx' = if isChainNT (unfoldChainNTsE gram) idx' + then ruleToManyRule (unfoldChainNTsE gram idx') + else manyRef idx' + gramm1' idx' = if isChainNT (unfoldChainNTsE gram) idx' + then ruleToMany1Rule (unfoldChainNTsE gram idx') + else many1Ref idx' + gram' :: ProcessingExtendedContextFreeGrammar phi r t + gram' idx' = if isChainNT (unfoldChainNTsE gram) idx' + then unfoldChainNTsE gram idx' + else ref idx' + in replaceLoopsRule (unfoldRuleE (gram idx) gram') gramm' gramm1' + +-- TODO: unfold chain rules -> useful? diff --git a/Text/GrammarCombinators/Transform/UnfoldDead.hs b/Text/GrammarCombinators/Transform/UnfoldDead.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/UnfoldDead.hs @@ -0,0 +1,99 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Text.GrammarCombinators.Transform.UnfoldDead ( + unfoldDead, + unfoldDeadE, + unfoldDeadLE + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.IsDead + +newtype UnfoldDeadRule p (phi :: * -> *) (r :: * -> *) t v = + UDRule { unUDRule :: (forall ix. phi ix -> Bool) -> p v } + +instance (ProductionRule p) => + ProductionRule (UnfoldDeadRule p phi r t) where + a >>> b = UDRule $ \g -> unUDRule a g >>> unUDRule b g + a ||| b = UDRule $ \g -> unUDRule a g ||| unUDRule b g + die = UDRule $ \_ -> die + endOfInput = UDRule $ \_ -> endOfInput + +instance (EpsProductionRule p) => + EpsProductionRule (UnfoldDeadRule p phi r t) where + epsilon v = UDRule $ \_ -> epsilon v + +instance (LiftableProductionRule p) => + LiftableProductionRule (UnfoldDeadRule p phi r t) where + epsilonL v q = UDRule $ \_ -> epsilonL v q + +instance (TokenProductionRule p t) => + TokenProductionRule (UnfoldDeadRule p phi r t) t where + token t = UDRule $ \_ -> token t + +instance (ProductionRule p, + RecProductionRule p phi r) => + RecProductionRule (UnfoldDeadRule p phi r t) phi r where + ref idx = UDRule $ \g -> if g idx then die else ref idx + +instance (ProductionRule p, + LiftableProductionRule p, + LoopProductionRule p phi r) => + LoopProductionRule (UnfoldDeadRule p phi r t) phi r where + manyRef idx = UDRule $ \g -> if g idx then epsilonL [] [| [] |] else manyRef idx + many1Ref idx = UDRule $ \g -> if g idx then die else many1Ref idx + +-- | Unfold dead non-terminals in a given extended context- +-- free grammar, such +-- that the unfolded references can be filtered with the +-- 'filterDies' algorithm. This uses the 'isDead' algorithm +-- to detect dead non-terminals. +unfoldDeadE :: (EqFam phi, FoldFam phi, MemoFam phi) => + GExtendedContextFreeGrammar phi r t rr -> + GExtendedContextFreeGrammar phi r t rr +unfoldDeadE gram idx = unUDRule (gram idx) $ isDead gram + +-- | Unfold dead non-terminals in a given extended liftable context- +-- free grammar, such +-- that the unfolded references can be filtered with the +-- 'filterDies' algorithm. This uses the 'isDead' algorithm +-- to detect dead non-terminals. +unfoldDeadLE :: (EqFam phi, FoldFam phi, MemoFam phi) => + GLExtendedContextFreeGrammar phi r t rr -> + GLExtendedContextFreeGrammar phi r t rr +unfoldDeadLE gram idx = unUDRule (gram idx) $ isDead gram + +-- | Unfold dead non-terminals in a given context- +-- free grammar, such +-- that the unfolded references can be filtered with the +-- 'filterDies' algorithm. This uses the 'isDead' algorithm +-- to detect dead non-terminals. +unfoldDead :: (EqFam phi, FoldFam phi, MemoFam phi) => + GContextFreeGrammar phi r t rr -> + GContextFreeGrammar phi r t rr +unfoldDead gram idx = unUDRule (gram idx) $ isDead gram diff --git a/Text/GrammarCombinators/Transform/UnfoldLoops.hs b/Text/GrammarCombinators/Transform/UnfoldLoops.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/UnfoldLoops.hs @@ -0,0 +1,105 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Transform.UnfoldLoops ( + unfoldLoops, + unfoldLoopsRule, + replaceLoopsRule + ) where + +import Text.GrammarCombinators.Base + +newtype UnfoldLoopsWrapper p (phi :: * -> *) ixT (r :: * -> *) t v = ULW { + runULW :: (forall ix. phi ix -> p [r ix]) -> (forall ix. phi ix -> p [r ix]) -> p v + } + +instance (ProductionRule p) => + ProductionRule (UnfoldLoopsWrapper p phi ixT r t) where + ra >>> rb = ULW $ \gm gm1 -> runULW ra gm gm1 >>> runULW rb gm gm1 + ra ||| rb = ULW $ \gm gm1 -> runULW ra gm gm1 ||| runULW rb gm gm1 + die = ULW $ \_ _ -> die + endOfInput = ULW $ \_ _ -> endOfInput + +instance (LiftableProductionRule p) => + LiftableProductionRule (UnfoldLoopsWrapper p phi ixT r t) where + epsilonL v q = ULW $ \_ _ -> epsilonL v q + +instance (EpsProductionRule p) => + EpsProductionRule (UnfoldLoopsWrapper p phi ixT r t) where + epsilon v = ULW $ \_ _ -> epsilon v + +-- no newtype deriving for multi param type classes? +instance (TokenProductionRule p t) => + TokenProductionRule (UnfoldLoopsWrapper p phi ixT r t) t where + token t = ULW $ \_ _ -> token t + +instance (RecProductionRule p phi r) => + RecProductionRule (UnfoldLoopsWrapper p phi ixT r t) phi r where + ref idx = ULW $ \_ _ -> ref idx + +instance (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r) => + LoopProductionRule (UnfoldLoopsWrapper p phi ixT r t) phi r where + manyRef idx = ULW $ \gm _ -> gm idx + many1Ref idx = ULW $ \_ gm1 -> gm1 idx + +-- | Unfold loops in a given grammar, replacing calls to +-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise +-- for 'many1Ref' +unfoldLoops :: + GExtendedContextFreeGrammar phi t r rr -> + GContextFreeGrammar phi t r rr +unfoldLoops gram idx = + unfoldLoopsRule (gram idx) + +-- | Unfold loops in a given rule, replacing calls to +-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise +-- for 'many1Ref' +unfoldLoopsRule :: + ExtendedContextFreeRule phi r t v -> + ContextFreeRule phi r t v +unfoldLoopsRule r = + let + manyGram idx = manyInf $ ref idx + oneOrMoreGram idx = (:) $>> ref idx >>> manyGram idx + in replaceLoopsRule r manyGram oneOrMoreGram + +-- | Replace loops in a given rule by rules provided +-- in two provided sets of rules, replacing calls to +-- 'manyRef' by the corresponding rule from the first +-- set, and calls to 'manyRef' by the corresponding rule +-- from the second set. You likely don't need this +-- and should be looking at 'unfoldLoops' or +-- 'unfoldLoopsRule' instead. +replaceLoopsRule :: + (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) => + ExtendedContextFreeRule phi r t v -> + (forall ix. phi ix -> p [r ix]) -> + (forall ix. phi ix -> p [r ix]) -> + p v +replaceLoopsRule r = + runULW r + diff --git a/Text/GrammarCombinators/Transform/UnfoldRecursion.hs b/Text/GrammarCombinators/Transform/UnfoldRecursion.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/UnfoldRecursion.hs @@ -0,0 +1,189 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Transform.UnfoldRecursion ( + UnfoldDepth, + unfoldRecursion, + unfoldRecursionE, + selectNothing, + selectAllOnce, + selectNT, + modifyUnfoldDepth, + unfoldSelective, + unfoldSelectiveE, + unfoldRule, + unfoldRuleE + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.UnfoldLoops + +data RPWRule p phi ixT r t v = + RPWRule { unRPWRule :: (forall ix. phi ix -> p (r ix)) -> p v } + +instance (ProductionRule p) => + ProductionRule (RPWRule p phi ixT r t) where + a >>> b = RPWRule $ \g -> unRPWRule a g >>> unRPWRule b g + a ||| b = RPWRule $ \g -> unRPWRule a g ||| unRPWRule b g + die = RPWRule $ const die + endOfInput = RPWRule $ const endOfInput + +instance (LiftableProductionRule p) => + LiftableProductionRule (RPWRule p phi ixT r t) where + epsilonL v q = RPWRule $ \_ -> epsilonL v q + +instance (EpsProductionRule p) => + EpsProductionRule (RPWRule p phi ixT r t) where + epsilon v = RPWRule $ \_ -> epsilon v + +instance (TokenProductionRule p t) => + TokenProductionRule (RPWRule p phi ixT r t) t where + token c = RPWRule $ \_ -> token c + +instance (ProductionRule p) => + RecProductionRule (RPWRule p phi ixT r t) phi r where + ref idx = RPWRule $ \g -> g idx + +instance (LoopProductionRule p phi r) => + LoopProductionRule (RPWRule p phi ixT r t) phi r where + -- we don't unfold loops, use unfoldLoops for that... + manyRef idx = RPWRule $ \_ -> manyRef idx + many1Ref idx = RPWRule $ \_ -> many1Ref idx + +-- | Unfold recursion in a given contextx-free grammar, replacing +-- calls to +-- 'ref' idx with the non-terminal's production rule. This produces +-- production rules similar to those in traditional parser combinator +-- libraries. +unfoldRecursion :: + ProcessingContextFreeGrammar phi t r -> + ProcessingRegularGrammar phi t r +unfoldRecursion gram idx = + unRPWRule (gram idx) $ unfoldRecursion gram + +-- | Unfold recursion in a given extended context-free grammar, +-- replacing calls to +-- 'ref' idx with the non-terminal's production rule. This produces +-- production rules similar to those in traditional parser combinator +-- libraries. +unfoldRecursionE :: + ProcessingExtendedContextFreeGrammar phi t r -> + ProcessingRegularGrammar phi t r +unfoldRecursionE gram = unfoldRecursion (unfoldLoops gram) + +-- instance (ProductionRule p) => SuperProductionRule (RPWRule p) where +-- subref subgram idxb = rpwSubRef (subgram idxb) idxb + +-- rpwSubRef :: forall p phi phi' supIxT ixT r ix t . +-- (DomainEmbedding phi phi' supIxT, HFunctor phi (PF phi), ProductionRule p) => +-- RPWRule p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix) -> +-- phi' ix -> phi (supIxT ix) -> +-- RPWRule p phi ixT r t (PF phi r (supIxT ix)) +-- rpwSubRef (RPWRule subintrule) idxb idx = RPWRule $ \outgram -> +-- let +-- restrictedGrammar :: forall ix'. phi' ix' -> p ((SubVal supIxT r) ix') +-- restrictedGrammar idx' = epsilon MkSubVal >>> outgram (supIx idx') +-- presult' :: p (PF phi' (SubVal supIxT r) ix) +-- presult' = subintrule restrictedGrammar +-- in epsilon (supPF idxb idx) >>> presult' + +-- | A value of type UnfoldDepth defines for each non-terminal in a +-- grammar how many times it should be unfolded by the 'unfoldSelective' +-- or 'unfoldSelectiveE' algorithms. +type UnfoldDepth phi = forall ix. phi ix -> Integer + +-- | A value of type 'UnfoldDepth' phi indicating nothing should be +-- unfolded at all. This can be used as a start value and then further +-- modified with the 'selectNT' function. +selectNothing :: UnfoldDepth phi +selectNothing _ = 0 + +-- | A value of type 'UnfoldDepth' phi indicating every non-terminal +-- should be unfolded once. +selectAllOnce :: UnfoldDepth phi +selectAllOnce _ = 1 + +-- | A function modifying a given 'UnfoldDepth' phi by applying a given +-- function to the depth for a given non-terminal. +modifyUnfoldDepth :: (EqFam phi) => UnfoldDepth phi -> (Integer -> Integer) -> phi ix -> UnfoldDepth phi +modifyUnfoldDepth base f idx = overrideIdxK base idx $ f $ base idx + +-- | A function modifying a given 'UnfoldDepth' phi by increasing +-- the depth for a given non-terminal by 1. +selectNT :: (EqFam phi) => UnfoldDepth phi -> phi ix -> UnfoldDepth phi +selectNT base = modifyUnfoldDepth base (+1) + +type RPWGrammar p phi ixT r v t = + forall ix. phi ix -> RPWRule p phi ixT r t (v ix) + +unfoldSelective' :: (EqFam phi, RecProductionRule p phi r) => + UnfoldDepth phi -> + RPWGrammar p phi ixT r r t -> + (forall ix. phi ix -> p (r ix)) +unfoldSelective' sel gram idx = + let + rg idx' = if sel idx' > 0 + then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx) gram idx' + else ref idx' + in unRPWRule (gram idx) rg + +-- | Selectively unfold a given context-free grammar according to a +-- given 'UnfoldDepth'. +unfoldSelective :: (EqFam phi) => + UnfoldDepth phi -> + ProcessingContextFreeGrammar phi t r -> + ProcessingContextFreeGrammar phi t r +unfoldSelective sel gram idx = unfoldSelective' sel gram idx + +-- | Selectively unfold a given extended context-free grammar +-- according to a given 'UnfoldDepth'. +unfoldSelectiveE :: (EqFam phi) => + UnfoldDepth phi -> + ProcessingExtendedContextFreeGrammar phi t r -> + ProcessingExtendedContextFreeGrammar phi t r +unfoldSelectiveE sel gram idx = + let + rg idx' = if sel idx' > 0 + then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx') gram idx' + else ref idx' + in unRPWRule (gram idx) rg + +-- | Unfold a given context-free rule by replacing all references to +-- non-terminals with the production rule for that non-terminal in +-- a given processing context-free grammar. +unfoldRule :: ContextFreeRule phi r t v -> + ProcessingContextFreeGrammar phi t r -> + ContextFreeRule phi r t v +unfoldRule r g = unRPWRule r g + +-- | Unfold a given extended context-free rule by replacing all +-- references to +-- non-terminals with the production rule for that non-terminal in +-- a given processing extended context-free grammar. +unfoldRuleE :: ExtendedContextFreeRule phi r t v -> + ProcessingExtendedContextFreeGrammar phi t r -> + ExtendedContextFreeRule phi r t v +unfoldRuleE r g = unRPWRule r g diff --git a/Text/GrammarCombinators/Transform/UniformPaull.hs b/Text/GrammarCombinators/Transform/UniformPaull.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Transform/UniformPaull.hs @@ -0,0 +1,317 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Text.GrammarCombinators.Transform.UniformPaull ( + UPDomain ( UPBase, UPHead, UPTail ) + , UPBaseIx, UPHeadIx, UPTailIx + , UPValue ( UPBV, UPHV, UPTV ) + , unUPBV, unUPHV, unUPTV + , transformUniformPaull + , transformUniformPaullE + , transformUniformPaullLE + ) where + +import Text.GrammarCombinators.Base + +import Control.Monad (ap, liftM2) + +import Data.Maybe (isJust, fromMaybe) + +import Language.Haskell.TH.Syntax + +data UPBaseIx ix +data UPHeadIx ix +data UPTailIx ix + +data UPDomain phi ix where + UPBase :: phi ix -> UPDomain phi (UPBaseIx ix) + UPHead :: phi ix -> UPDomain phi (UPHeadIx ix) + UPTail :: phi ix -> UPDomain phi (UPTailIx ix) + +instance (FoldFam phi) => FoldFam (UPDomain phi) where + foldFam (f :: forall ix. UPDomain phi ix -> b -> b) = + foldFam (\idx -> f (UPBase idx) . f (UPHead idx) . f (UPTail idx)) + +instance (ShowFam phi) => ShowFam (UPDomain phi) where + showIdx (UPBase idx) = showIdx idx + showIdx (UPHead idx) = showIdx idx ++ "_head" + showIdx (UPTail idx) = showIdx idx ++ "_tail" + +instance (LiftFam phi) => LiftFam (UPDomain phi) where + liftIdxE (UPBase idx) = AppE (ConE 'UPBase) $ liftIdxE idx + liftIdxE (UPHead idx) = AppE (ConE 'UPHead) $ liftIdxE idx + liftIdxE (UPTail idx) = AppE (ConE 'UPTail) $ liftIdxE idx + liftIdxP (UPBase idx) = ConP 'UPBase [liftIdxP idx] + liftIdxP (UPHead idx) = ConP 'UPHead [liftIdxP idx] + liftIdxP (UPTail idx) = ConP 'UPTail [liftIdxP idx] + +instance (EqFam phi) => EqFam (UPDomain phi) where + overrideIdx f (UPBase idx) v (UPBase idx') = + unSubVal $ overrideIdx (MkSubVal . f . UPBase) idx (MkSubVal v) idx' + overrideIdx f (UPHead idx) v (UPHead idx') = + unSubVal $ overrideIdx (MkSubVal . f . UPHead) idx (MkSubVal v) idx' + overrideIdx f (UPTail idx) v (UPTail idx') = + unSubVal $ overrideIdx (MkSubVal . f . UPTail) idx (MkSubVal v) idx' + overrideIdx f _ _ idx' = f idx' + +instance DomainMap (UPDomain phi) phi UPBaseIx where + supIx = UPBase + subIx (UPBase idx) = idx + +instance DomainMap (UPDomain phi) phi UPHeadIx where + supIx = UPHead + subIx (UPHead idx) = idx + +instance DomainMap (UPDomain phi) phi UPTailIx where + supIx = UPTail + subIx (UPTail idx) = idx + +instance (MemoFam phi) => MemoFam (UPDomain phi) where + data Memo (UPDomain phi) v = UPMemo (Memo phi (SubVal UPBaseIx v)) (Memo phi (SubVal UPHeadIx v)) (Memo phi (SubVal UPTailIx v)) + fromMemo (UPMemo mb _ _) (UPBase idx) = unSubVal $ fromMemo mb idx + fromMemo (UPMemo _ mh _) (UPHead idx) = unSubVal $ fromMemo mh idx + fromMemo (UPMemo _ _ mt) (UPTail idx) = unSubVal $ fromMemo mt idx + toMemo f = UPMemo (toMemo $ MkSubVal . f . UPBase) (toMemo $ MkSubVal . f . UPHead) (toMemo $ MkSubVal . f . UPTail) + +instance Domain phi => Domain (UPDomain phi) + +data family UPValue (r :: * -> *) ix +data instance UPValue r (UPBaseIx ix) = UPBV { unUPBV :: r ix } deriving (Show) +data instance UPValue r (UPHeadIx ix) = UPHV { unUPHV :: r ix } deriving (Show) +data instance UPValue r (UPTailIx ix) = UPTV { unUPTV :: r ix -> r ix } + +data TransformUPIntRule p surrIx (phi :: * -> *) (r :: * -> *) v = + MkTUPIR { + tlclwRecursionLimitActive :: forall ix. phi ix -> Bool, + tlclwEmpty :: forall ix. phi ix -> Maybe (p v), + tlclwHead :: forall ix. phi ix -> p v, + tlclwTail :: phi surrIx -> [(Bool, p (r surrIx -> v))], + tlclwFull :: p v + } + +newtype TransformUPWrapper p surrIx unused1 unused2 (phi :: * -> *) ixT (r :: * -> *) t v = + MkTUPW { + tUPRuleForGrammar :: + TransformUPGrammar p surrIx phi ixT r t -> + TransformUPIntRule p surrIx phi r v + } + +type TransformUPGrammar p surrIx phi ixT r t = + forall ix. phi ix -> + TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t (r ix) + +mkSimpleTUPW :: (ProductionRule p) => p v -> + TransformUPWrapper p surrIx unused1 unused2 phi ixT r t v +mkSimpleTUPW r = + MkTUPW $ \_ -> MkTUPIR (const False) (const Nothing) (const r) (const []) r + +mkEpsTUPW :: (ProductionRule p, EpsProductionRule p) => v -> + TransformUPWrapper p surrIx unused1 unused2 phi ixT r t v +mkEpsTUPW v = + MkTUPW $ \_ -> MkTUPIR (const False) (const $ Just $ epsilon v) (const die) (const [(True, epsilon (const v))]) $ epsilon v + +mkEpsLTUPW :: (ProductionRule p, LiftableProductionRule p) => v -> Q Exp -> + TransformUPWrapper p surrIx unused1 unused2 phi ixT r t v +mkEpsLTUPW v q = + MkTUPW $ \_ -> MkTUPIR (const False) (const $ Just $ epsilonL v q) (const die) (const [(True, epsilonL (const v) [| const $(q) |])]) $ epsilonL v q +instance (ProductionRule p, LiftableProductionRule p) => + ProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) where + ra >>> rb = MkTUPW $ \g -> + let (MkTUPIR rlaa eas ha tas fa) = tUPRuleForGrammar ra g + (MkTUPIR rlab ebs hb tbs fb) = tUPRuleForGrammar rb g + rla idx = rlaa idx || ((isJust $ eas idx) && rlab idx) + es idx = liftM2 (>>>) (eas idx) (ebs idx) + hForEmptyA idx = case eas idx of Nothing -> die + Just rea -> rea >>> hb idx + h idx = hForEmptyA idx + ||| ha idx >>> fb + ts surrIdx = + do (ea, ta) <- tas surrIdx + if ea + then do (eb,tb) <- tbs surrIdx + return (eb, epsilonL ap [| ap |] >>> ta >>> tb) + else return (False, epsilonL flip [| flip |] >>> ta >>> fb) + f = fa >>> fb + in MkTUPIR rla es h ts f + ra ||| rb = MkTUPW $ \g -> + let (MkTUPIR rlaa eas ha tas fa) = tUPRuleForGrammar ra g + (MkTUPIR rlab ebs hb tbs fb) = tUPRuleForGrammar rb g + rla idx = rlaa idx || rlab idx + es idx = liftM2 (|||) (eas idx) (ebs idx) + h idx = ha idx ||| hb idx + ts surrIdx = tas surrIdx ++ tbs surrIdx + in MkTUPIR rla es h ts $ fa ||| fb + endOfInput = mkSimpleTUPW endOfInput + die = MkTUPW $ \_ -> MkTUPIR (const False) (const Nothing) (const die) (const []) die + +instance (EpsProductionRule p) => + EpsProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) where + epsilon = mkEpsTUPW + +instance (LiftableProductionRule p) => + LiftableProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) where + epsilonL = mkEpsLTUPW + +instance (TokenProductionRule p t, ProductionRule p) => + TokenProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) t where + token tt = mkSimpleTUPW $ token tt + +tlclTailRef :: (LiftableProductionRule p, LoopProductionRule p (UPDomain phi) (UPValue r)) => + phi ix -> p ([r ix -> r ix]) +tlclTailRef idx = epsilonL (map unUPTV) [|map unUPTV|] >>> manyRef (UPTail idx) + +data WrapTransformUPWrapper p surrIx phi ixT r t ix = WrapTUPW { + unWrapTUPW :: TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t (r ix) + } + +failHeadRefsTo :: (EqFam phi, ProductionRule p) => + TransformUPGrammar p surrIx phi ixT r t -> phi ix -> + TransformUPGrammar p surrIx phi ixT r t +failHeadRefsTo g idx idx' = + let + nr = MkTUPW $ \g' -> + let (MkTUPIR _ _ _ _ rf) = tUPRuleForGrammar (g' idx) g' + in (MkTUPIR (eqIdx idx) (const Nothing) (\_ -> die) (\_ -> []) rf) + in unWrapTUPW $ overrideIdx (WrapTUPW . g) idx (WrapTUPW nr) idx' + +succeedTailRefs :: forall p surrIx phi ixT r t . (EqFam phi, ProductionRule p, LiftableProductionRule p) => + TransformUPGrammar p surrIx phi ixT r t -> phi surrIx -> + TransformUPGrammar p surrIx phi ixT r t +succeedTailRefs g idx idx' = + let + nr = MkTUPW $ \g' -> + let (MkTUPIR rla es rh _ rf) = tUPRuleForGrammar (g' idx) g' + in (MkTUPIR rla es rh (\_ -> [(False, epsilonL id [|id|])]) rf) + in unWrapTUPW $ overrideIdx (WrapTUPW . g) idx (WrapTUPW nr) idx' + +instance (RecProductionRule p (UPDomain phi) (UPValue r), + LiftableProductionRule p, + EqFam phi, + LoopProductionRule p (UPDomain phi) (UPValue r)) => + RecProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) phi r where + ref (idx :: phi ix) = + MkTUPW $ \g -> + let g' :: TransformUPGrammar p surrIx phi ixT r t + g' = failHeadRefsTo g idx + MkTUPIR rla eas ha tas _ = tUPRuleForGrammar (g idx) g' + h :: forall ix'. phi ix' -> p (r ix) + h idx' = if rla idx' -- use True to turn off optimization + then epsilonL (foldr ($)) [| foldr ($) |] >>> + (hForEmptyHead idx' ||| ha idx') >>> + tlclTailRef idx + else f + es idx' = if rla idx' -- use True to turn off optimization + then eas idx' + else Nothing + hForEmptyHead :: forall ix' . phi ix' -> p (r ix) + hForEmptyHead idx' = fromMaybe die $ eas idx' + f = epsilonL unUPBV [|unUPBV|] >>> ref (UPBase idx) + in MkTUPIR rla es h tas f + +data WrapListOfTailHeadManys p surrIx phi ixT r t ix = WLOTHM { + unWLOTHM :: [(Bool, p (r ix -> [r surrIx]))] + } +instance (EqFam phi, + LiftableProductionRule p, + LoopProductionRule p (UPDomain phi) (UPValue r)) => + LoopProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) phi r where + -- TODO: fix! + manyRef (idx :: phi ix) = + MkTUPW $ \_ -> + let tix :: p (r ix -> [r ix]) + tix = (flip (:) . map unUPBV, [| flip (:) . map unUPBV |]) $|>> manyRef (UPBase idx) + ts :: phi surrIx -> [(Bool, p (r surrIx -> [r ix]))] + ts surrIdx = unWLOTHM $ overrideIdx (\_ -> WLOTHM []) idx (WLOTHM [(False, tix)]) surrIdx + f = (map unUPBV, [|map unUPBV|]) $|>> manyRef (UPBase idx) + in MkTUPIR (\_ -> False) (const $ Just $ epsilonL [] [| [] |]) (const f) ts f + many1Ref (idx :: phi ix) = + MkTUPW $ \_ -> + let tix :: p (r ix -> [r ix]) + tix = (flip (:) . map unUPBV, [| flip (:) . map unUPBV |]) $|>> many1Ref (UPBase idx) + ts :: phi surrIx -> [(Bool, p (r surrIx -> [r ix]))] + ts surrIdx = unWLOTHM $ overrideIdx (\_ -> WLOTHM []) idx (WLOTHM [(False, tix)]) surrIdx + f = (map unUPBV, [|map unUPBV|]) $|>> many1Ref (UPBase idx) + in MkTUPIR (\_ -> False) (const Nothing) (const f) ts f + +transformUniformPaull' :: + forall p phi t r ix. + (Domain phi, + RecProductionRule p (UPDomain phi) (UPValue r), + LiftableProductionRule p, + LoopProductionRule p (UPDomain phi) (UPValue r), + TokenProductionRule p t) => + (forall ixT ix' surrIx. + phi ix' -> + TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t (r ix')) -> + UPDomain phi ix -> p (UPValue r ix) +transformUniformPaull' _ (UPBase idx) = + let + ruleHead = epsilonL unUPHV [|unUPHV|] >>> ref (UPHead idx) + br = epsilonL (foldr ($)) [|foldr ($)|] >>> ruleHead >>> tlclTailRef idx + in epsilonL UPBV [|UPBV|] >>> br +transformUniformPaull' bgram (UPHead (idx :: phi ix'')) = + let + intRule :: TransformUPIntRule p ix'' phi r (r ix'') + intRule = tUPRuleForGrammar (bgram idx) (bgram `failHeadRefsTo` idx) + ur :: p (r ix'') + ur = tlclwHead intRule idx + ||| (fromMaybe die $ tlclwEmpty intRule idx) + in epsilonL UPHV [| UPHV |] >>> ur +transformUniformPaull' bgram (UPTail (idx :: phi ix')) = + let + intRule = tUPRuleForGrammar (bgram idx) (bgram `succeedTailRefs` idx) + ur = foldr ((|||) . snd) die $ filter (not . fst) $ tlclwTail intRule idx + in epsilonL UPTV [|UPTV|] >>> ur + +-- | Apply a uniform variant of the classic Paull transformation to a given grammar, +-- removing direct and indirect left recursion. +transformUniformPaull :: + forall phi t r. Domain phi => + ProcessingContextFreeGrammar phi t r -> + ProcessingExtendedContextFreeGrammar (UPDomain phi) t (UPValue r) +transformUniformPaull gram idx = transformUniformPaull' gram idx + +-- | Apply a uniform variant of the classic Paull transformation to a given extended grammar, +-- removing direct and indirect left recursion. +transformUniformPaullE :: + forall phi t r. Domain phi => + ProcessingExtendedContextFreeGrammar phi t r -> + ProcessingExtendedContextFreeGrammar (UPDomain phi) t (UPValue r) +transformUniformPaullE gram idx = transformUniformPaull' gram idx + +-- | Apply a uniform variant of the classic Paull transformation to a given extended liftable grammar, +-- removing direct and indirect left recursion. +transformUniformPaullLE :: + forall phi t r. Domain phi => + ProcessingLExtendedContextFreeGrammar phi t r -> + ProcessingLExtendedContextFreeGrammar (UPDomain phi) t (UPValue r) +transformUniformPaullLE gram idx = transformUniformPaull' gram idx diff --git a/Text/GrammarCombinators/Utils/AssessSize.hs b/Text/GrammarCombinators/Utils/AssessSize.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/AssessSize.hs @@ -0,0 +1,68 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.AssessSize ( + assessSize + ) where + +import Text.GrammarCombinators.Base + +newtype AssessSizeProductionRule (phi :: * -> *) (r :: * -> *) t v = ASPR { + assessSizeRule :: Int + } + +instance ProductionRule (AssessSizeProductionRule phi r t) where + endOfInput = ASPR 1 + die = ASPR 1 + a ||| b = ASPR $ assessSizeRule a + assessSizeRule b + a >>> b = ASPR $ assessSizeRule a + assessSizeRule b + +instance EpsProductionRule (AssessSizeProductionRule phi r t) where + epsilon _ = ASPR 1 + +instance LiftableProductionRule (AssessSizeProductionRule phi r t) where + epsilonL _ _ = ASPR 1 + +instance (Token t) => TokenProductionRule (AssessSizeProductionRule phi r t) t where + token _ = ASPR 1 + +instance RecProductionRule (AssessSizeProductionRule phi r t) phi r where + ref _ = ASPR 1 + +instance LoopProductionRule (AssessSizeProductionRule phi r t) phi r where + manyRef _ = ASPR 1 + many1Ref _ = ASPR 1 + +-- | Assess the size of a given grammar. Primitive rules ('token', 'ref', 'manyRef', 'many1Ref', 'epsilon') +-- are counted as 1 point, combinators like '|||' or '>>>' just add the points of their left and +-- right hand sides. Proposals for better metrics are welcome. +assessSize :: forall phi r t rr . (Token t, FoldFam phi) => + GExtendedContextFreeGrammar phi t r rr -> Int +assessSize gram = + let + f idx = assessSizeRule $ gram idx + in foldFam ((+) . f) 0 + diff --git a/Text/GrammarCombinators/Utils/CalcFirst.hs b/Text/GrammarCombinators/Utils/CalcFirst.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/CalcFirst.hs @@ -0,0 +1,88 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Text.GrammarCombinators.Utils.CalcFirst ( + FirstSet (FS, firstSet, canBeEmpty, canBeEOI), + calcFirst + ) where + +import Data.Set (Set, union, singleton) +import qualified Data.Set as Set + +import Text.GrammarCombinators.Base + +data (Token t) => FirstSet t = + FS { + firstSet :: Set t, + canBeEmpty :: Bool, + canBeEOI :: Bool + } deriving (Show) + +newtype FSCalculator phi (r :: * -> *) t rr v = MkFSCalculator { + calcFS :: FirstSetGrammar phi r t rr -> FirstSet t + } +type FirstSetGrammar phi r t rr = + forall ix. phi ix -> FSCalculator phi r t rr (rr ix) + +instance (Token t) => ProductionRule (FSCalculator phi r t rr) where + a >>> b = MkFSCalculator $ \g -> + let FS fsa ea fa = calcFS a g + FS fsb eb fb = calcFS b g + in FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb)) + a ||| b = MkFSCalculator $ \g -> + let fa = calcFS a g + fb = calcFS b g + in FS { + firstSet = firstSet fa `union` firstSet fb, + canBeEmpty = canBeEmpty fa || canBeEmpty fb, + canBeEOI = canBeEOI fa || canBeEOI fb } + die = MkFSCalculator $ \_ -> FS Set.empty False False + endOfInput = MkFSCalculator $ \_ -> FS Set.empty False True + +instance (Token t) => EpsProductionRule (FSCalculator phi r t rr) where + epsilon _ = MkFSCalculator $ \_ -> FS Set.empty True False + +instance (Token t) => LiftableProductionRule (FSCalculator phi r t rr) where + epsilonL _ _ = MkFSCalculator $ \_ -> FS Set.empty True False + +newtype WrapFSC phi r t rr ix = WFSC { unWFSC :: FSCalculator phi r t rr (rr ix) } + +blockRecurse :: (EqFam phi, Token t) => + FirstSetGrammar phi r t rr -> phi idx -> FirstSetGrammar phi r t rr +blockRecurse gram idx = unWFSC . overrideIdx (WFSC . gram) idx (WFSC die) + +instance (Token t) => TokenProductionRule (FSCalculator phi r t rr) t where + token c = MkFSCalculator $ \_ -> FS (singleton c) False False +instance (Token t, EqFam phi) => RecProductionRule (FSCalculator phi r t rr) phi r where + ref idx = MkFSCalculator $ \g -> calcFS (g idx) $ blockRecurse g idx +instance (Token t, EqFam phi) => LoopProductionRule (FSCalculator phi r t rr) phi r where + -- first-set-wise, many1ref is identical to ref + -- manyRef will be defaulted correctly + many1Ref idx = MkFSCalculator $ \g -> calcFS (ref idx) g + +calcFirst :: (Domain phi, Token t) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> FirstSet t +calcFirst g idx = calcFS (ref idx) g + diff --git a/Text/GrammarCombinators/Utils/EnumTokens.hs b/Text/GrammarCombinators/Utils/EnumTokens.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/EnumTokens.hs @@ -0,0 +1,84 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.EnumTokens ( + enumRuleTokens, + enumTokens, + enumAllTokens + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.IsReachable + +newtype EnumTokensRule (phi :: * -> *) (r :: * -> *) t v = ETR { + unETR :: [t] + } + +instance ProductionRule (EnumTokensRule phi r t) where + die = ETR [] + endOfInput = ETR [] + a ||| b = ETR $ unETR a ++ unETR b + a >>> b = ETR $ unETR a ++ unETR b + +instance LiftableProductionRule (EnumTokensRule phi r t) where + epsilonL v _ = epsilon v + +instance EpsProductionRule (EnumTokensRule phi r t) where + epsilon _ = ETR [] + +instance (Token t) => TokenProductionRule (EnumTokensRule phi r t) t where + token t = ETR [t] + +instance (ShowFam phi) => RecProductionRule (EnumTokensRule phi r t) phi r where + ref _ = ETR [] + +instance (ShowFam phi) => LoopProductionRule (EnumTokensRule phi r t) phi r where + manyRef _ = ETR [] + many1Ref _ = ETR [] + +-- | Enumerate all tokens that can be present in any match of a given production rule. +enumRuleTokens :: (Domain phi, Token t) => + ExtendedContextFreeRule phi r t v -> [t] +enumRuleTokens rule = unETR rule + +enumTokens' :: forall phi t r rr . (Token t, Domain phi) => + ((forall ix. phi ix -> [t] -> [t]) -> [t] -> [t]) -> + GExtendedContextFreeGrammar phi t r rr -> [t] +enumTokens' fold' grammar = + let + addRuleTokens :: forall ix. phi ix -> [t] -> [t] + addRuleTokens idx b = enumRuleTokens (grammar idx) ++ b + in fold' addRuleTokens [] + +-- | Enumerate all tokens that can be present in any match of any string that can be matched +-- by a given non-terminal in a given grammar. +enumTokens :: (Token t, Domain phi) => GExtendedContextFreeGrammar phi t r rr -> phi ix -> [t] +enumTokens g idx = enumTokens' (foldReachable g idx) g + +-- | Enumerate all tokens that can be present in any match of any string that can be matched +-- by any non-terminal in a given grammar. +enumAllTokens :: (Token t, Domain phi) => GExtendedContextFreeGrammar phi t r rr -> [t] +enumAllTokens = enumTokens' foldFam diff --git a/Text/GrammarCombinators/Utils/EnumerateGrammar.hs b/Text/GrammarCombinators/Utils/EnumerateGrammar.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/EnumerateGrammar.hs @@ -0,0 +1,74 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.EnumerateGrammar where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Transform.FoldLoops + +type EnumerateParserInternalGrammar phi t = forall ix . phi ix -> Int -> [[ConcreteToken t]] + +newtype EnumerateProductionRule phi ixT r t v = IPP { + printIPP :: EnumerateParserInternalGrammar phi t -> Int -> [[ConcreteToken t]] + } + +instance ProductionRule (EnumerateProductionRule phi ixT r t) where + endOfInput = IPP $ \_ _ -> [[]] + die = IPP $ \_ _ -> [] + a ||| b = IPP $ \g d -> printIPP a g d ++ printIPP b g d + a >>> b = IPP $ \g d -> do x <- printIPP a g d + y <- printIPP b g d + return $ x ++ y + +instance LiftableProductionRule (EnumerateProductionRule phi ixT r t) where + epsilonL v _ = epsilon v + +instance EpsProductionRule (EnumerateProductionRule phi ixT r t) where + epsilon _ = IPP $ \_ _ -> [[]] + +instance (Token t) => TokenProductionRule (EnumerateProductionRule phi ixT r t) t where + token t = IPP $ \_ _ -> map (:[]) $ enumConcreteTokens t + +instance RecProductionRule (EnumerateProductionRule phi ixT r t) phi r where + ref idx = IPP $ \g d -> if d > 0 then g idx $ d-1 else [] + +type EnumerateGrammar phi ixT (r :: * -> *) t rr = forall ix. phi ix -> EnumerateProductionRule phi ixT r t (rr ix) + +enumerateGrammar :: forall phi r t rr ix. (Token t, FoldFam phi, ShowFam phi) => + GContextFreeGrammar phi t r rr -> Int -> phi ix -> [[ConcreteToken t]] +enumerateGrammar gram depth idx = + let + igram :: EnumerateGrammar phi ixT r t rr + igram = gram + intgram :: EnumerateParserInternalGrammar phi t + intgram idx' = printIPP (igram idx') intgram + in intgram idx depth + +enumerateGrammarE :: + forall phi r t rr ix. (Token t, FoldFam phi, ShowFam phi) => + GExtendedContextFreeGrammar phi t r rr -> Int -> phi ix -> [[ConcreteToken t]] +enumerateGrammarE gram depth idx = + enumerateGrammar (foldLoops gram) depth (FLBase idx) diff --git a/Text/GrammarCombinators/Utils/IsChainNT.hs b/Text/GrammarCombinators/Utils/IsChainNT.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/IsChainNT.hs @@ -0,0 +1,70 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.IsChainNT ( + isChainNT + ) where + +import Text.GrammarCombinators.Base + +-- A rule is a chain rule if it is a sequence of epsilons followed by +-- a single reference to another NT, possibly followed by more epsilons +data IsChainNT (phi :: * -> *) (r :: * -> *) t rr v = MkITR { + ruleIsEpsilon :: Bool, + ruleIsChain :: Bool + } + +instance ProductionRule (IsChainNT phi r t rr) where + ra >>> rb = + let eps = ruleIsEpsilon ra && ruleIsEpsilon rb + chain = ruleIsChain ra && ruleIsEpsilon rb || + ruleIsChain rb && ruleIsEpsilon ra + in MkITR eps chain + _ ||| _ = MkITR False False + die = MkITR False False + endOfInput = MkITR False False + +instance EpsProductionRule (IsChainNT phi r t rr) where + epsilon _ = MkITR True False + +instance LiftableProductionRule (IsChainNT phi r t rr) where + epsilonL _ _ = MkITR True False + +instance TokenProductionRule (IsChainNT phi r t rr) t where + token _ = MkITR False False + +instance (EqFam phi) => RecProductionRule (IsChainNT phi r t rr) phi r where + ref _ = MkITR False True + +instance (EqFam phi) => LoopProductionRule (IsChainNT phi r t rr) phi r where + manyRef _ = MkITR False False + +-- | Detect if a given non-terminal in a given extended context free +-- grammar is a chain non-terminal. An NT is a chain NT if all of +-- its productions are chain rules. +isChainNT :: (EqFam phi) => GExtendedContextFreeGrammar phi t r rr -> phi idx -> Bool +isChainNT gram idx = ruleIsChain (gram idx) + diff --git a/Text/GrammarCombinators/Utils/IsDead.hs b/Text/GrammarCombinators/Utils/IsDead.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/IsDead.hs @@ -0,0 +1,126 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.IsDead ( + isDead + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.UnfoldDepthFirst + +import Data.Maybe + +import Control.Monad.State + +data KnownDead phi = MkKD { knownDead :: forall ix. phi ix -> Maybe Bool } +newtype IsDeadRule phi (r :: * -> *) t (rr :: * -> *) v = MkIDR { + -- second bool means dead or not + -- first bool means dead state influenced by recursion cut-off + ruleIsDead :: State (KnownDead phi) (Bool, Bool) + } +cast :: IsDeadRule phi r t rr v -> IsDeadRule phi r t rr v' +cast = MkIDR . ruleIsDead + +seqDead :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool) +seqDead (False, True) _ = (False, True) +seqDead _ (False, True) = (False, True) +seqDead (ra, da) (rb, db) = (ra || rb, da || db) +altDead :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool) +altDead (False, False) _ = (False, False) +altDead _ (False, False) = (False, False) +altDead (ra, da) (rb, db) = (ra || rb, da && db) + +instance ProductionRule (IsDeadRule phi r t rr) where + ra >>> rb = MkIDR $ liftM2 seqDead (ruleIsDead ra) (ruleIsDead rb) + ra ||| rb = MkIDR $ liftM2 altDead (ruleIsDead ra) (ruleIsDead rb) + die = MkIDR $ return (False, True) + endOfInput = MkIDR $ return (False, False) + +instance EpsProductionRule (IsDeadRule phi r t rr) where + epsilon _ = MkIDR $ return (False, False) + +instance LiftableProductionRule (IsDeadRule phi r t rr) where + epsilonL _ _ = MkIDR $ return (False, False) + +instance TokenProductionRule (IsDeadRule phi r t rr) t where + token _ = MkIDR $ return (False, False) + +instance (EqFam phi, MemoFam phi) => + SimpleRecProductionRule (IsDeadRule phi r t rr) phi r rr where + ref' idx r = MkIDR $ do kds <- get + case knownDead kds idx of + (Just kd) -> return (False, kd) + _ -> do (rl,d) <- ruleIsDead r + unless rl $ putDeath idx d + return (rl, d) + cutRecursion _ = MkIDR $ return (True, True) + +instance (EqFam phi, MemoFam phi) => + SimpleLoopProductionRule (IsDeadRule phi r t rr) phi r rr where + manyRef' _ _ = MkIDR $ return (False, False) + many1Ref' idx r = cast (ref' idx r) + +putDeath :: (EqFam phi, MemoFam phi) => phi ix -> Bool -> + State (KnownDead phi) () +putDeath idx d = + do let setDead kd = MkKD $ memoFamilyK $ overrideIdxK (knownDead kd) idx $ Just d + modify setDead + +-- this is dead slow atm, we must be able to do better.. +-- isDead1 :: forall phi t r rr ix. (EqFam phi, MemoFam phi) => +-- GExtendedContextFreeGrammar phi t r rr -> +-- phi ix -> Bool +-- isDead1 gram idx = +-- let +-- ikd :: KnownDead phi +-- ikd = MkKD $ \_ -> Nothing +-- in snd $ evalState (ruleIsDead (unfoldDepthFirst gram idx)) ikd + +-- | Detect if a given non-terminal in a given grammar is dead. A +-- non-terminal is dead if its production rule can never match +-- anything. +isDead :: forall phi t r rr ix. (EqFam phi, FoldFam phi, MemoFam phi) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> Bool +isDead gram = + let + ikd :: KnownDead phi + ikd = MkKD $ \_ -> Nothing + checkDead idx = + do (_,d) <- ruleIsDead (unfoldDepthFirst gram idx) + putDeath idx d + checkAll = foldFam ((>>) . checkDead) (return ()) + in fromJust . knownDead (execState checkAll ikd) + +-- foldDead :: forall phi r t rr ix b. (Domain phi) => +-- GExtendedContextFreeGrammar phi r t rr -> +-- (forall ix. phi ix -> b -> b) -> b -> b +-- foldDead grammar f n = +-- let +-- f' :: forall ix. phi ix -> b -> b +-- f' idx n = if isDead grammar idx then f idx n else n +-- in foldFam f' n + diff --git a/Text/GrammarCombinators/Utils/IsEpsilon.hs b/Text/GrammarCombinators/Utils/IsEpsilon.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/IsEpsilon.hs @@ -0,0 +1,59 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Text.GrammarCombinators.Utils.IsEpsilon ( + isEpsilon + ) where + +import Text.GrammarCombinators.Base + +newtype IsEpsilonRule (phi :: * -> *) (r :: * -> *) t v = MkIER { + unIER :: Bool + } + +instance ProductionRule (IsEpsilonRule phi r t) where + ra >>> rb = MkIER $ unIER ra && unIER rb + ra ||| rb = MkIER $ unIER ra && unIER rb + die = MkIER False + endOfInput = MkIER False + +instance LiftableProductionRule (IsEpsilonRule phi r t) where + epsilonL v _ = epsilon v + +instance EpsProductionRule (IsEpsilonRule phi r t) where + epsilon _ = MkIER True + +instance TokenProductionRule (IsEpsilonRule phi r t) t where + token _ = MkIER False + +instance RecProductionRule (IsEpsilonRule phi r t) phi r where + ref _ = MkIER False + +instance LoopProductionRule (IsEpsilonRule phi r t) phi r where + manyRef _ = MkIER False + +-- | Detect if a given context-free rule is an epsilon rule. +isEpsilon :: ContextFreeRule phi r t v -> Bool +isEpsilon r = unIER r diff --git a/Text/GrammarCombinators/Utils/IsReachable.hs b/Text/GrammarCombinators/Utils/IsReachable.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/IsReachable.hs @@ -0,0 +1,142 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.IsReachable ( + foldReachable, + foldReachableProper, + isReachable, + isReachableProper + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.UnfoldDepthFirst + +import Control.Monad.State + +newtype SeenGram phi = MkSG { seenIdx :: forall ix. phi ix -> Bool } +newtype Folder phi n = MkFF { foldIdxs :: (forall ix. phi ix -> n -> n) -> n -> n } +newtype FoldReachableIntRule phi (r :: * -> *) t (rr :: * -> *) n v = MkFRIR { + foldRule :: State (SeenGram phi) (Folder phi n) + } +combineFolders :: Folder phi n -> Folder phi n -> Folder phi n +combineFolders a b = MkFF $ \f n -> foldIdxs a f $ foldIdxs b f n +foldDeadEnd :: FoldReachableIntRule phi r t rr n v +foldDeadEnd = MkFRIR $ return $ MkFF $ \_ n -> n +foldVia :: FoldReachableIntRule phi r t rr n v -> FoldReachableIntRule phi r t rr n v' -> FoldReachableIntRule phi r t rr n v'' +foldVia ra rb = MkFRIR $ do fa <- foldRule ra + fb <- foldRule rb + return $ combineFolders fa fb +setSeen :: (EqFam phi) => phi ix -> SeenGram phi -> SeenGram phi +setSeen idx s = MkSG $ overrideIdxK (seenIdx s) idx True +putSeen :: (EqFam phi) => phi ix -> State (SeenGram phi) () +putSeen idx = modify $ setSeen idx +noFold :: Folder phi n +noFold = MkFF $ const id +foldIdx :: phi ix -> Folder phi n +foldIdx idx = MkFF $ \f n -> f idx n +foldRef :: (EqFam phi) => + phi ix -> FoldReachableIntRule phi r t rr n (rr ix) -> + FoldReachableIntRule phi r t rr n v +foldRef idx r = MkFRIR $ do s <- get + if seenIdx s idx + then return noFold + else do putSeen idx + frec <- foldRule r + return $ combineFolders frec $ foldIdx idx + +instance ProductionRule (FoldReachableIntRule phi r t rr n) where + ra >>> rb = foldVia ra rb + ra ||| rb = foldVia ra rb + die = foldDeadEnd + endOfInput = foldDeadEnd + +instance EpsProductionRule (FoldReachableIntRule phi r t rr n) where + epsilon _ = foldDeadEnd + +instance LiftableProductionRule (FoldReachableIntRule phi r t rr n) where + epsilonL _ _ = foldDeadEnd + +instance TokenProductionRule (FoldReachableIntRule phi r t rr n) t where + token _ = foldDeadEnd + +instance (EqFam phi) => + SimpleRecProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where + ref' = foldRef + +instance (EqFam phi) => + SimpleLoopProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where + manyRef' = foldRef + many1Ref' = foldRef + +nothingSeen :: SeenGram phi +nothingSeen = MkSG $ \_ -> False + +-- | Fold a given function over all non-terminals that are reachable +-- from a given non-terminal. This function is limited to proper +-- reachable rules (see 'isReachableProper' for what that means). +foldReachableProper :: forall phi r t rr ix n. (Domain phi) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> + (forall ix'. phi ix' -> n -> n) -> n -> n +foldReachableProper grammar idx = + foldIdxs $ evalState (foldRule (unfoldDepthFirstProper grammar idx)) nothingSeen + +-- | Fold a given function over all non-terminals that are reachable +-- from a given non-terminal. This function will at least fold over the +-- given non-terminal itself. +foldReachable :: forall phi r rr t ix n. (Domain phi) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> + (forall ix'. phi ix' -> n -> n) -> n -> n +foldReachable grammar idx = + foldIdxs $ evalState (foldRule (unfoldDepthFirst grammar idx)) nothingSeen + +isReachable' :: forall phi r t rr ix ix'. (Domain phi) => + (forall n. + GExtendedContextFreeGrammar phi t r rr -> phi ix -> + (forall ix''. phi ix'' -> n -> n) -> n -> n) -> + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> phi ix' -> Bool +isReachable' fold' g start end = + fold' g start ((||) . eqIdx end) False + +-- | Check if a given terminal is reachable from a given other grammar +-- in a given extended context-free grammar. This function assumes +-- that all grammars are reachable from themselves. +isReachable :: forall phi r t rr ix ix'. (Domain phi) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> phi ix' -> Bool +isReachable = isReachable' foldReachable + +-- | Check if a given terminal is reachable from a given other grammar +-- in a given extended context-free grammar. For this function, a non- +-- terminal is not automatically considered reachable from itself, but +-- only if it has some production in which a submatch of itself is +-- present. +isReachableProper :: forall phi r t rr ix ix'. (Domain phi) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> phi ix' -> Bool +isReachableProper = isReachable' foldReachableProper diff --git a/Text/GrammarCombinators/Utils/PrintGrammar.hs b/Text/GrammarCombinators/Utils/PrintGrammar.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/PrintGrammar.hs @@ -0,0 +1,105 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.PrintGrammar ( + printRule, + printGrammar, + printGrammarInf, + printReachableGrammar + ) where + +import Text.GrammarCombinators.Base +import Text.GrammarCombinators.Utils.IsReachable + +newtype PrintProductionRule (phi :: * -> *) (r :: * -> *) t v = IPP { + printIPP :: Bool -> Bool -> Integer -> String + } + +printIPPSub :: Integer -> Bool -> Bool -> PrintProductionRule phi r t v -> String +printIPPSub d pd pc pp = if d > 0 then printIPP pp pd pc (d-1) else "..." + +instance ProductionRule (PrintProductionRule phi r t) where + die = IPP $ \_ _ _ -> "die" + endOfInput = IPP $ \_ _ _ -> "EOI" + a ||| b = IPP $ \pd _ d -> + let t = printIPPSub d False True a ++ " | " ++ printIPPSub d False True b + in if pd then "(" ++ t ++ ")" else t + a >>> b = IPP $ \pd pc d -> + if printIPPSub d pd pc a == "epsilon" + then printIPPSub d pd pc b + else if printIPPSub d pd pc b == "epsilon" + then printIPPSub d pd pc a + else let t = printIPPSub d True False a ++ " " ++ printIPPSub d True False b + in if pc then "(" ++ t ++ ")" else t + +instance EpsProductionRule (PrintProductionRule phi r t) where + epsilon _ = IPP $ \_ _ _ -> "epsilon" + +instance LiftableProductionRule (PrintProductionRule phi r t) where + epsilonL _ _ = IPP $ \_ _ _ -> "epsilon" + +instance (Token t) => TokenProductionRule (PrintProductionRule phi r t) t where + token t = IPP $ \_ _ _ -> show t + +instance (ShowFam phi) => RecProductionRule (PrintProductionRule phi r t) phi r where + ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" + +instance (ShowFam phi) => LoopProductionRule (PrintProductionRule phi r t) phi r where + manyRef idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" ++ "*" + many1Ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" ++ "+" + +-- | Print out a single production rule +printRule :: (Domain phi, Token t) => GExtendedContextFreeGrammar phi t r rr -> Integer -> phi ix -> String +printRule gram depth idx = "<" ++ showIdx idx ++ ">" ++ " ::= " ++ printIPP (gram idx) False False depth + +printGrammar' :: forall phi t r rr. (Domain phi, Token t) => + (forall b. (forall ix. phi ix -> b -> b) -> b -> b) -> + GExtendedContextFreeGrammar phi t r rr -> Integer -> String +printGrammar' fold' gram depth = + unlines $ fold' ((:) . printRule gram depth) [] + +-- close enough... +infinity :: Integer +infinity = 999999999999999999999999999999 + +-- | Print out a full grammar. +printGrammar :: forall phi t r rr. (Domain phi, Token t) => + GExtendedContextFreeGrammar phi t r rr -> String +printGrammar g = printGrammar' foldFam g infinity + +-- | Print out a grammar with a depth limit. Intended for infinite grammars. +printGrammarInf :: forall phi t r rr. (Domain phi, Token t) => + GExtendedContextFreeGrammar phi t r rr -> Integer -> String +printGrammarInf = printGrammar' foldFam + +-- | Print out the part of a grammar that is reachable from a given non-terminal. +printReachableGrammar :: + forall phi t r rr ix. + (Domain phi, Token t) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> String +printReachableGrammar gram idx = printGrammar' (foldReachable gram idx) gram infinity + diff --git a/Text/GrammarCombinators/Utils/ToGraph.hs b/Text/GrammarCombinators/Utils/ToGraph.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/ToGraph.hs @@ -0,0 +1,177 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.ToGraph ( + ruleToGraph, + graphToGraphviz, + fullGrammarToGraph, + reachableGrammarToGraph, + showGraph + ) where + +import Text.GrammarCombinators.Base + +import Text.GrammarCombinators.Utils.IsReachable + +import Data.Graph.Inductive.Graph + +import Control.Monad.State +import Control.Monad.Writer + +import Data.Graph.Inductive.PatriciaTree +import Data.GraphViz + +newNode :: (MonadState (Int, Int) m) => m Int +newNode = do (d, n) <- get + put (d, n + 1) + return n +tell1 :: (MonadWriter [w] m) => w -> m () +tell1 w = tell [w] + +newtype GraphConstructor (phi :: * -> *) (r :: * -> *) t v = + MkGC { + constructContexts :: + Adj String -> Bool -> + WriterT [Context String String] (State (Int, Int)) (Adj String) + } + +leafNode :: String -> Bool -> GraphConstructor phi r t v +leafNode label eps = MkGC $ \parentEdge printeps -> + if not eps || printeps + then do ln <- newNode + tell1 (parentEdge, ln, label, []) + return [("",ln)] + else return parentEdge + +constructContextsSub :: GraphConstructor phi r t v -> Adj String -> + Bool -> + WriterT [Context String String] (State (Int, Int)) (Adj String) +constructContextsSub r pe printeps = + do (d, n) <- get + if d > 0 + then put (d-1,n) >> + constructContexts r pe printeps + else do n' <- newNode + tell1 (pe, n', "(...)", []) + return [] + +instance ProductionRule (GraphConstructor phi r t) where + ra >>> rb = MkGC $ \parentEdge printeps -> + do (d,_) <- get + pe <- constructContextsSub ra parentEdge False + if null pe + then return [] + else do modify $ \(_,n) -> (d,n) -- do not ignore right branches if left ones are infinite... + constructContextsSub rb pe printeps + ra ||| rb = MkGC $ \parentEdge _ -> + do (d,_) <- get + pea <- constructContextsSub ra parentEdge True + modify $ \(_,n) -> (d,n) + peb <- constructContextsSub rb parentEdge True + return $ pea ++ peb + endOfInput = leafNode "endOfInput" False + die = leafNode "die" False + +instance EpsProductionRule (GraphConstructor phi r t) where + epsilon _ = leafNode "epsilon" True + +instance LiftableProductionRule (GraphConstructor phi r t) where + epsilonL _ _ = leafNode "epsilon" True + +instance (Token t) => + TokenProductionRule (GraphConstructor phi r t) t where + token tt = leafNode (show tt) False + +instance (Domain phi) => RecProductionRule (GraphConstructor phi r t) phi r where + ref idx = leafNode ("<" ++ showIdx idx ++ ">") False + +instance (Domain phi) => LoopProductionRule (GraphConstructor phi r t) phi r where + manyRef idx = leafNode ("<" ++ showIdx idx ++ ">*") False + +ruleToGraph :: forall phi t r rr gr ix. (Token t, Domain phi, DynGraph gr) => + Int -> GExtendedContextFreeGrammar phi t r rr -> + phi ix -> gr String String +ruleToGraph depth gram idx = buildGr $ snd $ ruleToContexts depth gram idx 0 + +ruleToContexts :: forall phi t r rr ix. (Token t, Domain phi) => + Int -> GExtendedContextFreeGrammar phi t r rr -> + phi ix -> Int -> (Int, [Context String String]) +ruleToContexts depth gram idx sn = + let + processNTDef :: phi ix -> + WriterT [Context String String] (State (Int, Int)) (Adj String) + processNTDef idx' = + do ntNode <- newNode + tell1 ([], ntNode, showIdx idx', []) + let stAdj = [("", ntNode)] + constructContexts (gram idx') stAdj True + (contexts, (_,nsn)) = flip runState (depth, sn) $ execWriterT $ processNTDef idx + in (nsn, reverse contexts) + +graphvizParams :: GraphvizParams String String () String +graphvizParams = Params { + isDirected = True, + globalAttributes = [], + clusterBy = N, + clusterID = const Nothing, + fmtCluster = const [], + fmtNode = \(_,n) -> [Label $ StrLabel n], + fmtEdge = \(_,_,_) -> [] + } + +graphToGraphviz :: Gr String String -> DotGraph Node +graphToGraphviz gr = setID (Str "Grammar") $ graphToDot graphvizParams (gr :: Gr String String) + +grammarToContexts :: forall phi t r rr . (Token t, Domain phi) => + (forall b. (forall ix. phi ix -> b -> b) -> b -> b) -> + Int -> GExtendedContextFreeGrammar phi t r rr -> + [Context String String] +grammarToContexts fold' depth gram = + let + processRule idx (nsn, cs) = (nsn', cs ++ cs') + where (nsn', cs') = ruleToContexts depth gram idx nsn + in snd $ fold' processRule (0,[]) + +grammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) => + (forall b. (forall ix. phi ix -> b -> b) -> b -> b) -> + Int -> GExtendedContextFreeGrammar phi t r rr -> + gr String String +grammarToGraph fold' depth gram = buildGr $ grammarToContexts fold' depth gram + +fullGrammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) => + Int -> GExtendedContextFreeGrammar phi t r rr -> + gr String String +fullGrammarToGraph = grammarToGraph foldFam +reachableGrammarToGraph :: forall phi t r rr gr ix . (Token t, Domain phi, DynGraph gr) => + Int -> GExtendedContextFreeGrammar phi t r rr -> phi ix -> + gr String String +reachableGrammarToGraph depth gram idx = grammarToGraph (foldReachable gram idx) depth gram + +void :: (Monad m) => m a -> m () +void m = m >> return () + +showGraph :: (DotRepr dg n) => dg n -> IO () +showGraph gr = void $ runGraphvizCanvas' gr Xlib diff --git a/Text/GrammarCombinators/Utils/UnfoldDepthFirst.hs b/Text/GrammarCombinators/Utils/UnfoldDepthFirst.hs new file mode 100644 --- /dev/null +++ b/Text/GrammarCombinators/Utils/UnfoldDepthFirst.hs @@ -0,0 +1,136 @@ +{- Copyright 2010 Dominique Devriese + + This file is part of the grammar-combinators library. + + The grammar-combinators library is free software: you can + redistribute it and/or modify it under the terms of the GNU + Lesser General Public License as published by the Free + Software Foundation, either version 3 of the License, or (at + your option) any later version. + + Foobar 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 Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General + Public License along with Foobar. If not, see + . +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GrammarCombinators.Utils.UnfoldDepthFirst where + +import Text.GrammarCombinators.Base + +-- TODO: use UnfoldLoops and UnfoldRecursion instead of redoing everything? + +class (ProductionRule p) => + SimpleRecProductionRule p phi r rr | p -> phi, p -> r, p -> rr where + ref' :: phi ix -> p (rr ix) -> p (r ix) + cutRecursion :: phi ix -> p (rr ix) + cutRecursion _ = die + +class SimpleLoopProductionRule p phi r rr | p -> phi, p -> r, p -> rr where + manyRef' :: phi ix -> p (rr ix) -> p [r ix] + many1Ref' :: phi ix -> p (rr ix) -> p [r ix] + +newtype UnfoldDepthFirstRule p (phi :: * -> *) (r :: * -> *) t (rr :: * -> *) v = MkFRR { + foldReachableFromRule :: UDFGrammar p phi r t rr -> + p v + } + +type UDFGrammar p phi r t rr = + forall ix. phi ix -> p (rr ix) + +instance (ProductionRule p) => ProductionRule (UnfoldDepthFirstRule p phi r t rr) where + ra >>> rb = MkFRR $ \g -> foldReachableFromRule ra g >>> foldReachableFromRule rb g + ra ||| rb = MkFRR $ \g -> foldReachableFromRule ra g ||| foldReachableFromRule rb g + die = MkFRR $ \_ -> die + endOfInput = MkFRR $ \_ -> endOfInput + +instance (EpsProductionRule p) => EpsProductionRule (UnfoldDepthFirstRule p phi r t rr) where + epsilon v = MkFRR $ \_ -> epsilon v + +instance (LiftableProductionRule p) => LiftableProductionRule (UnfoldDepthFirstRule p phi r t rr) where + epsilonL v q = MkFRR $ \_ -> epsilonL v q + +instance (TokenProductionRule p t) => + TokenProductionRule (UnfoldDepthFirstRule p phi r t rr) t where + token tt = MkFRR $ \_ -> token tt + +instance (SimpleRecProductionRule p phi r rr) => + RecProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where + ref idx = MkFRR $ \g -> ref' idx (g idx) + +instance (ProductionRule p, + LiftableProductionRule p, + SimpleRecProductionRule p phi r rr, + SimpleLoopProductionRule p phi r rr) => + LoopProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where + manyRef idx = MkFRR $ \g -> manyRef' idx (g idx) + many1Ref idx = MkFRR $ \g -> many1Ref' idx (g idx) + +newtype WrapUR p r ix = WUR { unWUR :: p (r ix) } + +declareDead :: (EqFam phi, ProductionRule p, + SimpleRecProductionRule p phi r rr) => + phi ix -> + UDFGrammar p phi r t rr -> + UDFGrammar p phi r t rr +declareDead idx g = unWUR . overrideIdx (WUR . g) idx (WUR $ cutRecursion idx) + + +unfoldDepthFirst'' :: forall p phi r rr t v. + (ProductionRule p, EqFam phi, + TokenProductionRule p t, + EpsProductionRule p, + SimpleRecProductionRule p phi r rr, + SimpleLoopProductionRule p phi r rr) => + UnfoldDepthFirstRule p phi r t rr v -> + GExtendedContextFreeGrammar phi t r rr -> + (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) -> + p v +unfoldDepthFirst'' r grammar rg = + foldReachableFromRule r (rg (unfoldDepthFirst' grammar rg)) + +unfoldDepthFirst' :: forall p phi r rr t ix. + (ProductionRule p, EqFam phi, + EpsProductionRule p, + TokenProductionRule p t, + SimpleRecProductionRule p phi r rr, + SimpleLoopProductionRule p phi r rr) => + GExtendedContextFreeGrammar phi t r rr -> + (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) -> + phi ix -> p (rr ix) +unfoldDepthFirst' grammar rg idx = + let + nrg :: UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr + nrg g = declareDead idx (rg g) + in unfoldDepthFirst'' (grammar idx) grammar nrg + +unfoldDepthFirstProper :: forall p phi r rr t ix. + (ProductionRule p, EqFam phi, + EpsProductionRule p, + TokenProductionRule p t, + SimpleRecProductionRule p phi r rr, + SimpleLoopProductionRule p phi r rr) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> p (rr ix) +unfoldDepthFirstProper grammar = unfoldDepthFirst' grammar id + +unfoldDepthFirst :: forall p phi r rr t ix. + (ProductionRule p, EqFam phi, + EpsProductionRule p, + TokenProductionRule p t, + SimpleRecProductionRule p phi r rr, + SimpleLoopProductionRule p phi r rr) => + GExtendedContextFreeGrammar phi t r rr -> + phi ix -> p (r ix) +unfoldDepthFirst grammar idx = unfoldDepthFirst'' (ref idx) grammar id + diff --git a/grammar-combinators.cabal b/grammar-combinators.cabal new file mode 100644 --- /dev/null +++ b/grammar-combinators.cabal @@ -0,0 +1,71 @@ +Name: grammar-combinators +Version: 0.1 +Description: + The grammar-combinators library is a novel parsing library using + an explicit representation of recursion to provide various novel + features, for grammar analysis, transformation and parsing + functionality. +License: LGPL +License-file: COPYING.LGPL +Homepage: http://projects.haskell.org/grammar-combinators/ +Author: Dominique Devriese +Maintainer: Dominique Devriese +Build-Type: Simple +Category: Parsing +Synopsis: A parsing library of context-free grammar combinators. +Cabal-Version: >=1.2.1 +Extra-Source-Files: COPYING.GPL +Stability: experimental + +Library + Build-Depends: base >= 3 && < 5, + multirec >= 0.4, + template-haskell >= 2.4.0.0, + enumerable >= 0.0.3, + mtl >= 1.1, + containers >= 0.3, + parsec >= 3.1, + MaybeT >= 0.1.2, + uu-parsinglib >= 2.5.1, + graphviz >= 2999.10, + fgl >= 5.4.2.2 + Exposed-modules: Text.GrammarCombinators.Base.Domain + Text.GrammarCombinators.Base.Grammar + Text.GrammarCombinators.Base + Text.GrammarCombinators.Base.MultiRec + Text.GrammarCombinators.Base.ProductionRule + Text.GrammarCombinators.Base.Processor + Text.GrammarCombinators.Base.Token + Text.GrammarCombinators.Parser.LL1 + Text.GrammarCombinators.Parser.LL1TH + Text.GrammarCombinators.Parser.Packrat + Text.GrammarCombinators.Parser.Parsec + Text.GrammarCombinators.Parser.RealLL1 + Text.GrammarCombinators.Parser.RecursiveDescent + Text.GrammarCombinators.Parser.TopDown + Text.GrammarCombinators.Parser.UUParse + Text.GrammarCombinators.TH.Base + Text.GrammarCombinators.TH.FoldLoops + Text.GrammarCombinators.TH.RealLL1 + Text.GrammarCombinators.Transform.CombineEpsilons + Text.GrammarCombinators.Transform.FilterDies + Text.GrammarCombinators.Transform.FoldLoops + Text.GrammarCombinators.Transform.LeftCorner + Text.GrammarCombinators.Transform.OptimizeGrammar + Text.GrammarCombinators.Transform.UnfoldChainNTs + Text.GrammarCombinators.Transform.UnfoldDead + Text.GrammarCombinators.Transform.UnfoldLoops + Text.GrammarCombinators.Transform.UnfoldRecursion + Text.GrammarCombinators.Transform.UniformPaull + Text.GrammarCombinators.Utils.AssessSize + Text.GrammarCombinators.Utils.CalcFirst + Text.GrammarCombinators.Utils.EnumerateGrammar + Text.GrammarCombinators.Utils.EnumTokens + Text.GrammarCombinators.Utils.IsChainNT + Text.GrammarCombinators.Utils.IsDead + Text.GrammarCombinators.Utils.IsEpsilon + Text.GrammarCombinators.Utils.IsReachable + Text.GrammarCombinators.Utils.PrintGrammar + Text.GrammarCombinators.Utils.ToGraph + Text.GrammarCombinators.Utils.UnfoldDepthFirst + ghc-options: -Wall