hoppy-generator (empty) → 0.1.0
raw patch · 14 files changed
+5825/−0 lines, 14 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, haskell-src, mtl
Files
- LICENSE +661/−0
- Setup.hs +19/−0
- hoppy-generator.cabal +45/−0
- src/Foreign/Hoppy/Generator/Common.hs +93/−0
- src/Foreign/Hoppy/Generator/Common/Consume.hs +84/−0
- src/Foreign/Hoppy/Generator/Language/Cpp.hs +266/−0
- src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +616/−0
- src/Foreign/Hoppy/Generator/Language/Haskell.hs +674/−0
- src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot +47/−0
- src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +1107/−0
- src/Foreign/Hoppy/Generator/Main.hs +220/−0
- src/Foreign/Hoppy/Generator/Spec.hs +1796/−0
- src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +96/−0
- src/Foreign/Hoppy/Generator/Version.hs +101/−0
+ LICENSE view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+our General Public Licenses are 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.++ 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.++ Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++ A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate. Many developers of free software are heartened and+encouraged by the resulting cooperation. However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++ The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community. It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server. Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++ An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals. This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++ 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License.++ Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software. This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++ 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 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 work with which it is combined will remain governed by version+3 of the GNU General Public License.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU Affero 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 Affero 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 Affero 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 Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero 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 Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source. For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code. There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++ 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 AGPL, see+<http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -0,0 +1,19 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++import Distribution.Simple+main = defaultMain
+ hoppy-generator.cabal view
@@ -0,0 +1,45 @@+name: hoppy-generator+version: 0.1.0+synopsis: C++ FFI generator - Code generator+homepage: http://khumba.net/projects/hoppy+license: AGPL-3+license-file: LICENSE+author: Bryan Gardiner <bog@khumba.net>+maintainer: Bryan Gardiner <bog@khumba.net>+copyright: Copyright 2015-2016 Bryan Gardiner+category: Foreign+build-type: Simple+cabal-version: >=1.10+description:+ Hoppy generates Haskell bindings to C++ libraries.+ .+ This package is the code generator.++library+ exposed-modules:+ Foreign.Hoppy.Generator.Language.Cpp+ , Foreign.Hoppy.Generator.Language.Haskell+ , Foreign.Hoppy.Generator.Main+ , Foreign.Hoppy.Generator.Spec+ , Foreign.Hoppy.Generator.Spec.ClassFeature+ , Foreign.Hoppy.Generator.Version+ other-modules:+ Foreign.Hoppy.Generator.Common+ , Foreign.Hoppy.Generator.Common.Consume+ , Foreign.Hoppy.Generator.Language.Cpp.Internal+ , Foreign.Hoppy.Generator.Language.Haskell.Internal+ default-extensions:+ FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , MultiParamTypeClasses+ build-depends:+ base >=4.7 && <4.9+ , containers >=0.5 && <0.6+ , directory >=1.2 && <1.3+ , filepath >=1.3 && <1.5+ , haskell-src >=1.0 && <1.1+ , mtl >=2.1 && <2.3+ hs-source-dirs: src+ ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind+ default-language: Haskell2010
+ src/Foreign/Hoppy/Generator/Common.hs view
@@ -0,0 +1,93 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | General routines.+module Foreign.Hoppy.Generator.Common (+ fromMaybeM,+ fromEitherM,+ maybeFail,+ listSubst,+ zipWithM,+ writeFileIfDifferent,+ -- * String utilities+ capitalize,+ lowerFirst,+ upperFirst,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Exception (evaluate)+import Control.Monad (when)+import Data.Char (toLower, toUpper)+import System.Directory (doesFileExist)+import System.IO (IOMode (ReadMode), hGetContents, withFile)++-- | @fromMaybeM m x = maybe m return x@+fromMaybeM :: Monad m => m a -> Maybe a -> m a+fromMaybeM = flip maybe return++-- | @fromEitherM f x = either f return x@+fromEitherM :: Monad m => (e -> m a) -> Either e a -> m a+fromEitherM = flip either return++-- | @maybeFail s x = maybe (fail s) x@+maybeFail :: Monad m => String -> Maybe a -> m a+maybeFail = fromMaybeM . fail++-- | @listSubst a b xs@ replaces all @x@ in @xs@ such that @x == a@ with @b@.+listSubst :: Eq a => a -> a -> [a] -> [a]+listSubst x x' = map $ \y -> if y == x then x' else y++-- | Zips two lists using a monadic function.+zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys = sequence $ zipWith f xs ys++-- | If the file specified does not exist or its contents does not match the+-- given string, then this writes the string to the file.+writeFileIfDifferent :: FilePath -> String -> IO ()+writeFileIfDifferent path newContents = do+ exists <- doesFileExist path+ -- We need to read the file strictly, otherwise lazy IO might try to write the+ -- file while it's still open and locked for reading.+ doWrite <- if exists+ then (newContents /=) <$> readStrictly+ else return True+ when doWrite $ writeFile path newContents+ where readStrictly = withFile path ReadMode $ \handle -> do+ contents <- hGetContents handle+ _ <- evaluate $ length contents+ return contents++-- | Upper cases the first character of a string, and lower cases the rest of+-- it. Does nothing to an empty string.+capitalize :: String -> String+capitalize "" = ""+capitalize (c:cs) = toUpper c : map toLower cs++-- | Lower cases the first character of a string, if nonempty.+lowerFirst :: String -> String+lowerFirst "" = ""+lowerFirst (c:cs) = toLower c : cs++-- | Upper cases the first character of a string, if nonempty.+upperFirst :: String -> String+upperFirst "" = ""+upperFirst (c:cs) = toUpper c : cs
+ src/Foreign/Hoppy/Generator/Common/Consume.hs view
@@ -0,0 +1,84 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | A monad for consuming streams.+module Foreign.Hoppy.Generator.Common.Consume (+ MonadConsume (..),+ ConsumeT,+ runConsumeT,+ evalConsumeT,+ execConsumeT,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*>), Applicative, pure)+#endif+import Control.Monad (ap, liftM)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.State (StateT, get, put, runStateT)+import Data.Tuple (swap)++-- | A typeclass for monads that can consume items from a stream.+class MonadConsume s m | m -> s where+ -- | Attempts to consume an item from the stream. Returns an item if the+ -- stream is not empty.+ next :: m (Maybe s)++-- | A monad transformer for 'MonadConsume'.+newtype ConsumeT s m a = ConsumeT { getConsumeT :: StateT [s] m a }++instance Monad m => Functor (ConsumeT s m) where+ fmap = liftM++instance Monad m => Applicative (ConsumeT s m) where+ pure = return+ (<*>) = ap++instance Monad m => Monad (ConsumeT s m) where+ return = ConsumeT . return+ m >>= f = ConsumeT $ getConsumeT . f =<< getConsumeT m++instance MonadTrans (ConsumeT s) where+ lift = ConsumeT . lift++instance Monad m => MonadConsume s (ConsumeT s m) where+ next = do+ stream <- get'+ case stream of+ [] -> return Nothing+ x:xs -> put' xs >> return (Just x)++-- | Runs the consume action, returning the remainder of the stream, and the+-- action's result.+runConsumeT :: Monad m => [s] -> ConsumeT s m a -> m ([s], a)+runConsumeT stream (ConsumeT m) = liftM swap $ runStateT m stream++-- | Runs the consume action, returning the action's result.+evalConsumeT :: Monad m => [s] -> ConsumeT s m a -> m a+evalConsumeT stream = liftM snd . runConsumeT stream++-- | Runs the consume action, returning the remainder of the stream.+execConsumeT :: Monad m => [s] -> ConsumeT s m a -> m [s]+execConsumeT stream = liftM fst . runConsumeT stream++get' :: Monad m => ConsumeT s m [s]+get' = ConsumeT get++put' :: Monad m => [s] -> ConsumeT s m ()+put' = ConsumeT . put
+ src/Foreign/Hoppy/Generator/Language/Cpp.hs view
@@ -0,0 +1,266 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE ViewPatterns #-}++-- | Shared portion of the C++ code generator. Usable by binding definitions.+module Foreign.Hoppy.Generator.Language.Cpp (+ externalNameToCpp,+ classDeleteFnCppName,+ classCastFnCppName,+ callbackClassName,+ callbackImplClassName,+ callbackFnName,+ toArgName,+ toArgNameAlt,+ Chunk (..),+ runChunkWriter,+ evalChunkWriter,+ execChunkWriter,+ runChunkWriterT,+ evalChunkWriterT,+ execChunkWriterT,+ say,+ says,+ sayIdentifier,+ sayVar,+ sayType,+ ) where++import Control.Monad (liftM)+import Control.Monad.Writer (MonadWriter, Writer, WriterT, runWriter, runWriterT, tell)+import Data.Foldable (forM_)+import Data.List (intercalate, intersperse)+import Foreign.Hoppy.Generator.Spec++cppNameSeparator :: String+cppNameSeparator = "__"++makeCppName :: [String] -> String+makeCppName = intercalate cppNameSeparator++-- | \"genpop\" is the prefix used for individually exported functions.+externalNamePrefix :: String+externalNamePrefix = "genpop"++-- | Returns the C++ binding function name for an external name.+externalNameToCpp :: ExtName -> String+externalNameToCpp extName =+ makeCppName [externalNamePrefix, fromExtName extName]++makeClassCppName :: String -> Class -> String+makeClassCppName prefix cls = makeCppName [prefix, fromExtName $ classExtName cls]++-- | \"gendel\" is the prefix used for wrappers for @delete@ calls.+classDeleteFnPrefix :: String+classDeleteFnPrefix = "gendel"++-- | Returns the C++ binding function name of the wrapper for the delete method+-- for a class.+classDeleteFnCppName :: Class -> String+classDeleteFnCppName = makeClassCppName classDeleteFnPrefix++-- | @classCastFnCppName fromCls toCls@ returns the name of the generated C+++-- function that casts a pointer from @fromCls@ to @toCls@.+classCastFnCppName :: Class -> Class -> String+classCastFnCppName from to =+ concat [ "gencast__"+ , fromExtName $ classExtName from+ , "__"+ , fromExtName $ classExtName to+ ]++-- | Returns the name of the outer, copyable class for a callback.+callbackClassName :: Callback -> String+callbackClassName = fromExtName . callbackExtName++-- | Returns the name of the internal, non-copyable implementation class for a+-- callback.+callbackImplClassName :: Callback -> String+callbackImplClassName = (++ "_impl") . fromExtName . callbackExtName++-- | Returns the name of the C++ binding function that creates a C++ callback+-- wrapper object from a function pointer to foreign code.+callbackFnName :: Callback -> String+callbackFnName = externalNameToCpp . callbackExtName++-- | Returns a distinct argument variable name for each nonnegative number.+toArgName :: Int -> String+toArgName = ("arg" ++) . show++-- | Same as 'toArgName', but with distinct names, with with similarity between+-- @toArgName n@ and @toArgNameAlt n@.+toArgNameAlt :: Int -> String+toArgNameAlt n = "arg" ++ show n ++ "_"++-- TODO Fixme, this is most likely backwards, it should be a finite set of+-- non-identifier chars. Also (maybe) share some logic with the toExtName+-- requirements?+isIdentifierChar :: Char -> Bool+isIdentifierChar = (`elem` identifierChars)++identifierChars :: String+identifierChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_"++-- | A chunk is a string that contains an arbitrary portion of C++ code. The+-- only requirement is that chunk boundaries are also C++ token boundaries,+-- because the generator monad automates the process of inserting whitespace+-- between chunk boundaries where necessary.+newtype Chunk = Chunk { chunkContents :: String }++-- | Runs a 'Chunk' writer, combining them with 'combineChunks' to form a single+-- string.+runChunkWriter :: Writer [Chunk] a -> (a, String)+runChunkWriter = fmap combineChunks . runWriter++-- | Runs a 'Chunk' writer and returns the monad's value.+evalChunkWriter :: Writer [Chunk] a -> a+evalChunkWriter = fst . runChunkWriter++-- | Runs a 'Chunk' writer and returns the written log.+execChunkWriter :: Writer [Chunk] a -> String+execChunkWriter = snd . runChunkWriter++-- | Runs a 'Chunk' writer transformer, combining them with 'combineChunks' to+-- form a single string.+runChunkWriterT :: Monad m => WriterT [Chunk] m a -> m (a, String)+runChunkWriterT = liftM (fmap combineChunks) . runWriterT++-- | Runs a 'Chunk' writer transformer and returns the monad's value.+evalChunkWriterT :: Monad m => WriterT [Chunk] m a -> m a+evalChunkWriterT = liftM fst . runChunkWriterT++-- | Runs a 'Chunk' writer transformer and returns the written log.+execChunkWriterT :: Monad m => WriterT [Chunk] m a -> m String+execChunkWriterT = liftM snd . runChunkWriterT++-- | Flattens a list of chunks down into a single string. Inserts spaces+-- between chunks where the ends of adjacent chunks would otherwise merge into a+-- single C++ token.+combineChunks :: [Chunk] -> String+combineChunks chunks =+ let strs = map chunkContents chunks+ in concat $ flip map (zip ("":strs) strs) $ \(prev, cur) ->+ let needsSpace =+ not (null prev) && not (null cur) &&+ (let a = last prev+ b = head cur+ in -- "intconstx" should become "int const x"+ isIdentifierChar a && isIdentifierChar b ||+ -- Adjacent template parameter '>'s need spacing in old C++.+ a == '>' && b == '>')+ in if needsSpace then ' ':cur else cur++-- | Emits a single 'Chunk'.+say :: MonadWriter [Chunk] m => String -> m ()+say = tell . (:[]) . Chunk++-- | Emits a 'Chunk' for each string in a list.+says :: MonadWriter [Chunk] m => [String] -> m ()+says = tell . map Chunk++-- | Emits an 'Identifier'.+sayIdentifier :: MonadWriter [Chunk] m => Identifier -> m ()+sayIdentifier =+ sequence_ . intersperse (say "::") . map renderPart . identifierParts+ where renderPart part = do+ say $ idPartBase part+ case idPartArgs part of+ Nothing -> return ()+ Just args -> do+ say "<"+ sequence_ $ intersperse (say ", ") $ map (sayType Nothing) args+ say ">"++-- | @sayVar name maybeParamNames t@ speaks a variable declaration of the form+-- @\<type\> \<name\>@, where @\<name\>@ is the given name, and @\<type\>@ is+-- rendered by giving @maybeParamNames@ and @t@ to 'sayType'.+--+-- This function is useful for generating variable declarations, declarations+-- with assignments, and function prototypes and definitions.+sayVar :: MonadWriter [Chunk] m => String -> Maybe [String] -> Type -> m ()+sayVar name maybeParamNames t = sayType' t maybeParamNames topPrecedence $ say name++-- | @sayType maybeParamNames t@ renders @t@ in C++ syntax. If @t@ is a 'TFn',+-- then @maybeParamNames@ will provide variable names for parameters, if+-- present.+sayType :: MonadWriter [Chunk] m => Maybe [String] -> Type -> m ()+sayType maybeParamNames t = sayType' t maybeParamNames topPrecedence $ return ()++-- | Implementation of 'sayType', deals with recursion, precedence, and the+-- inside-out style of C++ type syntax.+sayType' :: MonadWriter [Chunk] m => Type -> Maybe [String] -> Int -> m () -> m ()+sayType' (normalizeType -> t) maybeParamNames outerPrec unwrappedOuter =+ let prec = typePrecedence t+ outer = if prec <= outerPrec+ then unwrappedOuter+ else say "(" >> unwrappedOuter >> say ")"+ in case t of+ TVoid -> say "void" >> outer+ TBool -> say "bool" >> outer+ TChar -> say "char" >> outer+ TUChar -> say "unsigned char" >> outer+ TShort -> say "short" >> outer+ TUShort -> say "unsigned short" >> outer+ TInt -> say "int" >> outer+ TUInt -> say "unsigned int" >> outer+ TLong -> say "long" >> outer+ TULong -> say "unsigned long" >> outer+ TLLong -> say "long long" >> outer+ TULLong -> say "unsigned long long" >> outer+ TFloat -> say "float" >> outer+ TDouble -> say "double" >> outer+ TInt8 -> say "int8_t" >> outer+ TInt16 -> say "int16_t" >> outer+ TInt32 -> say "int32_t" >> outer+ TInt64 -> say "int64_t" >> outer+ TWord8 -> say "uint8_t" >> outer+ TWord16 -> say "uint16_t" >> outer+ TWord32 -> say "uint32_t" >> outer+ TWord64 -> say "uint64_t" >> outer+ TPtrdiff -> say "ptrdiff_t" >> outer+ TSize -> say "size_t" >> outer+ TSSize -> say "ssize_t" >> outer+ TEnum e -> sayIdentifier (enumIdentifier e) >> outer+ TBitspace b -> case bitspaceCppTypeIdentifier b of+ Just identifier -> sayIdentifier identifier >> outer+ Nothing -> sayType' (bitspaceType b) maybeParamNames outerPrec unwrappedOuter+ TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer+ TRef t' -> sayType' t' Nothing prec $ say "&" >> outer+ TFn paramTypes retType -> sayType' retType Nothing prec $ do+ outer+ say "("+ sequence_ $ intersperse (say ", ") $+ flip map (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $+ \(ptype, pname) ->+ sayType' ptype Nothing topPrecedence $ forM_ pname say+ say ")"+ TCallback cb -> says [callbackImplClassName cb, "*"] >> outer+ TObj cls -> sayIdentifier (classIdentifier cls) >> outer+ TObjToHeap cls -> sayType' (TRef $ TConst $ TObj cls) maybeParamNames outerPrec unwrappedOuter+ TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter+ -- TODO ^ Is using the outer stuff correctly here?++topPrecedence :: Int+topPrecedence = 11++typePrecedence :: Type -> Int+typePrecedence t = case t of+ TFn {} -> 10+ TPtr {} -> 9+ TRef {} -> 9+ _ -> 8
+ src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs view
@@ -0,0 +1,616 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, ViewPatterns #-}++-- | Internal portion of the C++ code generator.+module Foreign.Hoppy.Generator.Language.Cpp.Internal (+ Generation,+ generate,+ generatedFiles,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (liftM, unless, when)+import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)+import Control.Monad.Writer (WriterT, execWriterT, runWriterT, tell)+import Control.Monad.Trans (lift)+import Data.Foldable (forM_)+import Data.List (intersperse)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, isJust)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mappend, mconcat, mempty)+#endif+import qualified Data.Set as S+import Foreign.Hoppy.Generator.Common+import Foreign.Hoppy.Generator.Language.Cpp+import Foreign.Hoppy.Generator.Spec++data CoderDirection = DoDecode | DoEncode+ deriving (Eq, Show)++type Generator = ReaderT Env (WriterT [Chunk] (WriterT (S.Set Include) (Either ErrorMsg)))++data Env = Env+ { envInterface :: Interface+ , envModule :: Module+ }++addIncludes :: [Include] -> Generator ()+addIncludes = lift . lift . tell . S.fromList++addInclude :: Include -> Generator ()+addInclude = addIncludes . (:[])++-- Have to call this addReqsM, addReqs is taken by HasReqs.+addReqsM :: Reqs -> Generator ()+addReqsM = lift . lift . tell . reqsIncludes++askInterface :: MonadReader Env m => m Interface+askInterface = liftM envInterface ask++askModule :: MonadReader Env m => m Module+askModule = liftM envModule ask++-- | Halts generation and returns the given error message.+abort :: ErrorMsg -> Generator a+abort = lift . lift . lift . Left++execGenerator :: Interface -> Module -> Maybe String -> Generator a -> Either ErrorMsg String+execGenerator interface m maybeHeaderGuardName action = do+ (contents, includes) <-+ (runWriterT $+ -- WriterT (S.Set Include) (Either String) String:+ execChunkWriterT $+ -- WriterT [Chunk] (WriterT (S.Set Include) (Either String)) a:+ runReaderT action $ Env interface m)+ :: Either String (String, S.Set Include)+ return $ execChunkWriter $ do+ say "////////// GENERATED FILE, EDITS WILL BE LOST //////////\n"+ forM_ maybeHeaderGuardName $ \x -> do+ says ["\n#ifndef ", x, "\n"]+ says ["#define ", x, "\n"]+ unless (S.null includes) $ do+ say "\n"+ forM_ includes $ say . includeToString+ say "\nextern \"C\" {\n"+ say contents+ say "\n} // extern \"C\"\n"+ forM_ maybeHeaderGuardName $ \x ->+ says ["\n#endif // ifndef ", x, "\n"]++sayFunction :: String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()+sayFunction name paramNames t maybeBody = do+ case t of+ TFn {} -> return ()+ _ -> abort $ concat ["sayFunction: A function type is required, given ", show t, "."]+ say "\n" -- New top-level structure, leave a blank line.+ sayVar name (Just paramNames) t+ case maybeBody of+ Nothing -> say ";\n"+ Just body -> do+ say " {\n"+ body -- TODO Indent.+ say "}\n"++-- | The in-memory result of generating C++ code for an interface.+data Generation = Generation+ { generatedFiles :: M.Map FilePath String+ -- ^ A map from paths of generated files to the contents of those files.+ -- The file paths are relative paths below the C++ generation root.+ }++-- | Runs the C++ code generator against an interface.+generate :: Interface -> Either ErrorMsg Generation+generate interface =+ fmap (Generation . M.fromList) $+ execWriterT $+ forM_ (M.elems $ interfaceModules interface) $ \m -> do+ let headerGuard = concat ["HOPPY_MODULE_", interfaceName interface, "_", moduleName m]+ header <- lift $ execGenerator interface m (Just headerGuard) sayModuleHeader+ tell [(moduleHppPath m, header)]+ source <- lift $ execGenerator interface m Nothing sayModuleSource+ tell [(moduleCppPath m, source)]++sayModuleHeader :: Generator ()+sayModuleHeader = do+ m <- askModule+ addReqsM $ moduleReqs m+ mapM_ (sayExport False) $ M.elems $ moduleExports m++sayModuleSource :: Generator ()+sayModuleSource = do+ m <- askModule+ addInclude $ includeLocal $ moduleHppPath m+ mapM_ (sayExport True) $ M.elems $ moduleExports m++sayExport :: Bool -> Export -> Generator ()+sayExport sayBody export = case export of+ ExportVariable v -> when sayBody $ sayExportVariable v++ -- Nothing to do C++ side for an enum or bitspace.+ ExportEnum _ -> return ()+ ExportBitspace _ -> return ()++ ExportFn fn ->+ -- Export a single function.+ when sayBody $ do+ addReqsM $ fnReqs fn+ sayExportFn (fnExtName fn)+ (case fnCName fn of+ FnName identifier -> CallFn $ sayIdentifier identifier+ FnOp op -> CallOp op)+ Nothing+ (fnParams fn)+ (fnReturn fn)+ sayBody++ ExportClass cls -> when sayBody $ do+ let clsPtr = TPtr $ TObj cls+ justClsPtr = Just clsPtr+ -- TODO Is this redundant for a completely empty class? (No ctors or methods, private dtor.)+ addReqsM $ classReqs cls -- This is needed at least for the delete function.++ -- Export each of the class's constructors.+ forM_ (classCtors cls) $ \ctor ->+ sayExportFn (getClassyExtName cls ctor)+ (CallFn $ say "new" >> sayIdentifier (classIdentifier cls))+ Nothing+ (ctorParams ctor)+ clsPtr+ sayBody++ -- Export a delete function for the class.+ when (classDtorIsPublic cls) $+ sayFunction (classDeleteFnCppName cls)+ ["self"]+ (TFn [TPtr $ TConst $ TObj cls] TVoid) $+ Just $ say "delete self;\n"++ -- Export each of the class's methods.+ forM_ (classMethods cls) $ \method -> do+ let nonMemberCall =+ methodStatic method == Static ||+ case methodImpl method of+ RealMethod {} -> False+ FnMethod {} -> True+ let static = methodStatic method == Static+ sayExportFn (getClassyExtName cls method)+ (case methodImpl method of+ RealMethod name -> case name of+ FnName cName -> CallFn $ do+ when static $ do+ sayIdentifier (classIdentifier cls)+ say "::"+ say cName+ FnOp op -> CallOp op+ FnMethod name -> case name of+ FnName cName -> CallFn $ sayIdentifier cName+ FnOp op -> CallOp op)+ (if nonMemberCall then Nothing else justClsPtr)+ (methodParams method)+ (methodReturn method)+ sayBody++ -- Export upcast functions for the class to its direct superclasses.+ forM_ (classSuperclasses cls) $ genUpcastFns cls+ -- Export downcast functions from the class's direct and indirect+ -- superclasses to it.+ unless (classIsSubclassOfMonomorphic cls) $+ forM_ (classSuperclasses cls) $ genDowncastFns cls++ ExportCallback cb -> do+ -- Need <memory> for std::shared_ptr.+ addReqsM $ callbackReqs cb `mappend` reqInclude (includeStd "memory")+ sayExportCallback sayBody cb++ where genUpcastFns :: Class -> Class -> Generator ()+ genUpcastFns cls ancestorCls = do+ sayFunction (classCastFnCppName cls ancestorCls)+ ["self"]+ (TFn [TPtr $ TConst $ TObj cls] $ TPtr $ TConst $ TObj ancestorCls)+ (Just $ say "return self;\n")+ forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls++ genDowncastFns :: Class -> Class -> Generator ()+ genDowncastFns cls ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do+ let clsPtr = TPtr $ TConst $ TObj cls+ ancestorPtr = TPtr $ TConst $ TObj ancestorCls+ sayFunction (classCastFnCppName ancestorCls cls)+ ["self"]+ (TFn [ancestorPtr] clsPtr) $ Just $ do+ say "return dynamic_cast<"+ sayType Nothing clsPtr+ say ">(self);\n"+ forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls++sayExportVariable :: Variable -> Generator ()+sayExportVariable v = do+ let (isConst, deconstType) = case varType v of+ TConst t -> (True, t)+ t -> (False, t)++ -- Say a getter function.+ sayExportFn (varGetterExtName v)+ (VarRead $ varIdentifier v)+ Nothing+ []+ deconstType+ True++ -- Say a setter function.+ unless isConst $+ sayExportFn (varSetterExtName v)+ (VarWrite $ varIdentifier v)+ Nothing+ [deconstType]+ TVoid+ True++data CallType =+ CallOp Operator+ | CallFn (Generator ())+ | VarRead Identifier+ | VarWrite Identifier++sayExportFn :: ExtName+ -> CallType+ -> Maybe Type+ -> [Type]+ -> Type+ -> Bool+ -> Generator ()+sayExportFn extName callType maybeThisType paramTypes retType sayBody = do+ let paramCount = length paramTypes+ paramCTypeMaybes = map typeToCType paramTypes+ paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes+ retCTypeMaybe = typeToCType retType+ retCType = fromMaybe retType retCTypeMaybe++ addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes)++ sayFunction (externalNameToCpp extName)+ (maybe id (const ("self":)) maybeThisType $+ zipWith3 (\t ctm -> case t of+ TCallback {} -> toArgNameAlt+ _ -> if isJust ctm then toArgNameAlt else toArgName)+ paramTypes paramCTypeMaybes [1..paramCount])+ (TFn (maybe id (:) maybeThisType paramCTypes) retCType) $+ if not sayBody+ then Nothing+ else Just $ do+ -- Convert arguments that aren't passed in directly.+ mapM_ (sayArgRead DoDecode) $ zip3 [1..] paramTypes paramCTypeMaybes++ -- Determine how to call the exported function or method.+ let sayCall = case callType of+ CallOp op -> do+ say "("+ let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0+ paramNames@(p1:p2:_) = (if isJust maybeThisType then ("(*self)":) else id) $+ map toArgName [1..]+ assertParamCount n =+ when (effectiveParamCount /= n) $ abort $ concat+ ["sayExportFn: Operator ", show op, " for export ", show extName,+ " requires ", show n, " parameter(s), but has ", show effectiveParamCount,+ "."]+ case operatorType op of+ UnaryPrefixOperator symbol -> assertParamCount 1 >> says [symbol, p1]+ UnaryPostfixOperator symbol -> assertParamCount 1 >> says [p1, symbol]+ BinaryOperator symbol -> assertParamCount 2 >> says [p1, symbol, p2]+ CallOperator ->+ says $ p1 : "(" : take (effectiveParamCount - 1) (drop 1 paramNames) ++ [")"]+ ArrayOperator -> assertParamCount 2 >> says [p1, "[", p2, "]"]+ say ")"+ CallFn sayCppName -> do+ when (isJust maybeThisType) $ say "self->"+ sayCppName+ say "("+ sayArgNames paramCount+ say ")"+ VarRead identifier -> sayIdentifier identifier+ VarWrite identifier -> sayIdentifier identifier >> says [" = ", toArgName 1]++ -- Write the call, transforming the return value if necessary.+ case (retType, retCTypeMaybe) of+ (TVoid, Nothing) -> sayCall >> say ";\n"+ (_, Nothing) -> say "return " >> sayCall >> say ";\n"+ (TBitspace b, Just _) -> do+ addReqsM $ bitspaceReqs b+ let convFn = bitspaceFromCppValueFn b+ say "return "+ forM_ convFn $ \f -> says [f, "("]+ sayCall+ when (isJust convFn) $ say ")"+ say ";\n";+ (TRef cls, Just (TPtr cls')) | cls == cls' -> say "return &(" >> sayCall >> say ");\n"+ (TObj cls, Just (TPtr (TConst (TObj cls')))) | cls == cls' -> sayReturnNewCopy cls sayCall+ (TObjToHeap cls, Just (TPtr (TObj cls'))) | cls == cls' -> sayReturnNewCopy cls sayCall+ ts -> abort $ concat ["sayExportFn: Unexpected return types ", show ts,+ "while generating binding for ", show extName, "."]++ where sayReturnNewCopy cls sayCall =+ say "return new" >> sayIdentifier (classIdentifier cls) >> say "(" >>+ sayCall >> say ");\n"++-- | If @dir@ is 'DoDecode', then we are a C++ function reading an argument from+-- foreign code. If @dir@ is 'DoEncode', then we are invoking a foreign+-- callback.+sayArgRead :: CoderDirection -> (Int, Type, Maybe Type) -> Generator ()+sayArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of+ TBitspace b -> case maybeCType of+ Just cType -> do+ let cppTypeId = fromMaybe (error $ concat+ ["sayArgRead: Expected ", show b,+ " to have a C++ type, but it doesn't."]) $+ bitspaceCppTypeIdentifier b+ addReqsM $ bitspaceReqs b+ case dir of+ -- Convert from cType to cppType.+ DoDecode -> do+ sayIdentifier cppTypeId+ says [" ", toArgName n, " = ", fromMaybe "" $ bitspaceToCppValueFn b,+ "(", toArgNameAlt n, ");\n"]+ -- Convert from cppType to cType.+ DoEncode -> do+ sayVar (toArgName n) Nothing cType+ says [" = ", fromMaybe "" $ bitspaceFromCppValueFn b,+ "(", toArgNameAlt n, ");\n"]+ Nothing ->+ return ()++ TCallback cb -> do+ case dir of+ DoDecode -> return ()+ DoEncode -> abort $ concat+ ["sayArgRead: Encoding of callbacks is not supported. Given ",+ show cb, "."]+ says [callbackClassName cb, " ", toArgName n, "(", toArgNameAlt n, ");\n"]++ TRef t -> convertObj t++ TObj _ -> convertObj $ TConst cppType+ TObjToHeap cls -> case dir of+ DoDecode -> error $ tObjToHeapWrongDirectionErrorMsg (Just "sayArgRead") cls+ DoEncode -> do+ sayIdentifier $ classIdentifier cls+ says ["* ", toArgName n, " = new "]+ sayIdentifier $ classIdentifier cls+ says ["(", toArgNameAlt n, ");\n"]++ -- Primitive types don't need to be encoded/decoded. But if maybeCType is a+ -- Just, then we're expected to do some encoding/decoding, so something is+ -- wrong.+ --+ -- TODO Do we need to handle TConst?+ _ -> forM_ maybeCType $ \cType ->+ abort $ concat+ ["sayArgRead: Don't know how to ", show dir, " between C-type ", show cType,+ " and C++-type ", show cppType, "."]++ where convertObj cppType' = case dir of+ DoDecode -> do+ sayVar (toArgName n) Nothing $ TRef cppType'+ says [" = *", toArgNameAlt n, ";\n"]+ DoEncode -> do+ sayVar (toArgName n) Nothing $ TPtr cppType'+ says [" = &", toArgNameAlt n, ";\n"]++sayArgNames :: Int -> Generator ()+sayArgNames count =+ says $ intersperse ", " $ map toArgName [1..count]++sayExportCallback :: Bool -> Callback -> Generator ()+sayExportCallback sayBody cb = do+ let className = callbackClassName cb+ implClassName = callbackImplClassName cb+ fnName = callbackFnName cb+ paramTypes = callbackParams cb+ paramCount = length paramTypes+ retType = callbackReturn cb+ cbType = TCallback cb+ fnType = TFn paramTypes retType++ -- The function pointer we receive from foreign code will work with C-types,+ -- so determine what that function looks like.+ let paramCTypes = zipWith fromMaybe paramTypes $ map typeToCType paramTypes+ retCType = fromMaybe retType $ typeToCType retType++ addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes)++ let fnCType = TFn paramCTypes retCType+ fnPtrCType = TPtr fnCType++ if not sayBody+ then do+ -- Render the class declarations into the header file.+ addInclude $ includeStd "memory" -- Needed for std::shared_ptr.++ says ["\nclass ", implClassName, " {\n"]+ say "public:\n"+ says [" explicit ", implClassName, "("] >> sayType Nothing fnPtrCType >>+ say ", void(*)(void(*)()), bool);\n"+ says [" ~", implClassName, "();\n"]+ say " " >> sayVar "operator()" Nothing fnType >> say ";\n"+ say "private:\n"+ says [" ", implClassName, "(const ", implClassName, "&);\n"]+ says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"]+ say "\n"+ say " " >> sayVar "f_" Nothing (TConst fnPtrCType) >> say ";\n"+ say " void (*const release_)(void(*)());\n"+ say " const bool releaseRelease_;\n"+ say "};\n"++ says ["\nclass ", className, " {\n"]+ say "public:\n"+ says [" explicit ", className, "(", implClassName, "* impl) : impl_(impl) {}\n"]+ say " " >> sayVar "operator()" Nothing fnType >> say ";\n"+ say "private:\n"+ says [" std::shared_ptr<", implClassName, "> impl_;\n"]+ say "};\n"++ else do+ -- Render the classes' methods into the source file. First render the+ -- impl class's constructor.+ says ["\n", implClassName, "::", implClassName, "("] >> sayVar "f" Nothing fnPtrCType >>+ say ", void (*release)(void(*)()), bool releaseRelease) :\n"+ say " f_(f), release_(release), releaseRelease_(releaseRelease) {}\n"++ -- Then render the destructor.+ says ["\n", implClassName, "::~", implClassName, "() {\n"]+ say " if (release_) {\n"+ say " release_(reinterpret_cast<void(*)()>(f_));\n"+ say " if (releaseRelease_) {\n"+ say " release_(reinterpret_cast<void(*)()>(release_));\n"+ say " }\n"+ say " }\n"+ say "}\n"++ -- Render the impl operator() method, which does argument decoding and+ -- return value encoding and passes C++ values to underlying function+ -- poiner.+ --+ -- TODO Abstract the duplicated code here and in sayExportFn.+ let paramCTypeMaybes = map typeToCType paramTypes+ retCTypeMaybe = typeToCType retType++ sayFunction (implClassName ++ "::operator()")+ (zipWith (\ctm -> if isJust ctm then toArgNameAlt else toArgName)+ paramCTypeMaybes [1..paramCount])+ fnType $ Just $ do+ -- Convert arguments that aren't passed in directly.+ mapM_ (sayArgRead DoEncode) $ zip3 [1..] paramTypes paramCTypeMaybes+ -- Invoke the function pointer into foreign code.+ let sayCall = say "f_(" >> sayArgNames paramCount >> say ")"+ case (retType, retCTypeMaybe) of+ (TVoid, Nothing) -> sayCall >> say ";\n"+ (_, Nothing) -> say "return " >> sayCall >> say ";\n"+ (TBitspace b, Just _) -> do+ addReqsM $ bitspaceReqs b+ let convFn = bitspaceToCppValueFn b+ say "return "+ forM_ convFn $ \f -> says [f, "("]+ sayCall+ when (isJust convFn) $ say ")"+ say ";\n";+ (TObj cls1, Just retCType@(TPtr (TConst (TObj cls2)))) | cls1 == cls2 -> do+ sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n"+ sayVar "result" Nothing retType >> say " = *resultPtr;\n"+ say "delete resultPtr;\n"+ say "return result;\n"+ (TRef (TConst (TObj cls1)), Just (TPtr (TConst (TObj cls2)))) | cls1 == cls2 ->+ say "return *(" >> sayCall >> say ");\n"+ (TRef (TObj cls1), Just (TPtr (TObj cls2))) | cls1 == cls2 ->+ say "return *(" >> sayCall >> say ");\n"+ ts -> abort $ concat+ ["sayExportCallback: Unexpected return types ", show ts, "."]++ -- Render the non-impl operator() method, which simply passes C++ values+ -- along to the impl object.+ sayFunction (className ++ "::operator()")+ (map toArgName [1..paramCount])+ fnType $ Just $ do+ case retType of+ TVoid -> say "(*impl_)("+ _ -> say "return (*impl_)("+ sayArgNames paramCount+ say ");\n"++ -- Render the function that creates a new callback object.+ let newCallbackFnType = TFn [ fnPtrCType+ , TPtr (TFn [TPtr $ TFn [] TVoid] TVoid)+ , TBool+ ]+ cbType+ sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $+ says ["return new ", implClassName, "(f, release, releaseRelease);\n"]++-- | Returns a 'Type' iff there is a C type distinct from the given C++ type+-- that should be used for conversion.+typeToCType :: Type -> Maybe Type+typeToCType t = case t of+ -- Because we don't know (although we could...) the direction in which we're+ -- converting the bitspace value, when the bitspace has a C++ type we have to+ -- assume that it needs to be converted. The caller will sort out whether a+ -- conversion is actually requested.+ TBitspace b -> case bitspaceCppTypeIdentifier b of+ Just _ -> Just $ bitspaceType b+ Nothing -> Nothing+ TRef t' -> Just $ TPtr t'+ TObj _ -> Just $ TPtr $ TConst t+ TObjToHeap cls -> Just $ TPtr $ TObj cls+ TConst t' -> typeToCType t'+ _ -> Nothing++typeReqs :: Type -> Generator Reqs+typeReqs t = case t of+ TVoid -> return mempty+ TBool -> return mempty+ TChar -> return mempty+ TUChar -> return mempty+ TShort -> return mempty+ TUShort -> return mempty+ TInt -> return mempty+ TUInt -> return mempty+ TLong -> return mempty+ TULong -> return mempty+ TLLong -> return mempty+ TULLong -> return mempty+ TFloat -> return mempty+ TDouble -> return mempty+ TInt8 -> return cstdintReqs+ TInt16 -> return cstdintReqs+ TInt32 -> return cstdintReqs+ TInt64 -> return cstdintReqs+ TWord8 -> return cstdintReqs+ TWord16 -> return cstdintReqs+ TWord32 -> return cstdintReqs+ TWord64 -> return cstdintReqs+ TPtrdiff -> return cstddefReqs+ TSize -> return cstddefReqs+ TSSize -> return cstddefReqs+ TEnum e -> return $ enumReqs e+ TBitspace b -> typeReqs $ bitspaceType b+ TPtr t' -> typeReqs t'+ TRef t' -> typeReqs t'+ TFn paramTypes retType ->+ -- TODO Is the right 'ReqsType' being used recursively here?+ mconcat <$> mapM typeReqs (retType:paramTypes)+ TCallback cb -> do+ cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$>+ findExportModule (callbackExtName cb)+ -- TODO Is the right 'ReqsType' being used recursively here?+ fnTypeReqs <- typeReqs $ callbackToTFn cb+ return $ cbClassReqs `mappend` fnTypeReqs+ TObj cls -> return $ classReqs cls+ TObjToHeap cls -> return $ classReqs cls+ TConst t' -> typeReqs t'++cstddefReqs :: Reqs+cstddefReqs = reqInclude $ includeStd "cstddef"++cstdintReqs :: Reqs+cstdintReqs = reqInclude $ includeStd "cstdint"++findExportModule :: ExtName -> Generator Module+findExportModule extName =+ fromMaybeM (abort $ concat+ ["findExportModule: Can't find module exporting ", fromExtName extName, "."]) =<<+ fmap (M.lookup extName . interfaceNamesToModules) askInterface
+ src/Foreign/Hoppy/Generator/Language/Haskell.hs view
@@ -0,0 +1,674 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Shared portion of the Haskell code generator. Usable by binding+-- definitions.+module Foreign.Hoppy.Generator.Language.Haskell (+ getModuleName,+ toModuleName,+ -- * Code generators+ Partial (..),+ Output (..),+ Generator,+ runGenerator,+ evalGenerator,+ execGenerator,+ renderPartial,+ withErrorContext,+ inFunction,+ -- * Exports+ HsExport,+ addExport,+ addExport',+ addExports,+ -- * Imports+ addImports,+ importHsModuleForExtName,+ -- * Code generation+ sayLn,+ saysLn,+ ln,+ indent,+ sayLet,+ toHsEnumTypeName,+ toHsEnumCtorName,+ toHsBitspaceTypeName,+ toHsBitspaceValueName,+ toHsBitspaceToNumName,+ toHsBitspaceClassName,+ toHsBitspaceFromValueName,+ toHsValueClassName,+ toHsWithValuePtrName,+ toHsPtrClassName,+ toHsCastMethodName,+ toHsDownCastClassName,+ toHsDownCastMethodName,+ toHsCastPrimitiveName,+ toHsConstCastFnName,+ toHsDataTypeName,+ toHsClassDeleteFnName,+ toHsMethodName,+ toHsMethodName',+ toHsCallbackCtorName,+ toHsFnName,+ toArgName,+ HsTypeSide (..),+ cppTypeToHsTypeAndUse,+ prettyPrint,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Arrow (first)+import Control.Monad (when)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (Except, catchError, runExcept, throwError)+#else+import Control.Monad.Error (catchError, throwError)+#endif+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Writer (WriterT, censor, runWriterT, tell)+import Data.Char (toUpper)+import Data.Foldable (forM_)+import Data.Function (on)+import Data.Functor (($>))+import Data.List (intercalate, intersperse)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, isJust)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid, mappend, mconcat, mempty)+#endif+import Data.Tuple (swap)+import Foreign.Hoppy.Generator.Common (capitalize, lowerFirst)+import Foreign.Hoppy.Generator.Spec+import qualified Language.Haskell.Pretty as P+import Language.Haskell.Syntax (+ HsName (HsIdent),+ HsQName (Special, UnQual),+ HsSpecialCon (HsUnitCon),+ HsType (HsTyApp, HsTyCon, HsTyFun),+ )++-- | Returns the complete Haskell module name for a 'Module' in an 'Interface',+-- taking into account the 'interfaceHaskellModuleBase' and the+-- 'moduleHaskellName'.+getModuleName :: Interface -> Module -> String+getModuleName interface m =+ intercalate "." $+ interfaceHaskellModuleBase interface +++ fromMaybe [toModuleName $ moduleName m] (moduleHaskellName m)++-- | Performs case conversions on the given string to ensure that it is a valid+-- component of a Haskell module name.+toModuleName :: String -> String+toModuleName (x:xs) = toUpper x : xs+toModuleName "" = ""++-- | Renders a set of imports in Haskell syntax on multiple lines.+renderImports :: HsImportSet -> [String]+renderImports = map renderModuleImport . M.assocs . getHsImportSet+ where -- | Renders an import as a string that contains one or more lines.+ renderModuleImport :: (HsImportKey, HsImportSpecs) -> String+ renderModuleImport (key, specs) =+ let moduleName = hsImportModule key+ maybeQualifiedName = hsImportQualifiedName key+ isQual = isJust maybeQualifiedName+ importPrefix = if hsImportSource specs+ then "import {-# SOURCE #-} "+ else "import "+ importQualifiedPrefix =+ if hsImportSource specs+ then "import {-# SOURCE #-} qualified "+ else "import qualified "+ in case getHsImportSpecs specs of+ Nothing -> case maybeQualifiedName of+ Nothing -> importPrefix ++ moduleName+ Just qualifiedName ->+ concat [importQualifiedPrefix, moduleName, " as ", qualifiedName]+ Just specMap ->+ let specWords :: [String]+ specWords = concatWithCommas $ map renderSpecAsWords $ M.assocs specMap+ singleLineImport :: String+ singleLineImport =+ concat $+ (if isQual then importQualifiedPrefix else importPrefix) :+ moduleName : " (" : intersperse " " specWords +++ case maybeQualifiedName of+ Nothing -> [")"]+ Just qualifiedName -> [") as ", qualifiedName]+ in if null $ drop maxLineLength singleLineImport+ then singleLineImport+ else intercalate "\n" $+ (importPrefix ++ moduleName ++ " (") :+ groupWordsIntoLines specWords +++ case maybeQualifiedName of+ Nothing -> [" )"]+ Just qualifiedName -> [" ) as " ++ qualifiedName]++ -- | Takes an import spec, and returns a list of words that comprise+ -- that spec. Line breaking may be performed by the caller only between+ -- these words.+ renderSpecAsWords :: (HsImportName, HsImportVal) -> [String]+ renderSpecAsWords (name, val) = case val of+ HsImportVal -> [name]+ -- When we export specific subnames under a name, then we put a+ -- non-breaking space between the outer name and the first inner name,+ -- just for a little readability.+ HsImportValSome parts -> case parts of+ [] -> [name ++ " ()"]+ [part] -> [concat [name, " (", part, ")"]]+ part0:parts -> let (parts', [partN]) = splitAt (length parts - 1) parts+ in concat [name, " (", part0, ","] :+ map (++ ",") parts' +++ [partN ++ ")"]+ HsImportValAll -> [name ++ " (..)"]++ -- | Takes a list of list of words. Concatenates to get a list of+ -- words, appending a comma to the final word in each list of words.+ concatWithCommas :: [[String]] -> [String]+ concatWithCommas [] = []+ concatWithCommas ss =+ let (ss', ssLast@[_]) = splitAt (length ss - 1) ss+ in concat $ map (onLast (++ ",")) ss' ++ ssLast++ -- | Applies a function to the final element of a list, if the list is+ -- nonempty.+ onLast :: (a -> a) -> [a] -> [a]+ onLast _ [] = []+ onLast f xs = let (xs', [x]) = splitAt (length xs - 1) xs+ in xs' ++ [f x]++ -- | Takes a list of words, and returns a list of lines with the words+ -- flowed.+ groupWordsIntoLines :: [String] -> [String]+ groupWordsIntoLines [] = []+ groupWordsIntoLines words =+ let (wordCount, line, _) =+ last $+ takeWhile (\(wordCount, _, len) -> wordCount <= 1 || len <= maxLineLength) $+ scanl (\(wordCount, acc, len) word ->+ (wordCount + 1,+ concat [acc, " ", word],+ len + 1 + length word))+ (0, "", 0)+ words+ in line : groupWordsIntoLines (drop wordCount words)++ maxLineLength :: Int+ maxLineLength = 100++-- | A generator monad for Haskell code.+--+-- Errors thrown in this monad are of the form:+--+-- > "$problem; $context; $moreContext; $evenMoreContext."+--+-- For example, "Class Foo is not convertible (use classModifyConversion);+-- generating function bar; in module baz.".+--+-- The main error message given to 'throwError' should be capitalized and should+-- not end with punctuation. If there is a suggestion, include it in+-- parentheses at the end of the message. 'withErrorContext' and 'inFunction'+-- add context information, and should be given clauses, without punctuation.+#if MIN_VERSION_mtl(2,2,1)+type Generator = ReaderT Env (WriterT Output (Except ErrorMsg))+#else+type Generator = ReaderT Env (WriterT Output (Either ErrorMsg))+#endif++-- | Context information for generating Haskell code.+data Env = Env+ { envInterface :: Interface+ , envModuleName :: String+ }++askInterface :: Generator Interface+askInterface = envInterface <$> ask++askModuleName :: Generator String+askModuleName = envModuleName <$> ask++-- | A partially-rendered 'Module'. Contains all of the module's bindings, but+-- may be subject to further processing.+data Partial = Partial+ { partialModuleHsName :: String+ , partialOutput :: Output+ }++instance Eq Partial where+ (==) = (==) `on` partialModuleHsName++instance Ord Partial where+ compare = compare `on` partialModuleHsName++-- | A chunk of generated Haskell code, including information about imports and+-- exports.+data Output = Output+ { outputExports :: [HsExport]+ -- ^ Haskell module exports. Each 'HsExport' should include one item to go+ -- in the export list of the generated module. Should only contain objects+ -- imported or defined in the same 'Output'.+ , outputImports :: HsImportSet+ -- ^ Haskell module imports. Should include all imports needed for the+ -- 'outputBody'.+ , outputBody :: [String]+ -- ^ Lines of Haskell code (possibly empty). These lines may not contain+ -- the newline character in them. There is an implicit newline between each+ -- string, as given by @intercalate \"\\n\" . outputBody@.+ }++instance Monoid Output where+ mempty = Output mempty mempty mempty++ (Output e i b) `mappend` (Output e' i' b') =+ Output (e `mappend` e') (i `mappend` i') (b `mappend` b')++ mconcat os =+ Output (mconcat $ map outputExports os)+ (mconcat $ map outputImports os)+ (mconcat $ map outputBody os)++-- | Runs a generator action for the given interface and module name string.+-- Returns an error message if an error occurred, otherwise the action's output+-- together with its value.+runGenerator :: Interface -> String -> Generator a -> Either ErrorMsg (Partial, a)+runGenerator iface modName generator =+ fmap (first (Partial modName) . swap) $+#if MIN_VERSION_mtl(2,2,1)+ runExcept $+#endif+ flip catchError (\msg -> throwError $ msg ++ ".") $+ runWriterT $ runReaderT generator $ Env iface modName++-- | Runs a generator action and returns the its value.+evalGenerator :: Interface -> String -> Generator a -> Either ErrorMsg a+evalGenerator iface modName =+ fmap snd . runGenerator iface modName++-- | Runs a generator action and returns its output.+execGenerator :: Interface -> String -> Generator a -> Either ErrorMsg Partial+execGenerator iface modName =+ fmap fst . runGenerator iface modName++-- | Converts a 'Partial' into a complete Haskell module.+renderPartial :: Partial -> String+renderPartial partial =+ let modName = partialModuleHsName partial+ output = partialOutput partial+ imports = outputImports output+ body =+ intercalate "\n" $ concat+ [ [ "---------- GENERATED FILE, EDITS WILL BE LOST ----------"+ , ""+ ]+ , case outputExports output of+ [] -> [concat ["module ", modName, " where"]]+ exports ->+ concat ["module ", modName, " ("] :+ map (\export -> concat [" ", export, ","]) exports +++ [" ) where"]+ , if M.null $ getHsImportSet imports+ then []+ else "" : renderImports imports+ , [""]+ , outputBody output+ ]+ in body++-- | Adds context information to the end of any error message thrown by the+-- action. See 'Generator'.+withErrorContext :: String -> Generator a -> Generator a+withErrorContext msg' action = catchError action $ \msg -> throwError $ concat [msg, "; ", msg']++-- | Adds the given function name to any error message thrown by the action, for+-- context.+inFunction :: String -> Generator a -> Generator a+inFunction fnName = withErrorContext $ "in " ++ fnName++-- | Indicates strings that represent an item in a Haskell module export list.+type HsExport = String++-- | Adds an export to the current module.+addExport :: HsExport -> Generator ()+addExport = addExports . (:[])++-- | @addExport' \"x\"@ adds an export of the form @x (..)@ to the current+-- module.+addExport' :: HsExport -> Generator ()+addExport' x = addExports [x ++ " (..)"]++-- | Adds multiple exports to the current module.+addExports :: [HsExport] -> Generator ()+addExports exports = tell $ mempty { outputExports = exports }++-- | Adds imports to the current module.+addImports :: HsImportSet -> Generator ()+addImports imports = tell mempty { outputImports = imports }++-- | Imports all of the objects for the given external name into the current+-- module. This is a no-op of the external name is defined in the current+-- module.+importHsModuleForExtName :: ExtName -> Generator ()+importHsModuleForExtName extName = inFunction "importHsModuleForExtName" $ do+ iface <- askInterface+ case M.lookup extName $ interfaceNamesToModules iface of+ Just ownerModule -> do+ let ownerModuleName = getModuleName iface ownerModule+ currentModuleName <- askModuleName+ when (currentModuleName /= ownerModuleName) $+ -- Yes, this currently imports the whole dang module to keep things+ -- simple.+ addImports $ hsWholeModuleImport ownerModuleName+ Nothing ->+ throwError $ concat+ ["Couldn't find module for ", show extName,+ " (maybe you forgot to include it in an exports list?)"]++-- | Outputs a line of Haskell code. A newline will be added on the end of the+-- input. Newline characters must not be given to this function.+sayLn :: String -> Generator ()+sayLn x =+ if '\n' `elem` x+ then inFunction "sayLn" $ throwError $ concat+ ["Refusing to speak '\n', received ", show x, " (use (mapM_ sayLn . lines) instead)"]+ else tell $ mempty { outputBody = [x] }++-- | Outputs multiple words to form a line of Haskell code (effectively @saysLn+-- = sayLn . concat@).+saysLn :: [String] -> Generator ()+saysLn = sayLn . concat++-- | Outputs an empty line of Haskell code. This is reportedly valid Perl code+-- as well.+ln :: Generator ()+ln = sayLn ""++-- | Runs the given action, indenting all code output by the action one level.+indent :: Generator a -> Generator a+indent = censor $ \o -> o { outputBody = map (\x -> ' ':' ':x) $ outputBody o }++-- | Takes a list of binding actions and a body action, and outputs a @let@+-- expression. By passing in 'Nothing' for the body, it will be omitted, so+-- @let@ statements in @do@ blocks can be created as well. Output is of the+-- form:+--+-- > let+-- > <binding1>+-- > ...+-- > <bindingN>+-- > in+-- > <body>+--+-- To stretch a binding over multiple lines, lines past the first should use+-- 'indent' manually.+sayLet :: [Generator ()] -> Maybe (Generator ()) -> Generator ()+sayLet bindings maybeBody = do+ sayLn "let"+ indent $ sequence_ bindings+ forM_ maybeBody $ \body ->+ -- Indent here in case we have a "let ... in ..." within a do block.+ indent $ do+ sayLn "in"+ indent body++-- | Internal helper function for constructing Haskell names from external+-- names. Returns a name that is a suitable Haskell type name for the external+-- name, and if given 'Const', then with @\"Const\"@ appended.+toHsTypeName :: Constness -> ExtName -> String+toHsTypeName cst extName =+ (case cst of+ Const -> (++ "Const")+ Nonconst -> id) $+ case fromExtName extName of+ x:xs -> toUpper x:xs+ [] -> []++-- | Returns the Haskell name for an enum.+toHsEnumTypeName :: CppEnum -> String+toHsEnumTypeName = toHsTypeName Nonconst . enumExtName++-- | Constructs the data constructor name for a value in an enum. Like C++ and+-- unlike say Java, Haskell enum values aren't in a separate enum-specific+-- namespace, so we prepend the enum name to the value name to get the data+-- constructor name. The value name is a list of words; see 'enumValueNames'.+toHsEnumCtorName :: CppEnum -> [String] -> String+toHsEnumCtorName enum words =+ concat $ toHsEnumTypeName enum : "_" : map capitalize words++-- | Returns the Haskell name for a bitspace. See 'toHsEnumTypeName'.+toHsBitspaceTypeName :: Bitspace -> String+toHsBitspaceTypeName = toHsTypeName Nonconst . bitspaceExtName++-- | Constructs the data constructor name for a value in a bitspace. See+-- 'toHsEnumCtorName'.+toHsBitspaceValueName :: Bitspace -> [String] -> String+toHsBitspaceValueName bitspace words =+ lowerFirst $ concat $ toHsBitspaceTypeName bitspace : "_" : map capitalize words++-- | Returns the name of the function that will convert a bitspace value into a+-- raw numeric value.+toHsBitspaceToNumName :: Bitspace -> String+toHsBitspaceToNumName = ("from" ++) . toHsBitspaceTypeName++-- | The name of the Haskell typeclass that contains a method for converting to+-- a bitspace value.+toHsBitspaceClassName :: Bitspace -> String+toHsBitspaceClassName bitspace = 'I':'s':toHsBitspaceTypeName bitspace++-- | The name of the method in the 'toHsBitspaceClassName' typeclass that+-- constructs bitspace values.+toHsBitspaceFromValueName :: Bitspace -> String+toHsBitspaceFromValueName = ("to" ++) . toHsBitspaceTypeName++-- | The name for the typeclass of types that can be represented as values of+-- the given C++ class.+toHsValueClassName :: Class -> String+toHsValueClassName cls = toHsDataTypeName Nonconst cls ++ "Value"++-- | The name of the method within the 'toHsValueClassName' typeclass for+-- accessing an object of the type as a pointer.+toHsWithValuePtrName :: Class -> String+toHsWithValuePtrName cls = concat ["with", toHsDataTypeName Nonconst cls, "Ptr"]++-- | The name for the typeclass of types that are (possibly const) pointers to+-- objects of the given C++ class, or subclasses.+toHsPtrClassName :: Constness -> Class -> String+toHsPtrClassName cst cls = toHsDataTypeName cst cls ++ "Ptr"++-- | The name of the function that upcasts pointers to the specific class type+-- and constness.+toHsCastMethodName :: Constness -> Class -> String+toHsCastMethodName cst cls = "to" ++ toHsDataTypeName cst cls++-- | The name of the typeclass that provides a method to downcast to a specific+-- class type. See 'toHsDownCastMethodName'.+toHsDownCastClassName :: Constness -> Class -> String+toHsDownCastClassName cst cls =+ concat [toHsDataTypeName Nonconst cls,+ "Super",+ case cst of+ Const -> "Const"+ Nonconst -> ""]++-- | The name of the function that downcasts pointers to the specific class type+-- and constness.+toHsDownCastMethodName :: Constness -> Class -> String+toHsDownCastMethodName cst cls = "downTo" ++ toHsDataTypeName cst cls++-- | The import name for the foreign function that casts between two specific+-- pointer types. Used for upcasting and downcasting.+toHsCastPrimitiveName :: Class -> Class -> String+toHsCastPrimitiveName from to =+ concat ["cast", toHsDataTypeName Nonconst from, "To", toHsDataTypeName Nonconst to]++-- | The name of one of the functions that add/remove const to/from a class's+-- pointer type. Given 'Const', it will return the function that adds const,+-- and given 'Nonconst', it will return the function that removes const.+toHsConstCastFnName :: Constness -> Class -> String+toHsConstCastFnName cst cls =+ concat ["cast", toHsDataTypeName Nonconst cls,+ case cst of+ Const -> "ToConst"+ Nonconst -> "ToNonconst"]++-- | The name of the data type that represents a pointer to an object of the+-- given class and constness.+toHsDataTypeName :: Constness -> Class -> String+toHsDataTypeName cst cls = toHsTypeName cst $ classExtName cls++-- | The name of the foreign function import wrapping @delete@ for the given+-- class type. This is in internal to the binding; normal users should use+-- 'Foreign.Hoppy.Runtime.delete'.+toHsClassDeleteFnName :: Class -> String+toHsClassDeleteFnName cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName Nonconst cls++-- | Returns the name of the Haskell function that invokes the given method.+--+-- See also 'getClassyExtName'.+toHsMethodName :: Class -> Method -> String+toHsMethodName cls method = toHsMethodName' cls $ fromExtName $ methodExtName method++-- | Returns the name of the Haskell function that invokes a method with a+-- specific name in a class.+toHsMethodName' :: IsFnName String name => Class -> name -> String+toHsMethodName' cls methodName =+ lowerFirst $+ concat [fromExtName $ classExtName cls, "_",+ case toFnName methodName of+ FnName name -> name+ FnOp op -> fromExtName $ operatorPreferredExtName op]++-- | The name of the function that takes a Haskell function and wraps it in a+-- callback object. This is internal to the binding; normal users can pass+-- Haskell functions to be used as callbacks inplicitly.+toHsCallbackCtorName :: Callback -> String+toHsCallbackCtorName = toHsFnName . callbackExtName++-- | Converts an external name into a name suitable for a Haskell function or+-- variable.+toHsFnName :: ExtName -> String+toHsFnName = lowerFirst . fromExtName++-- | Returns a distinct argument variable name for each nonnegative number.+toArgName :: Int -> String+toArgName = ("arg'" ++) . show++-- | The Haskell side of bindings performs conversions between C FFI types and+-- Haskell types. This denotes which side's type is being used.+data HsTypeSide =+ HsCSide -- ^ The C type sent from C++.+ | HsHsSide -- ^ The Haskell-native type.+ deriving (Eq, Show)++-- | Returns the 'HsType' corresponding to a 'Type', and also adds imports to+-- the 'Generator' as necessary for Haskell types that the 'Type' references.+-- On failure, an error is thrown.+cppTypeToHsTypeAndUse :: HsTypeSide -> Type -> Generator HsType+cppTypeToHsTypeAndUse side t =+ withErrorContext (concat ["converting ", show t, " to ", show side, " type"]) $+ case t of+ TVoid -> return $ HsTyCon $ Special HsUnitCon+ -- C++ has sizeof(bool) == 1, whereas Haskell can > 1, so we have to convert.+ TBool -> case side of+ HsCSide -> addImports hsImportForRuntime $> HsTyCon (UnQual $ HsIdent "HoppyFHR.CBool")+ HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Bool")+ TChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CChar")+ TUChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUChar")+ TShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CShort")+ TUShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUShort")+ TInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CInt")+ TUInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUInt")+ TLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLong")+ TULong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULong")+ TLLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLLong")+ TULLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULLong")+ TFloat -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CFloat")+ TDouble -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CDouble")+ TInt8 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int8")+ TInt16 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int16")+ TInt32 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int32")+ TInt64 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int64")+ TWord8 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word8")+ TWord16 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word16")+ TWord32 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word32")+ TWord64 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word64")+ TPtrdiff -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CPtrdiff")+ TSize -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CSize")+ TSSize -> addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize")+ TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of+ HsCSide -> addImports hsImportForForeignC $> "HoppyFC.CInt"+ HsHsSide -> importHsModuleForExtName (enumExtName e) $> toHsEnumTypeName e+ TBitspace b -> case side of+ HsCSide -> cppTypeToHsTypeAndUse side $ bitspaceType b+ HsHsSide -> importHsModuleForExtName (bitspaceExtName b) $>+ HsTyCon (UnQual $ HsIdent $ toHsBitspaceTypeName b)+ TPtr (TObj cls) ->+ importHsModuleForExtName (classExtName cls) $>+ HsTyCon (UnQual $ HsIdent $ toHsTypeName Nonconst $ classExtName cls)+ TPtr (TConst (TObj cls)) ->+ importHsModuleForExtName (classExtName cls) $>+ HsTyCon (UnQual $ HsIdent $ toHsTypeName Const $ classExtName cls)+ TPtr (TFn paramTypes retType) -> do+ paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes+ retHsType <- cppTypeToHsTypeAndUse side retType+ sideFn <- case side of+ HsCSide -> do addImports hsImportForForeign+ return $ HsTyApp $ HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr"+ HsHsSide -> return id+ addImports hsImportForPrelude+ return $ sideFn $+ foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes+ TPtr t' -> do+ addImports hsImportForForeign+ -- Pointers to other types (i.e. primitive number types) point to the raw+ -- C++ value, so we need to use the C-side type of the pointer target+ -- here.+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") <$> cppTypeToHsTypeAndUse HsCSide t'+ TRef t' -> cppTypeToHsTypeAndUse side $ TPtr t'+ TFn paramTypes retType -> do+ paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes+ retHsType <- cppTypeToHsTypeAndUse side retType+ addImports hsImportForPrelude+ return $+ foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes+ TCallback cb -> do+ hsType <- cppTypeToHsTypeAndUse side $ callbackToTFn cb+ case side of+ HsHsSide -> return hsType+ HsCSide -> do+ addImports hsImportForRuntime+ return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsType+ TObj cls -> case side of+ HsCSide -> cppTypeToHsTypeAndUse side $ TPtr $ TConst t+ HsHsSide ->+ case classHaskellConversionType <$> classHaskellConversion (classConversion cls) of+ Nothing ->+ throwError $ concat+ ["Expected a Haskell type for ", show cls, " but there isn't one"]+ Just t' -> t'+ TObjToHeap cls -> cppTypeToHsTypeAndUse side $ TPtr $ TObj cls+ TConst t' -> cppTypeToHsTypeAndUse side t'++-- | Prints a value like 'P.prettyPrint', but removes newlines so that they+-- don't cause problems with this module's textual generation. Should be mainly+-- used for printing types; stripping newlines from definitions for example+-- could go badly.+prettyPrint :: P.Pretty a => a -> String+prettyPrint = filter (/= '\n') . P.prettyPrint
+ src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot view
@@ -0,0 +1,47 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++module Foreign.Hoppy.Generator.Language.Haskell (+ Generator,+ Output,+ prettyPrint,+ ) where++#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (Except)+#endif+import Control.Monad.Reader (ReaderT)+import Control.Monad.Writer (WriterT)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid)+#endif+import qualified Language.Haskell.Pretty as P++#if MIN_VERSION_mtl(2,2,1)+type Generator = ReaderT Env (WriterT Output (Except String))+#else+type Generator = ReaderT Env (WriterT Output (Either String))+#endif++data Env++data Output+instance Monoid Output++prettyPrint :: P.Pretty a => a -> String
+ src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs view
@@ -0,0 +1,1107 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Internal portion of the Haskell code generator.+module Foreign.Hoppy.Generator.Language.Haskell.Internal (+ Generation,+ generate,+ generatedFiles,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), pure)+#endif+import Control.Arrow ((&&&), second)+import Control.Monad (forM, unless, when)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (throwError)+#else+import Control.Monad.Error (throwError)+#endif+import Control.Monad.Trans (lift)+import Control.Monad.Writer (execWriterT, tell)+import Data.Foldable (forM_)+import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp)+import Data.List (intersperse)+import qualified Data.Map as M+import Data.Maybe (catMaybes, isJust, mapMaybe)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat)+#endif+import qualified Data.Set as S+import Foreign.Hoppy.Generator.Common+import Foreign.Hoppy.Generator.Spec+import Foreign.Hoppy.Generator.Language.Cpp (+ classCastFnCppName,+ classDeleteFnCppName,+ externalNameToCpp,+ )+import Foreign.Hoppy.Generator.Language.Haskell+import Language.Haskell.Syntax (+ HsAsst,+ HsContext,+ HsName (HsIdent),+ HsQName (Special, UnQual),+ HsQualType (HsQualType),+ HsSpecialCon (HsUnitCon),+ HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),+ )+import System.FilePath ((<.>), pathSeparator)++-- | The in-memory result of generating Haskell code for an interface.+data Generation = Generation+ { generatedFiles :: M.Map FilePath String+ -- ^ A map from paths of generated files to the contents of those files.+ -- The file paths are relative paths below the Haskell generation root.+ }++-- | Runs the C++ code generator against an interface.+generate :: Interface -> Either ErrorMsg Generation+generate iface = do+ -- Build the partial generation of each module.+ modPartials <- forM (M.elems $ interfaceModules iface) $ \m ->+ (,) m <$> execGenerator iface (getModuleName iface m) (generateSource m)++ -- Compute the strongly connected components. If there is a nontrivial SCC,+ -- then there is a module import cycle that we'll have to break with hs-boot+ -- files.+ let partialsByHsName :: M.Map HsModuleName Partial+ partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials++ sccInput :: [((Module, Partial), Partial, [Partial])]+ sccInput = flip map modPartials $ \x@(_, p) ->+ (x, p,+ mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $+ M.keys $ getHsImportSet $ outputImports $ partialOutput p)++ sccs :: [SCC (Module, Partial)]+ sccs = stronglyConnComp sccInput++ fileContents <- execWriterT $ forM_ sccs $ \scc -> case scc of+ AcyclicSCC (_, p) -> tell [finishPartial p "hs"]+ CyclicSCC mps -> do+ let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps+ forM_ mps $ \(m, p) -> do+ -- Create a boot partial.+ pBoot <- lift $ execGenerator iface (partialModuleHsName p) (generateBootSource m)++ -- Change the source and boot partials so that all imports of modules in+ -- this cycle are {-# SOURCE #-} imports.+ let p' = setSourceImports cycleModNames p+ pBoot' = setSourceImports cycleModNames pBoot++ -- Emit the completed partials.+ tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"]++ return $ Generation $ M.fromList fileContents++ where finishPartial :: Partial -> String -> (FilePath, String)+ finishPartial p fileExt =+ (listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt,+ prependExtensions $ renderPartial p)++ setSourceImports :: S.Set HsModuleName -> Partial -> Partial+ setSourceImports modulesToSourceImport p =+ let output = partialOutput p+ imports = outputImports output+ imports' = makeHsImportSet $+ M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $+ getHsImportSet imports+ output' = output { outputImports = imports' }+ in p { partialOutput = output' }++ setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs+ setSourceImportIfIn modulesToSourceImport key specs =+ if hsImportModule key `S.member` modulesToSourceImport+ then specs { hsImportSource = True }+ else specs++prependExtensions :: String -> String+prependExtensions = (prependExtensionsPrefix ++)++prependExtensionsPrefix :: String+prependExtensionsPrefix =+ -- MultiParamTypeClasses is necessary for instances of Decodable and+ -- Encodable. FlexibleContexts is needed for the type signature of the+ -- function that wraps the actual callback function in callback creation+ -- functions.+ --+ -- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions+ -- to and from String, which is really [Char].+ --+ -- UndecidableInstances is needed for instances of the form "SomeClassConstPtr+ -- a => SomeClassValue a", and overlapping instances are used for the overlap+ -- between these instances and instances of SomeClassValue for the class's+ -- native Haskell type, when it's convertible. CPP is used for warning-free+ -- compatibility using overlapping instances with both GHC 7.8 and 7.10.+ --+ -- GeneralizedNewtypeDeriving is to enable automatic deriving of+ -- Data.Bits.Bits instances for bitspace newtypes and Storable instances for+ -- object pointer newtypes.+ concat+ [ "{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving"+ , ", MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances #-}\n"+ , "#if !MIN_VERSION_base(4,8,0)\n"+ , "{-# LANGUAGE OverlappingInstances #-}\n"+ , "#endif\n\n"+ ]++generateSource :: Module -> Generator ()+generateSource m = do+ forM_ (moduleExports m) $ sayExport SayExportForeignImports+ forM_ (moduleExports m) $ sayExport SayExportDecls++generateBootSource :: Module -> Generator ()+generateBootSource m =+ forM_ (moduleExports m) $ sayExport SayExportBoot++data SayExportMode = SayExportForeignImports | SayExportDecls | SayExportBoot+ deriving (Eq, Show)++sayExport :: SayExportMode -> Export -> Generator ()+sayExport mode export = do+ case export of+ ExportVariable v -> sayExportVar mode v+ ExportEnum enum -> sayExportEnum mode enum+ ExportBitspace bitspace -> sayExportBitspace mode bitspace+ ExportFn fn ->+ (sayExportFn mode <$> fnExtName <*> pure Nothing <*> fnPurity <*> fnParams <*> fnReturn) fn+ ExportClass cls -> sayExportClass mode cls+ ExportCallback cb -> sayExportCallback mode cb++ when (mode == SayExportDecls) $+ addendumHaskell $ exportAddendum export++sayExportVar :: SayExportMode -> Variable -> Generator ()+sayExportVar mode v = do+ withErrorContext ("generating variable " ++ show (varExtName v)) $ do+ let (isConst, deconstType) = case varType v of+ TConst t -> (True, t)+ t -> (False, t)+ sayExportFn mode (varGetterExtName v) Nothing Nonpure [] deconstType+ unless isConst $+ sayExportFn mode (varSetterExtName v) Nothing Nonpure [deconstType] TVoid++sayExportEnum :: SayExportMode -> CppEnum -> Generator ()+sayExportEnum mode enum =+ withErrorContext ("generating enum " ++ show (enumExtName enum)) $+ case mode of+ -- Nothing to import from the C++ side of an enum.+ SayExportForeignImports -> return ()++ SayExportDecls -> do+ let hsTypeName = toHsEnumTypeName enum+ values :: [(Int, String)]+ values = map (second $ toHsEnumCtorName enum) $ enumValueNames enum+ addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude]++ -- Print out the data declaration.+ ln+ addExport' hsTypeName+ saysLn ["data ", hsTypeName, " ="]+ indent $ do+ forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) ->+ saysLn [if cont then "| " else "", hsCtorName]+ sayLn "deriving (HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"++ -- Print out the Enum instance.+ ln+ saysLn ["instance HoppyP.Enum ", hsTypeName, " where"]+ indent $ do+ forM_ values $ \(num, hsCtorName) ->+ saysLn ["fromEnum ", hsCtorName, " = ", show num]+ ln+ forM_ values $ \(num, hsCtorName) ->+ saysLn ["toEnum (", show num, ") = ", hsCtorName]+ -- TODO Fix the potential name collision of 'n'.+ saysLn ["toEnum n = HoppyP.error $ ",+ show (concat ["Unknown ", hsTypeName, " numeric value: "]),+ " ++ HoppyP.show n"]++ SayExportBoot -> do+ let hsTypeName = toHsEnumTypeName enum+ addImports hsImportForPrelude+ addExport hsTypeName+ ln+ saysLn ["data ", hsTypeName]+ saysLn ["instance HoppyP.Bounded ", hsTypeName]+ saysLn ["instance HoppyP.Enum ", hsTypeName]+ saysLn ["instance HoppyP.Eq ", hsTypeName]+ saysLn ["instance HoppyP.Ord ", hsTypeName]+ saysLn ["instance HoppyP.Show ", hsTypeName]++sayExportBitspace :: SayExportMode -> Bitspace -> Generator ()+sayExportBitspace mode bitspace =+ withErrorContext ("generating bitspace " ++ show (bitspaceExtName bitspace)) $+ let hsTypeName = toHsBitspaceTypeName bitspace+ fromFnName = toHsBitspaceToNumName bitspace+ className = toHsBitspaceClassName bitspace+ toFnName = toHsBitspaceFromValueName bitspace+ hsType = HsTyCon $ UnQual $ HsIdent hsTypeName+ in case mode of+ -- Nothing to import from the C++ side of a bitspace.+ SayExportForeignImports -> return ()++ SayExportDecls -> do+ let values :: [(Int, String)]+ values = map (second $ toHsBitspaceValueName bitspace) $ bitspaceValueNames bitspace++ hsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace++ -- Print out the data declaration and conversion functions.+ addImports $ mconcat [hsImportForBits, hsImportForPrelude]+ addExport' hsTypeName+ addExport' className+ ln+ saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",+ fromFnName, " :: ", prettyPrint hsNumType, " }"]+ indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"+ ln+ saysLn ["class ", className, " a where"]+ indent $ do+ let tyVar = HsTyVar $ HsIdent "a"+ saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]+ ln+ saysLn ["instance ", className, " (", prettyPrint hsNumType, ") where"]+ indent $ saysLn [toFnName, " = ", hsTypeName]++ -- If the bitspace has an associated enum, then print out a conversion+ -- instance for it as well.+ forM_ (bitspaceEnum bitspace) $ \enum -> do+ let enumTypeName = toHsEnumTypeName enum+ importHsModuleForExtName $ enumExtName enum+ addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]+ ln+ saysLn ["instance ", className, " ", enumTypeName, " where"]+ indent $+ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"]++ -- Print out the constants.+ ln+ forM_ values $ \(num, valueName) -> do+ addExport valueName+ saysLn [valueName, " = ", hsTypeName, " ", show num]++ SayExportBoot -> do+ hsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace++ addImports $ mconcat [hsImportForBits, hsImportForPrelude]+ addExport' hsTypeName+ addExport' className+ ln+ saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",+ fromFnName, " :: ", prettyPrint hsNumType, " }"]+ ln+ saysLn ["instance HoppyDB.Bits ", hsTypeName]+ saysLn ["instance HoppyP.Bounded ", hsTypeName]+ saysLn ["instance HoppyP.Eq ", hsTypeName]+ saysLn ["instance HoppyP.Ord ", hsTypeName]+ saysLn ["instance HoppyP.Show ", hsTypeName]+ ln+ saysLn ["class ", className, " a where"]+ indent $ do+ let tyVar = HsTyVar $ HsIdent "a"+ saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]+ ln+ saysLn ["instance ", className, " (", prettyPrint hsNumType, ")"]+ forM_ (bitspaceEnum bitspace) $ \enum -> do+ let enumTypeName = toHsEnumTypeName enum+ importHsModuleForExtName $ enumExtName enum+ saysLn ["instance ", className, " ", enumTypeName]++sayExportFn :: SayExportMode+ -> ExtName+ -> Maybe (Constness, Class)+ -> Purity+ -> [Type]+ -> Type+ -> Generator ()+sayExportFn mode name methodInfo purity paramTypes retType =+ let hsFnName = toHsFnName name+ hsFnImportedName = hsFnName ++ "'"+ in case mode of+ SayExportForeignImports ->+ withErrorContext ("generating imports for function " ++ show name) $ do+ -- Print a "foreign import" statement.+ hsCType <- fnToHsTypeAndUse HsCSide methodInfo purity paramTypes retType+ saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ", hsFnImportedName, " :: ",+ prettyPrint hsCType]++ SayExportDecls -> withErrorContext ("generating function " ++ show name) $ do+ -- Print the type signature.+ ln+ addExport hsFnName+ hsHsType <- fnToHsTypeAndUse HsHsSide methodInfo purity paramTypes retType+ saysLn [hsFnName, " :: ", prettyPrint hsHsType]++ case purity of+ Nonpure -> return ()+ Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"]++ -- Print the function body.+ let argNames = map toArgName [1..length paramTypes]+ argNamesWithThis = (if isJust methodInfo then ("this":) else id) argNames+ convertedArgNames = map (++ "'") argNames+ -- Operators on this line must bind more weakly than operators used below,+ -- namely ($) and (>>=). (So finish the line with ($).)+ lineEnd <- case purity of+ Nonpure -> return [" ="]+ Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]+ return [" = HoppySIU.unsafePerformIO $"]+ saysLn $ hsFnName : map (' ':) argNamesWithThis ++ lineEnd+ indent $ do+ forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') ->+ sayArgProcessing ToCpp t argName argName'++ sayCallAndProcessReturn ToCpp retType $+ hsFnImportedName :+ (case methodInfo of+ Just (cst, cls) -> " (" ++ toHsCastMethodName cst cls ++ " this)"+ Nothing -> "") :+ map (' ':) convertedArgNames++ SayExportBoot ->+ -- Functions (methods included) cannot be referenced from other exports,+ -- so we don't need to emit anything.+ return ()++-- | Prints \"foreign import\" statements and an internal callback construction+-- function for a given 'Callback' specification. For example, for a callback+-- of 'HsHsSide' type @Int -> String -> IO Int@, we will generate the following+-- bindings:+--+-- > foreign import ccall "wrapper" name'newFunPtr+-- > :: (CInt -> TPtr TChar -> IO CInt)+-- > -> IO (FunPtr (CInt -> TPtr TChar -> IO CInt))+-- >+-- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.)+-- > foreign import ccall "genpop__name_impl" name'newCallback+-- > :: FunPtr (CInt -> TPtr TChar -> IO CInt)+-- > -> FunPtr (FunPtr (IO ()) -> IO ())+-- > -> Bool+-- > -> IO (CCallback (CInt -> TPtr TChar -> IO CInt))+-- >+-- > name :: (CInt -> String -> IO CInt) -> IO (CCallback (CInt -> TPtr TChar -> IO CInt))+-- > name f = do+-- > let cf arg1' arg2' = do+-- > arg1 <- return arg1'+-- > arg2 <- ...decode the string...+-- > f arg1 arg2 >>= return+-- > cfp <- name'newFunPtr cf+-- > name'newCallback cfp freeHaskellFunPtrFunPtr False+--+-- Only the implementation of bindings that take a callback of this type will+-- make use of this @name@ binding; @name@ is not useful to users of bindings.+sayExportCallback :: SayExportMode -> Callback -> Generator ()+sayExportCallback mode cb =+ withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do+ let name = callbackExtName cb+ paramTypes = callbackParams cb+ retType = callbackReturn cb+ fnType = callbackToTFn cb+ hsFnName = toHsCallbackCtorName cb+ hsFnName'newCallback = hsFnName ++ "'newCallback"+ hsFnName'newFunPtr = hsFnName ++ "'newFunPtr"++ hsFnCType <- cppTypeToHsTypeAndUse HsCSide fnType+ hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide fnType++ let getWholeFnType = do+ addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+ return $+ HsTyFun hsFnHsType $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType++ case mode of+ SayExportForeignImports -> do+ addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]+ let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType+ hsFunPtrImportType =+ HsTyFun hsFnCType $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType+ hsCallbackCtorImportType =+ HsTyFun hsFunPtrType $+ HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $+ HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+ HsTyCon $ Special HsUnitCon) $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+ HsTyCon $ Special HsUnitCon) $+ HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType++ saysLn ["foreign import ccall \"wrapper\" ", hsFnName'newFunPtr, " :: ",+ prettyPrint hsFunPtrImportType]+ saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ",+ hsFnName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType]++ SayExportDecls -> do+ addExport hsFnName+ wholeFnType <- getWholeFnType+ let paramCount = length paramTypes+ argNames = map toArgName [1..paramCount]+ argNames' = map (++ "'") argNames+ ln+ saysLn [hsFnName, " :: ", prettyPrint wholeFnType]+ saysLn [hsFnName, " f'hs = do"]+ indent $ do+ sayLet+ [do saysLn ["f'c ", unwords argNames, " ="]+ indent $ do+ forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') ->+ sayArgProcessing FromCpp t argName argName'+ sayCallAndProcessReturn FromCpp retType $+ "f'hs" : map (' ':) argNames']+ Nothing+ saysLn ["f'p <- ", hsFnName'newFunPtr, " f'c"]+ saysLn [hsFnName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]++ SayExportBoot -> do+ addExport hsFnName+ wholeFnType <- getWholeFnType+ ln+ saysLn [hsFnName, " :: ", prettyPrint wholeFnType]++data CallDirection =+ ToCpp -- ^ Haskell code is calling out to C++.+ | FromCpp -- ^ C++ is invoking a callback.++sayArgProcessing :: CallDirection -> Type -> String -> String -> Generator ()+sayArgProcessing dir t fromVar toVar =+ withErrorContext ("processing argument of type " ++ show t) $+ case t of+ TVoid -> throwError $ "TVoid is not a valid argument type"+ TBool -> case dir of+ ToCpp -> saysLn ["let ", toVar, " = if ", fromVar, " then 1 else 0 in"]+ FromCpp -> do addImports $ hsImport1 "Prelude" "(/=)"+ saysLn ["let ", toVar, " = ", fromVar, " /= 0 in"]+ TChar -> noConversion+ TUChar -> noConversion+ TShort -> noConversion+ TUShort -> noConversion+ TInt -> noConversion+ TUInt -> noConversion+ TLong -> noConversion+ TULong -> noConversion+ TLLong -> noConversion+ TULLong -> noConversion+ TFloat -> noConversion+ TDouble -> noConversion+ TInt8 -> noConversion+ TInt16 -> noConversion+ TInt32 -> noConversion+ TInt64 -> noConversion+ TWord8 -> noConversion+ TWord16 -> noConversion+ TWord32 -> noConversion+ TWord64 -> noConversion+ TPtrdiff -> noConversion+ TSize -> noConversion+ TSSize -> noConversion+ TEnum _ -> do+ addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForPrelude, hsImportForRuntime]+ saysLn ["let ", toVar,+ -- TODO The coersion here is unnecssary if we replace the C numeric+ -- types with their Haskell ones across the board (e.g. CInt ->+ -- Int).+ case dir of+ ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum "+ FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ",+ fromVar, " in"]+ TBitspace b -> do+ importHsModuleForExtName $ bitspaceExtName b+ saysLn ["let ", toVar, " = ", bitspaceConvFn dir b, " ", fromVar, " in"]+ -- References and pointers are handled equivalently.+ TPtr (TObj cls) -> do+ addImportForClass cls+ saysLn $ case dir of+ ToCpp -> ["let ", toVar, " = ", toHsCastMethodName Nonconst cls, " ", fromVar, " in"]+ FromCpp -> ["let ", toVar, " = ", fromVar, " in"]+ TPtr (TConst (TObj cls)) -> case dir of+ ToCpp -> do+ addImports $ mconcat [hsImport1 "Prelude" "($)"]+ addImportForClass cls+ saysLn [toHsWithValuePtrName cls, " ", fromVar, " $ \\", toVar, " ->"]+ FromCpp ->+ saysLn ["let ", toVar, " = ", fromVar, " in"]+ TPtr _ -> noConversion+ TRef t' -> sayArgProcessing dir (TPtr t') fromVar toVar+ TFn {} -> throwError "TFn unimplemented"+ TCallback cb -> case dir of+ ToCpp -> do+ addImports $ hsImport1 "Prelude" "(>>=)"+ importHsModuleForExtName $ callbackExtName cb+ saysLn [toHsCallbackCtorName cb, " ", fromVar, " >>= \\", toVar, " ->"]+ FromCpp -> throwError "Can't receive a callback from C++"+ TObj cls -> case dir of+ ToCpp -> do+ addImports $ mconcat [hsImport1 "Prelude" "($)"]+ addImportForClass cls+ saysLn [toHsWithValuePtrName cls, " ", fromVar, " $ \\", toVar, " ->"]+ FromCpp -> do+ addImports $ mconcat [hsImport1 "Prelude" "(>>=)", hsImportForRuntime]+ saysLn ["HoppyFHR.decode ", fromVar, " >>= \\", toVar, " ->"]+ TObjToHeap cls -> case dir of+ ToCpp -> throwError $ tObjToHeapWrongDirectionErrorMsg Nothing cls+ FromCpp -> noConversion+ TConst t' -> sayArgProcessing dir t' fromVar toVar+ where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"]+ bitspaceConvFn dir = case dir of+ ToCpp -> toHsBitspaceToNumName+ FromCpp -> toHsBitspaceFromValueName++-- | Note that the 'CallDirection' is the direction of the call, not the+-- direction of the return. 'ToCpp' means we're returning to the foreign+-- language, 'FromCpp' means we're returning from it.+sayCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator ()+sayCallAndProcessReturn dir t callWords =+ withErrorContext ("processing return value of type " ++ show t) $+ case t of+ TVoid -> sayCall+ TBool -> do+ case dir of+ ToCpp -> do addImports $ mconcat [hsImport1 "Prelude" "(/=)", hsImportForPrelude]+ sayLn "HoppyP.fmap (/= 0)"+ FromCpp -> sayLn "HoppyP.fmap (\\x -> if x then 1 else 0)"+ sayCall+ TChar -> sayCall+ TUChar -> sayCall+ TShort -> sayCall+ TUShort -> sayCall+ TInt -> sayCall+ TUInt -> sayCall+ TLong -> sayCall+ TULong -> sayCall+ TLLong -> sayCall+ TULLong -> sayCall+ TFloat -> sayCall+ TDouble -> sayCall+ TInt8 -> sayCall+ TInt16 -> sayCall+ TInt32 -> sayCall+ TInt64 -> sayCall+ TWord8 -> sayCall+ TWord16 -> sayCall+ TWord32 -> sayCall+ TWord64 -> sayCall+ TPtrdiff -> sayCall+ TSize -> sayCall+ TSSize -> sayCall+ TEnum _ -> do+ addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]+ case dir of+ -- TODO The coersion here is unnecssary if we replace the C numeric types+ -- with their Haskell ones across the board (e.g. CInt -> Int).+ ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"]+ FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"]+ sayCall+ TBitspace b -> do+ addImports hsImportForPrelude+ importHsModuleForExtName $ bitspaceExtName b+ saysLn ["HoppyP.fmap ", bitspaceConvFn dir b]+ sayCall+ TPtr _ -> sayCall+ TRef _ -> sayCall+ TFn {} -> throwError "TFn unimplemented"+ TCallback cb -> case dir of+ ToCpp -> throwError "Can't receive a callback from C++"+ FromCpp -> do+ addImports $ hsImport1 "Prelude" "(=<<)"+ importHsModuleForExtName $ callbackExtName cb+ saysLn [toHsCallbackCtorName cb, "=<<"]+ sayCall+ TObj _ -> do+ addImports $ mconcat [hsImport1 "Prelude" "(=<<)", hsImportForRuntime]+ case dir of+ ToCpp -> sayLn "HoppyFHR.decodeAndDelete =<<"+ FromCpp -> sayLn "HoppyFHR.encode =<<"+ sayCall+ TObjToHeap cls -> case dir of+ ToCpp -> sayCall+ FromCpp -> throwError $ tObjToHeapWrongDirectionErrorMsg Nothing cls+ TConst t' -> sayCallAndProcessReturn dir t' callWords+ where sayCall = saysLn $ "(" : callWords ++ [")"]+ bitspaceConvFn dir = case dir of+ ToCpp -> toHsBitspaceFromValueName+ FromCpp -> toHsBitspaceToNumName++sayExportClass :: SayExportMode -> Class -> Generator ()+sayExportClass mode cls = do+ case mode of+ SayExportForeignImports -> do+ sayExportClassHsCtors mode cls++ forM_ (classMethods cls) $ \method ->+ (sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>+ pure (getMethodEffectiveParams cls method) <*> methodReturn) method++ SayExportDecls -> do+ sayExportClassHsClass True cls Const+ sayExportClassHsClass True cls Nonconst++ sayExportClassHsStaticMethods cls++ -- Create a newtype for referencing foreign objects with pointers. The+ -- newtype is not used with encodings of value objects.+ sayExportClassHsType True cls Const+ sayExportClassHsType True cls Nonconst++ sayExportClassHsCtors mode cls++ SayExportBoot -> do+ sayExportClassHsClass False cls Const+ sayExportClassHsClass False cls Nonconst++ sayExportClassHsType False cls Const+ sayExportClassHsType False cls Nonconst++ sayExportClassCastPrimitives mode cls+ sayExportClassHsSpecialFns mode cls++sayExportClassHsClass :: Bool -> Class -> Constness -> Generator ()+sayExportClassHsClass doDecls cls cst = do+ let hsTypeName = toHsDataTypeName cst cls+ hsValueClassName = toHsValueClassName cls+ hsWithValuePtrName = toHsWithValuePtrName cls+ hsPtrClassName = toHsPtrClassName cst cls+ hsCastMethodName = toHsCastMethodName cst cls+ supers = classSuperclasses cls++ forM_ supers $ importHsModuleForExtName . classExtName+ hsSupers <-+ (\x -> if null x+ then do addImports hsImportForRuntime+ return ["HoppyFHR.CppPtr"]+ else return x) $+ case cst of+ Const -> map (toHsPtrClassName Const) supers+ Nonconst -> toHsPtrClassName Const cls : map (toHsPtrClassName Nonconst) supers++ -- Print the value class definition. There is only one of these, and it is+ -- spiritually closer to the const version of the pointers for this class, so+ -- we emit for the const case only.+ when (cst == Const) $ do+ addImports hsImportForPrelude+ addExport' hsValueClassName+ ln+ saysLn ["class ", hsValueClassName, " a where"]+ indent $+ saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"]++ -- Generate instances for all pointer subtypes.+ ln+ saysLn ["#if MIN_VERSION_base(4,8,0)"]+ saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",+ if doDecls then " where" else ""]+ saysLn ["#else"]+ saysLn ["instance ", hsPtrClassName, " a => ", hsValueClassName, " a",+ if doDecls then " where" else ""]+ saysLn ["#endif"]+ when doDecls $ do+ addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],+ hsImportForPrelude]+ indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]++ -- When the class has a native Haskell type, also print an instance for it.+ forM_ (classHaskellConversion $ classConversion cls) $ \conv -> do+ hsType <- classHaskellConversionType conv+ ln+ saysLn ["#if MIN_VERSION_base(4,8,0)"]+ saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",+ if doDecls then " where" else ""]+ saysLn ["#else"]+ saysLn ["instance ", hsValueClassName, " (", prettyPrint hsType, ")",+ if doDecls then " where" else ""]+ saysLn ["#endif"]+ when doDecls $ do+ addImports hsImportForRuntime+ indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]++ -- Print the pointer class definition.+ addExport' hsPtrClassName+ ln+ saysLn $+ "class (" :+ intersperse ", " (map (++ " this") hsSupers) +++ [") => ", hsPtrClassName, " this where"]+ indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName]++ -- Print the non-static methods.+ when doDecls $ do+ let methods = filter ((cst ==) . methodConst) $ classMethods cls+ forM_ methods $ \method ->+ when (methodStatic method == Nonstatic) $+ (sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*>+ methodPurity <*> pure (getMethodEffectiveParams cls method) <*>+ methodReturn) method++sayExportClassHsStaticMethods :: Class -> Generator ()+sayExportClassHsStaticMethods cls =+ forM_ (classMethods cls) $ \method ->+ when (methodStatic method == Static) $+ (sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>+ methodParams <*> methodReturn) method++sayExportClassHsType :: Bool -> Class -> Constness -> Generator ()+sayExportClassHsType doDecls cls cst = do+ addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]+ -- Unfortunately, we must export the data constructor, so that GHC can marshal+ -- it in foreign calls in other modules.+ addExport' hsTypeName+ ln+ saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " (HoppyF.Ptr ", hsTypeName, ")"]+ if doDecls+ then indent $ sayLn "deriving (HoppyP.Eq, HoppyP.Ord, HoppyP.Show, HoppyF.Storable)"+ else saysLn ["instance HoppyF.Storable ", hsTypeName]++ -- Generate const_cast functions:+ -- castFooToConst :: Foo -> FooConst+ -- castFooToNonconst :: FooConst -> Foo+ ln+ let constCastFnName = toHsConstCastFnName cst cls+ addExport constCastFnName+ saysLn [constCastFnName, " :: ", toHsDataTypeName (constNegate cst) cls, " -> ", hsTypeName]+ when doDecls $ do+ addImports $ hsImport1 "Prelude" "(.)"+ saysLn [constCastFnName, " = ", hsTypeName, " . HoppyF.castPtr . HoppyFHR.toPtr"]++ -- Generate an instance of CppPtr.+ ln+ if doDecls+ then do addImports hsImportForForeign+ saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]+ indent $ do+ saysLn ["nullptr = ", toHsDataTypeName cst cls, " HoppyF.nullPtr"]+ saysLn ["toPtr (", hsTypeName, " ptr) = ptr"]+ when (classDtorIsPublic cls) $ do+ ln+ deleteTail <- case cst of+ Const -> return []+ Nonconst -> do addImports $ hsImport1 "Prelude" "(.)"+ return [" . ", toHsCastMethodName Const cls]+ saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"]+ indent $ saysLn $ "delete = " : toHsClassDeleteFnName cls : deleteTail+ else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName]+ saysLn ["instance HoppyFHR.Deletable ", hsTypeName]++ -- Generate instances for all superclasses' typeclasses.+ genInstances [] cls++ where hsTypeName :: String+ hsTypeName = toHsDataTypeName cst cls++ genInstances :: [Class] -> Class -> Generator ()+ genInstances path ancestorCls = do+ let path' = ancestorCls : path++ -- Unconditionally generate an instance of the const typeclass.+ when (null path) $ addImports $ hsImportForPrelude+ addImportForClass ancestorCls+ -- Use the fact that we've imported all of the classes from cls to+ -- ancestorCls.+ saysLn ["instance ", toHsPtrClassName Const ancestorCls, " ", hsTypeName,+ if doDecls then " where" else ""]+ when doDecls $ indent $ do+ let convertToConst = cst == Nonconst+ castToSelf = null path+ fns <- (\x -> if null x+ then do addImports $ hsImportForPrelude+ return ["HoppyP.id"]+ else return x) $+ catMaybes+ [ if castToSelf then Nothing else Just $ toHsCastPrimitiveName cls ancestorCls+ , if convertToConst then Just $ toHsConstCastFnName Const cls else Nothing+ ]+ case fns of+ _:_:_ -> addImports $ hsImport1 "Prelude" "(.)"+ _ -> return ()+ saysLn $ toHsCastMethodName Const ancestorCls : " = " :+ intersperse " . " fns++ -- Generate an instance of the nonconst typeclass if we're working on+ -- a nonconst pointer type.+ when (cst == Nonconst) $ do+ saysLn ["instance ", toHsPtrClassName Nonconst ancestorCls, " ", hsTypeName,+ if doDecls then " where" else ""]+ let name = toHsCastMethodName Nonconst ancestorCls+ when doDecls $ indent $+ if null path+ then do addImports hsImportForPrelude+ saysLn [name, " = HoppyP.id"]+ else do addImports $ hsImport1 "Prelude" "(.)"+ saysLn [name, " = ",+ toHsConstCastFnName Nonconst ancestorCls, " . ",+ toHsCastPrimitiveName cls ancestorCls, " . ",+ toHsConstCastFnName Const cls]++ forM_ (classSuperclasses ancestorCls) $ genInstances path'++sayExportClassHsCtors :: SayExportMode -> Class -> Generator ()+sayExportClassHsCtors mode cls =+ forM_ (classCtors cls) $ \ctor ->+ (sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*>+ pure Nonpure <*> ctorParams <*> pure (TPtr $ TObj cls)) ctor++sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator ()+sayExportClassHsSpecialFns mode cls = do+ let typeName = toHsDataTypeName Nonconst cls+ typeNameConst = toHsDataTypeName Const cls++ -- Say the delete function.+ case mode of+ SayExportForeignImports -> when (classDtorIsPublic cls) $ do+ addImports hsImportForPrelude+ saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ",+ toHsClassDeleteFnName cls, " :: ", toHsDataTypeName Const cls,+ " -> HoppyP.IO ()"]+ -- The user interface to this is the generic 'delete' function, rendered+ -- elsewhere.+ SayExportDecls -> return ()+ SayExportBoot -> return ()++ -- If the class has an assignment operator that takes its own type, then+ -- generate an instance of Assignable.+ let assignmentMethods = flip filter (classMethods cls) $ \m ->+ methodApplicability m == MNormal &&+ (methodParams m == [TObj cls] || methodParams m == [TRef $ TConst $ TObj cls]) &&+ (case methodImpl m of+ RealMethod name -> name == FnOp OpAssign+ FnMethod name -> name == FnOp OpAssign)+ withAssignmentMethod f = case assignmentMethods of+ [] -> return ()+ [m] -> f m+ _ ->+ throwError $ concat+ ["Can't determine an Assignable instance to generator for ", show cls,+ " because it has multiple assignment operators ", show assignmentMethods]+ when (mode == SayExportDecls) $ withAssignmentMethod $ \m -> do+ addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude]+ ln+ saysLn ["instance ", toHsValueClassName cls, " a => HoppyFHR.Assignable ", typeName,+ " a where"]+ indent $+ saysLn ["assign x' y' = ", toHsFnName $ getClassyExtName cls m,+ " x' y' >> HoppyP.return ()"]++ -- A pointer to an object pointer is decodable to an object pointer by peeking+ -- at the value, so generate a Decodable instance. You are now a two-star+ -- programmer. There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which+ -- handles deeper levels.+ case mode of+ SayExportForeignImports -> return ()++ SayExportDecls -> do+ addImports $ mconcat [hsImportForForeign, hsImportForRuntime]+ ln+ saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr ", typeName, ") ", typeName, " where"]+ indent $ sayLn "decode = HoppyF.peek"++ SayExportBoot -> do+ addImports $ mconcat [hsImportForForeign, hsImportForRuntime]+ ln+ -- TODO Encodable.+ saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr ", typeName, ") ", typeName]++ -- Say Encodable and Decodable instances, if the class is encodable and+ -- decodable.+ forM_ (classHaskellConversion $ classConversion cls) $ \conv -> do+ hsType <- classHaskellConversionType conv+ let hsTypeStr = concat ["(", prettyPrint hsType, ")"]+ case mode of+ SayExportForeignImports -> return ()++ SayExportDecls -> do+ addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]++ -- Say the Encodable instances.+ ln+ saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]+ indent $ do+ sayLn "encode ="+ indent $ classHaskellConversionToCppFn conv+ ln+ saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]+ indent $+ saysLn ["encode = HoppyP.fmap (", toHsCastMethodName Const cls,+ ") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]++ -- Say the Decodable instances.+ ln+ saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]+ indent $+ saysLn ["decode = HoppyFHR.decode . ", toHsCastMethodName Const cls]+ ln+ saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]+ indent $ do+ sayLn "decode ="+ indent $ classHaskellConversionFromCppFn conv++ SayExportBoot -> do+ addImports hsImportForRuntime+ ln+ saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]+ saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]+ saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]+ saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]++sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()+sayExportClassCastPrimitives mode cls = do+ let clsType = toHsDataTypeName Const cls+ case mode of+ SayExportForeignImports ->+ forAncestors cls $ \super -> do+ let hsCastFnName = toHsCastPrimitiveName cls super+ hsDownCastFnName = toHsCastPrimitiveName super cls+ superType = toHsDataTypeName Const super+ addExport hsCastFnName+ saysLn [ "foreign import ccall \"", classCastFnCppName cls super+ , "\" ", hsCastFnName, " :: ", clsType, " -> ", superType+ ]+ unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do+ addExport hsDownCastFnName+ saysLn [ "foreign import ccall \"", classCastFnCppName super cls+ , "\" ", hsDownCastFnName, " :: ", superType, " -> ", clsType+ ]+ return True++ SayExportDecls ->+ -- Generate a downcast typeclass and instances for all ancestor classes+ -- for the current constness. These don't need to be in the boot file,+ -- since they're not used by other generated bindings.+ unless (classIsSubclassOfMonomorphic cls) $+ forM_ [minBound..] $ \cst -> do+ let downCastClassName = toHsDownCastClassName cst cls+ downCastMethodName = toHsDownCastMethodName cst cls+ addExport' downCastClassName+ ln+ saysLn ["class ", downCastClassName, " a where"]+ indent $ saysLn [downCastMethodName, " :: ",+ prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $+ HsTyCon $ UnQual $ HsIdent $ toHsDataTypeName cst cls]+ ln+ forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of+ True -> return False+ False -> do+ let superTypeName = toHsDataTypeName cst super+ primitiveCastFn = toHsCastPrimitiveName super cls+ saysLn ["instance ", downCastClassName, " ", superTypeName, " where"]+ -- If Foo is a superclass of Bar:+ --+ -- instance BarSuper Foo where+ -- downToBar = castFooToNonconst . castFooToBar . castFooToConst+ --+ -- instance BarSuperConst FooConst where+ -- downToBarConst = constFooToBar+ indent $ saysLn $+ downCastMethodName : " = " :+ case cst of+ Const -> [primitiveCastFn]+ Nonconst -> [toHsConstCastFnName Nonconst cls, " . ",+ primitiveCastFn, " . ",+ toHsConstCastFnName Const super]+ return True++ SayExportBoot -> do+ forAncestors cls $ \super -> do+ let hsCastFnName = toHsCastPrimitiveName cls super+ superType = toHsDataTypeName Const super+ addExport hsCastFnName+ saysLn [hsCastFnName, " :: ", clsType, " -> ", superType]+ return True++ where forAncestors :: Class -> (Class -> Generator Bool) -> Generator ()+ forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do+ recur <- f super+ when recur $ forAncestors super f++fnToHsTypeAndUse :: HsTypeSide+ -> Maybe (Constness, Class)+ -> Purity+ -> [Type]+ -> Type+ -> Generator HsQualType+fnToHsTypeAndUse side methodInfo purity paramTypes returnType = do+ params <- mapM contextForParam $+ (case methodInfo of+ Just (cst, cls) -> [("this", case cst of+ Nonconst -> TPtr $ TObj cls+ Const -> TPtr $ TConst $ TObj cls)]+ Nothing -> []) +++ zip (map toArgName [1..]) paramTypes+ let context = mapMaybe fst params :: HsContext+ hsParams = map snd params+ hsReturn <- cppTypeToHsTypeAndUse side returnType+ hsReturnForPurity <- case (purity, side) of+ (Pure, HsHsSide) -> return hsReturn+ _ -> do+ addImports hsImportForPrelude+ return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturn+ return $ HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams++ where contextForParam :: (String, Type) -> Generator (Maybe HsAsst, HsType)+ contextForParam (s, t) = case t of+ TPtr (TObj cls) -> receivePtr s cls Nonconst+ TPtr (TConst (TObj cls)) -> receiveValue s t cls+ TRef (TObj cls) -> receivePtr s cls Nonconst+ TRef (TConst (TObj cls)) -> receiveValue s t cls+ TObj cls -> receiveValue s t cls+ TConst t' -> contextForParam (s, t')+ _ -> handoff side t++ -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass+ -- constraints.+ handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType)+ handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t++ -- Receive a @FooPtr this => this@.+ receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType)+ receivePtr s cls cst = do+ addImportForClass cls+ return $ case side of+ HsHsSide -> let t' = HsTyVar $ HsIdent s+ in (Just (UnQual $ HsIdent $ toHsPtrClassName cst cls, [t']),+ t')+ HsCSide -> (Nothing, HsTyVar $ HsIdent $ toHsDataTypeName cst cls)++ -- Receive a @FooValue a => a@.+ receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType)+ receiveValue s t cls = case side of+ HsCSide -> handoff side t+ HsHsSide -> do+ addImports hsImportForRuntime+ addImportForClass cls+ let t' = HsTyVar $ HsIdent s+ return (Just (UnQual $ HsIdent $ toHsValueClassName cls, [t']),+ t')++getMethodEffectiveParams :: Class -> Method -> [Type]+getMethodEffectiveParams cls method =+ (case methodImpl method of+ RealMethod {} -> case methodApplicability method of+ MNormal -> (TPtr (TObj cls):)+ MConst -> (TPtr (TConst $ TObj cls):)+ MStatic -> id+ FnMethod {} -> id) $+ methodParams method++-- | Imports bindings for the given class into the Haskell module.+addImportForClass :: Class -> Generator ()+addImportForClass = importHsModuleForExtName . classExtName
+ src/Foreign/Hoppy/Generator/Main.hs view
@@ -0,0 +1,220 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | A driver for a command-line interface to a generator.+--+-- A simple @Main.hs@ for a generator can be:+--+-- > import Foreign.Hoppy.Generator.Main (run)+-- > import Foreign.Hoppy.Generator.Spec (ErrorMsg, Interface, interface, interfaceResult)+-- > import System.Environment (getArgs)+-- > import System.Exit (exitFailure)+-- > import System.IO (hPutStrLn, stderr)+-- >+-- > iface :: Either ErrorMsg Interface+-- > iface = interface ...+-- >+-- > main :: IO ()+-- > main = case interfaceResult of+-- > Left errorMsg -> do+-- > hPutStrLn stderr $ "Error initializing interface: " ++ errorMsg+-- > exitFailure+-- > Right iface -> do+-- > args <- getArgs+-- > _ <- run [iface] args+-- > return ()+module Foreign.Hoppy.Generator.Main (+ Action (..),+ run,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar)+import Control.Monad ((<=<), unless, when)+import Data.Foldable (forM_)+import Data.List (intercalate)+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Foreign.Hoppy.Generator.Common (writeFileIfDifferent)+import qualified Foreign.Hoppy.Generator.Language.Cpp.Internal as Cpp+import qualified Foreign.Hoppy.Generator.Language.Haskell.Internal as Haskell+import Foreign.Hoppy.Generator.Spec+import System.Directory (createDirectoryIfMissing, doesDirectoryExist)+import System.Exit (exitFailure, exitSuccess)+import System.FilePath ((</>), takeDirectory)+import System.IO (hPutStrLn, stderr)++-- | Actions that can be requested of the program.+data Action =+ ListInterfaces+ -- ^ Lists the interfaces compiled into the generator.+ | GenCpp FilePath+ -- ^ Generates C++ wrappers for an interface in the given location.+ | GenHaskell FilePath+ -- ^ Generates Haskell bindings for an interface in the given location.++data AppState = AppState+ { appInterfaces :: [Interface]+ , appCurrentInterface :: Interface+ , appCaches :: Caches+ }++initialAppState :: [Interface] -> AppState+initialAppState ifaces = AppState+ { appInterfaces = ifaces+ , appCurrentInterface = head ifaces+ , appCaches = M.empty+ }++type Caches = Map String InterfaceCache++data InterfaceCache = InterfaceCache+ { cacheInterface :: Interface+ , generatedCpp :: Maybe Cpp.Generation+ , generatedHaskell :: Maybe Haskell.Generation+ }++emptyCache :: Interface -> InterfaceCache+emptyCache iface = InterfaceCache iface Nothing Nothing++getGeneratedCpp :: InterfaceCache -> IO (InterfaceCache, Either String Cpp.Generation)+getGeneratedCpp cache = case generatedCpp cache of+ Just gen -> return (cache, Right gen)+ _ -> case Cpp.generate $ cacheInterface cache of+ l@(Left _) -> return (cache, l)+ r@(Right gen) -> return (cache { generatedCpp = Just gen }, r)++getGeneratedHaskell :: InterfaceCache -> IO (InterfaceCache, Either String Haskell.Generation)+getGeneratedHaskell cache = case generatedHaskell cache of+ Just gen -> return (cache, Right gen)+ _ -> case Haskell.generate $ cacheInterface cache of+ l@(Left _) -> return (cache, l)+ r@(Right gen) -> return (cache { generatedHaskell = Just gen }, r)++-- | @run interfaces args@ runs the driver with the command-line arguments from+-- @args@ against the listed interfaces, and returns the list of actions+-- performed.+--+-- The recognized arguments are listed below. The exact forms shown are+-- required; the @--long-arg=value@ style is not supported.+--+-- - __@--help@:__ Displays a menu listing the valid commands.+--+-- - __@--list-interfaces@:__ Lists the interfaces compiled into the generator.+--+-- - __@--gen-cpp \<outdir\>@:__ Generates C++ bindings in the given directory.+--+-- - __@--gen-hs \<outdir\>@:__ Generates Haskell bindings under the given+-- top-level source directory.+run :: [Interface] -> [String] -> IO [Action]+run interfaces args = do+ stateVar <- newMVar $ initialAppState interfaces+ when (null args) $ do+ putStrLn "This is a Hoppy interface generator. Use --help for options."+ exitSuccess+ when ("--help" `elem` args) $ usage stateVar >> exitSuccess+ processArgs stateVar args++usage :: MVar AppState -> IO ()+usage stateVar = do+ interfaceNames <- map interfaceName <$> getInterfaces stateVar+ mapM_ putStrLn+ [ "Hoppy binding generator"+ , ""+ , "Interfaces: " ++ intercalate ", " interfaceNames+ , ""+ , "Supported options:"+ , " --help Displays this menu."+ , " --list-interfaces Lists the interfaces compiled into this binary."+ , " --gen-cpp <outdir> Generate C++ bindings in a directory."+ , " --gen-hs <outdir> Generate Haskell bindings under the given"+ , " top-level source directory."+ ]++processArgs :: MVar AppState -> [String] -> IO [Action]+processArgs stateVar args =+ case args of+ [] -> return []++ "--list-interfaces":rest -> do+ listInterfaces stateVar+ (ListInterfaces:) <$> processArgs stateVar rest++ "--gen-cpp":baseDir:rest -> do+ baseDirExists <- doesDirectoryExist baseDir+ unless baseDirExists $ do+ hPutStrLn stderr $+ "--gen-cpp: Please create this directory so that I can generate files in it: " +++ baseDir+ exitFailure+ genResult <- withCurrentCache stateVar getGeneratedCpp+ case genResult of+ Left errorMsg -> do+ putStrLn $ "--gen-cpp: Failed to generate: " ++ errorMsg+ exitFailure+ Right gen -> do+ forM_ (M.toList $ Cpp.generatedFiles gen) $+ uncurry $ writeGeneratedFile baseDir+ (GenCpp baseDir:) <$> processArgs stateVar rest++ "--gen-hs":baseDir:rest -> do+ baseDirExists <- doesDirectoryExist baseDir+ unless baseDirExists $ do+ hPutStrLn stderr $+ "--gen-hs: Please create this directory so that I can generate files in it: " +++ baseDir+ exitFailure+ genResult <- withCurrentCache stateVar getGeneratedHaskell+ case genResult of+ Left errorMsg -> do+ putStrLn $ "--gen-hs: Failed to generate: " ++ errorMsg+ exitFailure+ Right gen -> do+ forM_ (M.toList $ Haskell.generatedFiles gen) $+ uncurry $ writeGeneratedFile baseDir+ (GenHaskell baseDir:) <$> processArgs stateVar rest++ arg:_ -> do+ putStrLn $ "Invalid option or missing argument for " ++ arg ++ "."+ exitFailure++writeGeneratedFile :: FilePath -> FilePath -> String -> IO ()+writeGeneratedFile baseDir subpath contents = do+ let path = baseDir </> subpath+ createDirectoryIfMissing True $ takeDirectory path+ writeFileIfDifferent path contents++withCurrentCache :: MVar AppState -> (InterfaceCache -> IO (InterfaceCache, a)) -> IO a+withCurrentCache stateVar fn = modifyMVar stateVar $ \state -> do+ let currentInterface = appCurrentInterface state+ name = interfaceName currentInterface+ (cache, result) <- fn $+ fromMaybe (emptyCache currentInterface) $+ M.lookup name $+ appCaches state+ return (state { appCaches = M.insert name cache $ appCaches state }, result)++listInterfaces :: MVar AppState -> IO ()+listInterfaces = mapM_ (putStrLn . interfaceName) . appInterfaces <=< readMVar++getInterfaces :: MVar AppState -> IO [Interface]+getInterfaces = fmap appInterfaces . readMVar
+ src/Foreign/Hoppy/Generator/Spec.hs view
@@ -0,0 +1,1796 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | The primary data types for specifying C++ interfaces.+--+-- 'Show' instances in this module produce strings of the form @\"\<TypeOfObject+-- nameOfObject otherInfo...\>\"@. They can be used in error messages without+-- specifying a noun separately, i.e. write @show cls@ instead of @\"the class+-- \" ++ show cls@.+module Foreign.Hoppy.Generator.Spec (+ -- * Interfaces+ Interface,+ ErrorMsg,+ interface,+ interfaceName,+ interfaceModules,+ interfaceNamesToModules,+ interfaceHaskellModuleBase,+ interfaceDefaultHaskellModuleBase,+ interfaceAddHaskellModuleBase,+ -- * C++ includes+ Include,+ includeStd,+ includeLocal,+ includeToString,+ -- * Modules+ Module,+ moduleName,+ moduleHppPath,+ moduleCppPath,+ moduleExports,+ moduleReqs,+ moduleHaskellName,+ makeModule,+ moduleModify,+ moduleModify',+ moduleSetHppPath,+ moduleSetCppPath,+ moduleAddExports,+ moduleAddHaskellName,+ -- * Requirements+ Reqs,+ reqsIncludes,+ reqInclude,+ HasReqs (..),+ addReqs,+ addReqIncludes,+ -- * Names and exports+ ExtName,+ toExtName,+ fromExtName,+ FnName (..),+ IsFnName (..),+ Operator (..),+ OperatorType (..),+ operatorPreferredExtName,+ operatorPreferredExtName',+ operatorType,+ Export (..),+ exportExtName,+ exportAddendum,+ Identifier,+ identifierParts,+ IdPart,+ idPartBase,+ idPartArgs,+ ident, ident', ident1, ident2, ident3, ident4, ident5,+ identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T,+ -- * Basic types+ Type (..),+ normalizeType,+ stripConst,+ -- ** Variables+ Variable, makeVariable, varIdentifier, varExtName, varType, varReqs,+ varIsConst, varGetterExtName, varSetterExtName,+ -- ** Enums+ CppEnum, makeEnum, enumIdentifier, enumExtName, enumValueNames, enumReqs,+ -- ** Bitspaces+ Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum,+ bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn,+ bitspaceAddCppType, bitspaceReqs,+ -- ** Functions+ Purity (..),+ Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs,+ -- ** Classes+ Class, makeClass, classIdentifier, classExtName, classSuperclasses, classCtors, classDtorIsPublic,+ classMethods, classConversion, classReqs, classAddCtors, classSetDtorPrivate, classAddMethods,+ classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,+ classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,+ HasClassyExtName (..),+ Ctor, makeCtor, mkCtor, ctorExtName, ctorParams,+ Method,+ MethodImpl (..),+ MethodApplicability (..),+ Constness (..),+ constNegate,+ Staticness (..),+ makeMethod, makeFnMethod, mkMethod, mkMethod', mkConstMethod, mkConstMethod',+ mkStaticMethod, mkStaticMethod',+ mkProps, mkProp, mkStaticProp, mkBoolIsProp, mkBoolHasProp,+ methodImpl, methodExtName, methodApplicability, methodPurity, methodParams,+ methodReturn, methodConst, methodStatic,+ -- *** Conversion to and from foreign values+ ClassConversion (..),+ classConversionNone,+ classModifyConversion,+ ClassHaskellConversion (..),+ -- ** Callbacks+ Callback, makeCallback, callbackExtName, callbackParams, callbackReturn, callbackReqs,+ callbackToTFn,+ -- * Addenda+ Addendum (..),+ HasAddendum,+ addAddendumHaskell,+ -- * Haskell imports+ HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),+ hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',+ hsImportSetMakeSource,+ -- * Internal to Hoppy+ stringOrIdentifier,+ -- ** Haskell imports+ makeHsImportSet,+ getHsImportSet,+ hsImportForBits,+ hsImportForInt,+ hsImportForWord,+ hsImportForForeign,+ hsImportForForeignC,+ hsImportForPrelude,+ hsImportForRuntime,+ hsImportForSystemPosixTypes,+ hsImportForUnsafeIO,+ -- ** Error messages+ tObjToHeapWrongDirectionErrorMsg,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Arrow ((&&&))+import Control.Monad (liftM2, unless)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (MonadError, throwError)+#else+import Control.Monad.Error (MonadError, throwError)+#endif+import Control.Monad.State (MonadState, StateT, execStateT, get, modify)+import Data.Char (isAlpha, isAlphaNum, toUpper)+import Data.Function (on)+import Data.List (intercalate, intersperse)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid, mappend, mconcat, mempty)+#endif+import qualified Data.Set as S+import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as Haskell+import Language.Haskell.Syntax (HsType)++-- | Indicates strings that are error messages.+type ErrorMsg = String++-- | A complete specification of a C++ API. Generators for different languages,+-- including the binding generator for C++, use these to produce their output.+data Interface = Interface+ { interfaceName :: String+ -- ^ The textual name of the interface.+ , interfaceModules :: M.Map String Module+ -- ^ All of the individual modules, by 'moduleName'.+ , interfaceNamesToModules :: M.Map ExtName Module+ -- ^ Maps each 'ExtName' exported by some module to the module that exports+ -- the name.+ , interfaceHaskellModuleBase' :: Maybe [String]+ -- ^ See 'interfaceHaskellModuleBase'.+ }++instance Show Interface where+ show iface = concat ["<Interface ", show (interfaceName iface), ">"]++-- | Constructs an 'Interface' from the required parts. Some validation is+-- performed; if the resulting interface would be invalid, an error message is+-- returned instead.+interface :: String -- ^ 'interfaceName'+ -> [Module] -- ^ 'interfaceModules'+ -> Either ErrorMsg Interface+interface ifName modules = do+ -- TODO Check for duplicate module names.+ -- TODO Check for duplicate module file paths.++ -- Check for multiple modules exporting an ExtName.+ let extNamesToModules :: M.Map ExtName [Module]+ extNamesToModules =+ M.unionsWith (++) $+ map (\m -> const [m] <$> moduleExports m) modules++ extNamesInMultipleModules :: [(ExtName, [Module])]+ extNamesInMultipleModules =+ M.toList $+ M.filter (\modules -> case modules of+ _:_:_ -> True+ _ -> False)+ extNamesToModules++ unless (null extNamesInMultipleModules) $+ Left $ unlines $+ "Some external name(s) are exported by multiple modules:" :+ map (\(extName, modules) ->+ concat $ "- " : show extName : ": " : intersperse ", " (map show modules))+ extNamesInMultipleModules++ return Interface+ { interfaceName = ifName+ , interfaceModules = M.fromList $ map (moduleName &&& id) modules+ , interfaceNamesToModules = M.map (\[x] -> x) extNamesToModules+ , interfaceHaskellModuleBase' = Nothing+ }++-- | The name of the parent Haskell module under which a Haskell module will be+-- generated for a Hoppy 'Module'. This is a list of Haskell module path+-- components, in other words, @'Data.List.intercalate' "."@ on the list+-- produces a Haskell module name. Defaults to+-- 'interfaceDefaultHaskellModuleBase', and may be overridden with+-- 'interfaceAddHaskellModuleBase'.+interfaceHaskellModuleBase :: Interface -> [String]+interfaceHaskellModuleBase =+ fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase'++-- | The default Haskell module under which Hoppy modules will be generated.+-- This is @Foreign.Hoppy.Generated@, that is:+--+-- > ["Foreign", "Hoppy", "Generated"]+interfaceDefaultHaskellModuleBase :: [String]+interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"]++-- | Sets an interface to generate all of its modules under the given Haskell+-- module prefix. See 'interfaceHaskellModuleBase'.+interfaceAddHaskellModuleBase :: [String] -> Interface -> Either String Interface+interfaceAddHaskellModuleBase modulePath iface = case interfaceHaskellModuleBase' iface of+ Nothing -> Right iface { interfaceHaskellModuleBase' = Just modulePath }+ Just existingPath ->+ Left $ concat+ [ "addInterfaceHaskellModuleBase: Trying to add Haskell module base "+ , intercalate "." modulePath, " to ", show iface+ , " which already has a module base ", intercalate "." existingPath+ ]++-- | An @#include@ directive in a C++ file.+data Include = Include+ { includeToString :: String+ -- ^ Returns the complete @#include ...@ line for an include, including+ -- trailing newline.+ } deriving (Eq, Ord, Show)++-- | Creates an @#include \<...\>@ directive.+includeStd :: String -> Include+includeStd path = Include $ "#include <" ++ path ++ ">\n"++-- | Creates an @#include "..."@ directive.+includeLocal :: String -> Include+includeLocal path = Include $ "#include \"" ++ path ++ "\"\n"++-- | A portion of functionality in a C++ API. An 'Interface' is composed of+-- multiple modules. A module will generate a single compilation unit+-- containing bindings for all of the module's exports. The C++ code for a+-- generated module will @#include@ everything necessary for what is written to+-- the header and source files separately. You can declare include dependencies+-- with e.g. 'addReqIncludes', either for individual exports or at the module+-- level. Dependencies between modules are handled automatically, and+-- circularity is supported to a certain extent. See the documentation for the+-- individual language modules for further details.+data Module = Module+ { moduleName :: String+ -- ^ The module's name. A module name must identify a unique module within+ -- an 'Interface'.+ , moduleHppPath :: String+ -- ^ A relative path under a C++ sources root to which the generator will+ -- write a header file for the module's C++ bindings.+ , moduleCppPath :: String+ -- ^ A relative path under a C++ sources root to which the generator will+ -- write a source file for the module's C++ bindings.+ , moduleExports :: M.Map ExtName Export+ -- ^ All of the exports in a module.+ , moduleReqs :: Reqs+ -- ^ Module-level requirements.+ , moduleHaskellName :: Maybe [String]+ -- ^ The generated Haskell module name, underneath the+ -- 'interfaceHaskellModuleBase'. If absent (by default), the 'moduleName'+ -- is used. May be modified with 'moduleAddHaskellName'.+ }++instance Eq Module where+ (==) = (==) `on` moduleName++instance Ord Module where+ compare = compare `on` moduleName++instance Show Module where+ show m = concat ["<Module ", moduleName m, ">"]++instance HasReqs Module where+ getReqs = moduleReqs+ setReqs reqs m = m { moduleReqs = reqs }++-- | Creates an empty module, ready to be configured with 'moduleModify'.+makeModule :: String -- ^ 'moduleName'+ -> String -- ^ 'moduleHppPath'+ -> String -- ^ 'moduleCppPath'+ -> Module+makeModule name hppPath cppPath = Module+ { moduleName = name+ , moduleHppPath = hppPath+ , moduleCppPath = cppPath+ , moduleExports = M.empty+ , moduleReqs = mempty+ , moduleHaskellName = Nothing+ }++-- | Extends a module. To be used with the module state-monad actions in this+-- package.+moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module+moduleModify = flip execStateT++-- | Same as 'moduleModify', but calls 'error' in the case of failure, which is+-- okay in for a generator which would abort in this case anyway.+moduleModify' :: Module -> StateT Module (Either String) () -> Module+moduleModify' m action = case moduleModify m action of+ Left errorMsg ->+ error $ concat+ ["moduleModify' failed to modify ", show m, ": ", errorMsg]+ Right m' -> m'++-- | Replaces a module's 'moduleHppPath'.+moduleSetHppPath :: MonadState Module m => String -> m ()+moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path }++-- | Replaces a module's 'moduleCppPath'.+moduleSetCppPath :: MonadState Module m => String -> m ()+moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path }++-- | Adds exports to a module. An export must only be added to any module at+-- most once, and must not be added to multiple modules.+moduleAddExports :: (MonadError String m, MonadState Module m) => [Export] -> m ()+moduleAddExports exports = do+ m <- get+ let existingExports = moduleExports m+ newExports = M.fromList $ map (exportExtName &&& id) exports+ duplicateNames = (S.intersection `on` M.keysSet) existingExports newExports+ if S.null duplicateNames+ then modify $ \m -> m { moduleExports = existingExports `mappend` newExports }+ else throwError $ concat+ ["moduleAddExports: ", show m, " defines external names multiple times: ",+ show duplicateNames]++-- | Changes a module's 'moduleHaskellName' from the default. This can only be+-- called once on a module.+moduleAddHaskellName :: (MonadError String m, MonadState Module m) => [String] -> m ()+moduleAddHaskellName name = do+ m <- get+ case moduleHaskellName m of+ Nothing -> modify $ \m -> m { moduleHaskellName = Just name }+ Just name' ->+ throwError $ concat+ ["moduleAddHaskellName: ", show m, " already has Haskell name ",+ show name', "; trying to add name ", show name, "."]++-- | A set of requirements of needed to use an identifier in C++ (function,+-- type, etc.), via a set of 'Include's. The monoid instance has 'mempty' as an+-- empty set of includes, and 'mappend' unions two include sets.+data Reqs = Reqs+ { reqsIncludes :: S.Set Include+ -- ^ The includes specified by a 'Reqs'.+ } deriving (Show)++instance Monoid Reqs where+ mempty = Reqs mempty++ mappend (Reqs incl) (Reqs incl') = Reqs $ mappend incl incl'++ mconcat reqs = Reqs $ mconcat $ map reqsIncludes reqs++-- | Creates a 'Reqs' that contains the given include.+reqInclude :: Include -> Reqs+reqInclude include = mempty { reqsIncludes = S.singleton include }++-- | C++ types that have requirements in order to use them in generated+-- bindings.+class HasReqs a where+ {-# MINIMAL getReqs, (setReqs | modifyReqs) #-}++ -- | Returns an object's requirements.+ getReqs :: a -> Reqs++ -- | Replaces an object's requirements with new ones.+ setReqs :: Reqs -> a -> a+ setReqs = modifyReqs . const++ -- | Modifies an object's requirements.+ modifyReqs :: (Reqs -> Reqs) -> a -> a+ modifyReqs f x = setReqs (f $ getReqs x) x++-- | Adds to a object's requirements.+addReqs :: HasReqs a => Reqs -> a -> a+addReqs reqs = modifyReqs $ mappend reqs++-- | Adds a list of includes to the requirements of an object.+addReqIncludes :: HasReqs a => [Include] -> a -> a+addReqIncludes includes =+ modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes }++-- | An external name is a string that generated bindings use to uniquely+-- identify an object at runtime. An external name must start with an+-- alphabetic character, and may only contain alphanumeric characters and @'_'@.+-- You are free to use whatever naming style you like; case conversions will be+-- performed automatically when required. Hoppy does make use of some+-- conventions though, for example with 'Operator's and in the provided bindings+-- for the C++ standard library.+--+-- External names must be unique within an interface. They may not be reused+-- between modules. This assumption is used for symbol naming in compiled+-- shared objects and to freely import modules in Haskell bindings.+newtype ExtName = ExtName+ { fromExtName :: String+ -- ^ Returns the string an an 'ExtName' contains.+ } deriving (Eq, Ord)++instance Show ExtName where+ show extName = concat ["$\"", fromExtName extName, "\"$"]++-- | Creates an 'ExtName' that contains the given string, erroring if the string+-- is an invalid 'ExtName'.+toExtName :: String -> ExtName+toExtName str = case str of+ [] -> error "An ExtName cannot be empty."+ c:cs -> if isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs+ then ExtName str+ else error $+ "An ExtName must start with a letter and only contain letters, numbers, and '_': " +++ show str++-- | Generates an 'ExtName' from an 'Identifier', if the given name is absent.+extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName+extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of+ [] -> error "extNameOrIdentifier: Invalid empty identifier."+ parts -> toExtName $ idPartBase $ last parts++-- | Like 'extNameOrIdentifier', but works with strings rather than 'ExtName's.+stringOrIdentifier :: Identifier -> Maybe String -> String+stringOrIdentifier ident = fromMaybe $ case identifierParts ident of+ [] -> error "stringOrIdentifier: Invalid empty identifier."+ parts -> idPartBase $ last parts++-- | Generates an 'ExtName' from an @'FnName' 'Identifier'@, if the given name+-- is absent.+extNameOrFnIdentifier :: FnName Identifier -> Maybe ExtName -> ExtName+extNameOrFnIdentifier name =+ fromMaybe $ case name of+ FnName identifier -> case identifierParts identifier of+ [] -> error "extNameOrFnIdentifier: Empty idenfitier."+ parts -> toExtName $ idPartBase $ last parts+ FnOp op -> operatorPreferredExtName op++-- | The C++ name of a function or method.+data FnName name =+ FnName name+ -- ^ A regular, \"alphanumeric\" name. The exact type depends on what kind of+ -- object is being named.+ | FnOp Operator+ -- ^ An operator name.+ deriving (Eq, Ord)++instance Show name => Show (FnName name) where+ show (FnName name) = concat ["<FnName ", show name, ">"]+ show (FnOp op) = concat ["<FnOp ", show op, ">"]++-- | Enables implementing automatic conversions to a @'FnName' t@.+class IsFnName t a where+ toFnName :: a -> FnName t++instance IsFnName t (FnName t) where+ toFnName = id++instance IsFnName t t where+ toFnName = FnName++instance IsFnName t Operator where+ toFnName = FnOp++-- | Overloadable C++ operators.+data Operator =+ OpCall -- ^ @x(...)@+ | OpComma -- ^ @x, y@+ | OpAssign -- ^ @x = y@+ | OpArray -- ^ @x[y]@+ | OpDeref -- ^ @*x@+ | OpAddress -- ^ @&x@+ | OpAdd -- ^ @x + y@+ | OpAddAssign -- ^ @x += y@+ | OpSubtract -- ^ @x - y@+ | OpSubtractAssign -- ^ @x -= y@+ | OpMultiply -- ^ @x * y@+ | OpMultiplyAssign -- ^ @x *= y@+ | OpDivide -- ^ @x / y@+ | OpDivideAssign -- ^ @x /= y@+ | OpModulo -- ^ @x % y@+ | OpModuloAssign -- ^ @x %= y@+ | OpPlus -- ^ @+x@+ | OpMinus -- ^ @-x@+ | OpIncPre -- ^ @++x@+ | OpIncPost -- ^ @x++@+ | OpDecPre -- ^ @--x@+ | OpDecPost -- ^ @x--@+ | OpEq -- ^ @x == y@+ | OpNe -- ^ @x != y@+ | OpLt -- ^ @x < y@+ | OpLe -- ^ @x <= y@+ | OpGt -- ^ @x > y@+ | OpGe -- ^ @x >= y@+ | OpNot -- ^ @!x@+ | OpAnd -- ^ @x && y@+ | OpOr -- ^ @x || y@+ | OpBitNot -- ^ @~x@+ | OpBitAnd -- ^ @x & y@+ | OpBitAndAssign -- ^ @x &= y@+ | OpBitOr -- ^ @x | y@+ | OpBitOrAssign -- ^ @x |= y@+ | OpBitXor -- ^ @x ^ y@+ | OpBitXorAssign -- ^ @x ^= y@+ | OpShl -- ^ @x << y@+ | OpShlAssign -- ^ @x <<= y@+ | OpShr -- ^ @x >> y@+ | OpShrAssign -- ^ @x >>= y@+ deriving (Bounded, Enum, Eq, Ord, Show)++-- | The arity and syntax of an operator.+data OperatorType =+ UnaryPrefixOperator String -- ^ Prefix unary operators. Examples: @!x@, @*x@, @++x@.+ | UnaryPostfixOperator String -- ^ Postfix unary operators. Examples: @x--, x++@.+ | BinaryOperator String -- ^ Infix binary operators. Examples: @x * y@, @x >>= y@.+ | CallOperator -- ^ @x(...)@ with arbitrary arity.+ | ArrayOperator -- ^ @x[y]@, a binary operator with non-infix syntax.++data OperatorInfo = OperatorInfo+ { operatorPreferredExtName'' :: ExtName+ , operatorType' :: OperatorType+ }++makeOperatorInfo :: String -> OperatorType -> OperatorInfo+makeOperatorInfo = OperatorInfo . toExtName++-- | Returns a conventional string to use for the 'ExtName' of an operator.+operatorPreferredExtName :: Operator -> ExtName+operatorPreferredExtName op = case M.lookup op operatorInfo of+ Just info -> operatorPreferredExtName'' info+ Nothing ->+ error $ concat+ ["operatorPreferredExtName: Internal error, missing info for operator ", show op, "."]++-- | Returns a conventional name for an operator, as with+-- 'operatorPreferredExtName', but as a string.+operatorPreferredExtName' :: Operator -> String+operatorPreferredExtName' = fromExtName . operatorPreferredExtName++-- | Returns the type of an operator.+operatorType :: Operator -> OperatorType+operatorType op = case M.lookup op operatorInfo of+ Just info -> operatorType' info+ Nothing ->+ error $ concat+ ["operatorType: Internal error, missing info for operator ", show op, "."]++-- | Metadata for operators.+--+-- TODO Test out this missing data.+operatorInfo :: M.Map Operator OperatorInfo+operatorInfo =+ let input =+ [ (OpCall, makeOperatorInfo "CALL" CallOperator)+ , (OpComma, makeOperatorInfo "COMMA" $ BinaryOperator ",")+ , (OpAssign, makeOperatorInfo "ASSIGN" $ BinaryOperator "=")+ , (OpArray, makeOperatorInfo "ARRAY" ArrayOperator)+ , (OpDeref, makeOperatorInfo "DEREF" $ UnaryPrefixOperator "*")+ , (OpAddress, makeOperatorInfo "ADDRESS" $ UnaryPrefixOperator "&")+ , (OpAdd, makeOperatorInfo "ADD" $ BinaryOperator "+")+ , (OpAddAssign, makeOperatorInfo "ADDA" $ BinaryOperator "+=")+ , (OpSubtract, makeOperatorInfo "SUB" $ BinaryOperator "-")+ , (OpSubtractAssign, makeOperatorInfo "SUBA" $ BinaryOperator "-=")+ , (OpMultiply, makeOperatorInfo "MUL" $ BinaryOperator "*")+ , (OpMultiplyAssign, makeOperatorInfo "MULA" $ BinaryOperator "*=")+ , (OpDivide, makeOperatorInfo "DIV" $ BinaryOperator "/")+ , (OpDivideAssign, makeOperatorInfo "DIVA" $ BinaryOperator "/=")+ , (OpModulo, makeOperatorInfo "MOD" $ BinaryOperator "%")+ , (OpModuloAssign, makeOperatorInfo "MODA" $ BinaryOperator "%=")+ , (OpPlus, makeOperatorInfo "PLUS" $ UnaryPrefixOperator "+")+ , (OpMinus, makeOperatorInfo "NEG" $ UnaryPrefixOperator "-")+ , (OpIncPre, makeOperatorInfo "INC" $ UnaryPrefixOperator "++")+ , (OpIncPost, makeOperatorInfo "INCPOST" $ UnaryPostfixOperator "++")+ , (OpDecPre, makeOperatorInfo "DEC" $ UnaryPrefixOperator "--")+ , (OpDecPost, makeOperatorInfo "DECPOST" $ UnaryPostfixOperator "--")+ , (OpEq, makeOperatorInfo "EQ" $ BinaryOperator "==")+ , (OpNe, makeOperatorInfo "NE" $ BinaryOperator "!=")+ , (OpLt, makeOperatorInfo "LT" $ BinaryOperator "<")+ , (OpLe, makeOperatorInfo "LE" $ BinaryOperator "<=")+ , (OpGt, makeOperatorInfo "GT" $ BinaryOperator ">")+ , (OpGe, makeOperatorInfo "GE" $ BinaryOperator ">=")+ , (OpNot, makeOperatorInfo "NOT" $ UnaryPrefixOperator "!")+ , (OpAnd, makeOperatorInfo "AND" $ BinaryOperator "&&")+ , (OpOr, makeOperatorInfo "OR" $ BinaryOperator "||")+ , (OpBitNot, makeOperatorInfo "BNOT" $ UnaryPrefixOperator "~")+ , (OpBitAnd, makeOperatorInfo "BAND" $ BinaryOperator "&")+ , (OpBitAndAssign, makeOperatorInfo "BANDA" $ BinaryOperator "&=")+ , (OpBitOr, makeOperatorInfo "BOR" $ BinaryOperator "|")+ , (OpBitOrAssign, makeOperatorInfo "BORA" $ BinaryOperator "|=")+ , (OpBitXor, makeOperatorInfo "BXOR" $ BinaryOperator "^")+ , (OpBitXorAssign, makeOperatorInfo "BXORA" $ BinaryOperator "^=")+ , (OpShl, makeOperatorInfo "SHL" $ BinaryOperator "<<")+ , (OpShlAssign, makeOperatorInfo "SHLA" $ BinaryOperator "<<=")+ , (OpShr, makeOperatorInfo "SHR" $ BinaryOperator ">>")+ , (OpShrAssign, makeOperatorInfo "SHR" $ BinaryOperator ">>=")+ ]+ in if map fst input == [minBound..]+ then M.fromList input+ else error "operatorInfo: Operator info list is out of sync with Operator data type."++-- | Specifies some C++ object (function or class) to give access to.+data Export =+ ExportVariable Variable -- ^ Exports a variable.+ | ExportEnum CppEnum -- ^ Exports an enum.+ | ExportBitspace Bitspace -- ^ Exports a bitspace.+ | ExportFn Function -- ^ Exports a function.+ | ExportClass Class -- ^ Exports a class with all of its contents.+ | ExportCallback Callback -- ^ Exports a callback.+ deriving (Show)++-- | Returns the external name of an export.+exportExtName :: Export -> ExtName+exportExtName export = case export of+ ExportVariable v -> varExtName v+ ExportEnum e -> enumExtName e+ ExportBitspace b -> bitspaceExtName b+ ExportFn f -> fnExtName f+ ExportClass c -> classExtName c+ ExportCallback cb -> callbackExtName cb++-- | Returns the export's addendum. 'Export' doesn't have a 'HasAddendum'+-- instance because you normally wouldn't want to modify the addendum of one.+exportAddendum export = case export of+ ExportVariable v -> getAddendum v+ ExportEnum e -> getAddendum e+ ExportBitspace bs -> getAddendum bs+ ExportFn f -> getAddendum f+ ExportClass cls -> getAddendum cls+ ExportCallback cb -> getAddendum cb++-- | A path to some C++ object, including namespaces. An identifier consists of+-- multiple parts separated by @\"::\"@. Each part has a name string followed+-- by an optional template argument list, where each argument gets rendered from+-- a 'Type' (non-type arguments for template metaprogramming are not supported).+newtype Identifier = Identifier+ { identifierParts :: [IdPart]+ -- ^ The separate parts of the identifier, between @::@s.+ } deriving (Eq)++instance Show Identifier where+ show ident =+ (\words -> concat $ "<Identifier " : words ++ [">"]) $+ intersperse "::" $+ map (\part -> case idPartArgs part of+ Nothing -> idPartBase part+ Just args ->+ concat $+ idPartBase part : "<" :+ intersperse ", " (map show args) ++ [">"]) $+ identifierParts ident++-- | A single component of an 'Identifier', between @::@s.+data IdPart = IdPart+ { idPartBase :: String+ -- ^ The name within the enclosing scope.+ , idPartArgs :: Maybe [Type]+ -- ^ Template arguments, if present.+ } deriving (Eq, Show)++-- | Creates an identifier of the form @a@.+ident :: String -> Identifier+ident a = Identifier [IdPart a Nothing]++-- | Creates an identifier of the form @a1::a2::...::aN@.+ident' :: [String] -> Identifier+ident' = Identifier . map (\x -> IdPart x Nothing)++-- | Creates an identifier of the form @a::b@.+ident1 :: String -> String -> Identifier+ident1 a b = ident' [a, b]++-- | Creates an identifier of the form @a::b::c@.+ident2 :: String -> String -> String -> Identifier+ident2 a b c = ident' [a, b, c]++-- | Creates an identifier of the form @a::b::c::d@.+ident3 :: String -> String -> String -> String -> Identifier+ident3 a b c d = ident' [a, b, c, d]++-- | Creates an identifier of the form @a::b::c::d::e@.+ident4 :: String -> String -> String -> String -> String -> Identifier+ident4 a b c d e = ident' [a, b, c, d, e]++-- | Creates an identifier of the form @a::b::c::d::e::f@.+ident5 :: String -> String -> String -> String -> String -> String -> Identifier+ident5 a b c d e f = ident' [a, b, c, d, e, f]++-- | Creates an identifier of the form @a\<...\>@.+identT :: String -> [Type] -> Identifier+identT a ts = Identifier [IdPart a $ Just ts]++-- | Creates an identifier with arbitrary many templated and non-templated+-- parts.+identT' :: [(String, Maybe [Type])] -> Identifier+identT' = Identifier . map (uncurry IdPart)++-- | Creates an identifier of the form @a::b\<...\>@.+ident1T :: String -> String -> [Type] -> Identifier+ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts]++-- | Creates an identifier of the form @a::b::c\<...\>@.+ident2T :: String -> String -> String -> [Type] -> Identifier+ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts]++-- | Creates an identifier of the form @a::b::c::d\<...\>@.+ident3T :: String -> String -> String -> String -> [Type] -> Identifier+ident3T a b c d ts =+ Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,+ IdPart d $ Just ts]++-- | Creates an identifier of the form @a::b::c::d::e\<...\>@.+ident4T :: String -> String -> String -> String -> String -> [Type] -> Identifier+ident4T a b c d e ts =+ Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,+ IdPart d Nothing, IdPart e $ Just ts]++-- | Creates an identifier of the form @a::b::c::d::e::f\<...\>@.+ident5T :: String -> String -> String -> String -> String -> String -> [Type] -> Identifier+ident5T a b c d e f ts =+ Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,+ IdPart d Nothing, IdPart e Nothing, IdPart f $ Just ts]++-- | Concrete C++ types. It is possible to represent invalid C++ types with+-- this, but we try to catch these and fail cleanly as much as possible.+data Type =+ TVoid -- ^ C++ @void@, Haskell @()@.+ | TBool -- ^ C++ @bool@, Haskell 'Bool'.+ | TChar -- ^ C++ @char@, Haskell 'Foreign.C.CChar'.+ | TUChar -- ^ C++ @unsigned char@, Haskell 'Foreign.C.CUChar'.+ | TShort -- ^ C++ @short int@, Haskell 'Foreign.C.CShort'.+ | TUShort -- ^ C++ @unsigned short int@, Haskell 'Foreign.C.CUShort'.+ | TInt -- ^ C++ @int@, Haskell 'Foreign.C.CInt'.+ | TUInt -- ^ C++ @unsigned int@, Haskell 'Foreign.C.CUInt'.+ | TLong -- ^ C++ @long int@, Haskell 'Foreign.C.CLong'.+ | TULong -- ^ C++ @unsigned long int@, Haskell 'Foreign.C.CULong'.+ | TLLong -- ^ C++ @long long int@, Haskell 'Foreign.C.CLLong'.+ | TULLong -- ^ C++ @unsigned long long int@, Haskell 'Foreign.C.CULLong'.+ | TFloat -- ^ C++ @float@, Haskell 'Foreign.C.CFloat'.+ | TDouble -- ^ C++ @double@, Haskell 'Foreign.C.CDouble'.+ | TInt8 -- ^ C++ @int8_t@, Haskell 'Data.Int.Int8'.+ | TInt16 -- ^ C++ @int16_t@, Haskell 'Data.Int.Int16'.+ | TInt32 -- ^ C++ @int32_t@, Haskell 'Data.Int.Int32'.+ | TInt64 -- ^ C++ @int64_t@, Haskell 'Data.Int.Int64'.+ | TWord8 -- ^ C++ @uint8_t@, Haskell 'Data.Word.Word8'.+ | TWord16 -- ^ C++ @uint16_t@, Haskell 'Data.Word.Word16'.+ | TWord32 -- ^ C++ @uint32_t@, Haskell 'Data.Word.Word32'.+ | TWord64 -- ^ C++ @uint64_t@, Haskell 'Data.Word.Word64'.+ | TPtrdiff -- ^ C++ @ptrdiff_t@, Haskell 'Foreign.C.CPtrdiff'.+ | TSize -- ^ C++ @size_t@, Haskell 'Foreign.C.CSize'.+ | TSSize -- ^ C++ @ssize_t@, Haskell 'System.Posix.Types.CSsize'.+ | TEnum CppEnum -- ^ A C++ @enum@ value.+ | TBitspace Bitspace -- ^ A C++ bitspace value.+ | TPtr Type -- ^ A poiner to another type.+ | TRef Type -- ^ A reference to another type.+ | TFn [Type] Type+ -- ^ A function taking parameters and returning a value (or 'TVoid').+ -- Function pointers must wrap a 'TFn' in a 'TPtr'.+ | TCallback Callback -- ^ A handle for calling foreign code from C++.+ | TObj Class -- ^ An instance of a class.+ | TObjToHeap Class+ -- ^ A special case of 'TObj' that is only allowed when passing values from+ -- C++ to a foreign language. Rather than looking at the object's+ -- 'ClassConversion', the object will be copied to the heap, and a pointer+ -- to the new object will be passed. The object must be copy-constructable.+ --+ -- __The foreign language owns the pointer, even for callback arguments.__+ | TConst Type -- ^ A @const@ version of another type.+ deriving (Eq, Show)++-- | Canonicalizes a 'Type' without changing its meaning. Multiple nested+-- 'TConst's are collapsed into a single one.+normalizeType :: Type -> Type+normalizeType t = case t of+ TVoid -> t+ TBool -> t+ TChar -> t+ TUChar -> t+ TShort -> t+ TUShort -> t+ TInt -> t+ TUInt -> t+ TLong -> t+ TULong -> t+ TLLong -> t+ TULLong -> t+ TFloat -> t+ TDouble -> t+ TInt8 -> t+ TInt16 -> t+ TInt32 -> t+ TInt64 -> t+ TWord8 -> t+ TWord16 -> t+ TWord32 -> t+ TWord64 -> t+ TPtrdiff -> t+ TSize -> t+ TSSize -> t+ TEnum _ -> t+ TBitspace _ -> t+ TPtr t' -> TPtr $ normalizeType t'+ TRef t' -> TRef $ normalizeType t'+ TFn paramTypes retType -> TFn (map normalizeType paramTypes) $ normalizeType retType+ TCallback _ -> t+ TObj _ -> t+ TObjToHeap _ -> t+ TConst (TConst t') -> normalizeType $ TConst t'+ TConst _ -> t++-- | Strips leading 'TConst's off of a type.+stripConst :: Type -> Type+stripConst t = case t of+ TConst t' -> stripConst t'+ _ -> t++-- | A C++ variable.+data Variable = Variable+ { varIdentifier :: Identifier+ -- ^ The identifier used to refer to the variable.+ , varExtName :: ExtName+ -- ^ The variable's external name.+ , varType :: Type+ -- ^ The type of the variable. This may be 'TConst' to indicate that the+ -- variable is read-only.+ , varReqs :: Reqs+ -- ^ Requirements for bindings to use this variable.+ , varAddendum :: Addendum+ -- ^ The variable's addendum.+ }++instance Eq Variable where+ (==) = (==) `on` varIdentifier++instance Show Variable where+ show v = concat ["<Variable ", show (varExtName v), " ", show (varType v), ">"]++instance HasReqs Variable where+ getReqs = varReqs+ setReqs reqs v = v { varReqs = reqs }++instance HasAddendum Variable where+ getAddendum = varAddendum+ setAddendum addendum v = v { varAddendum = addendum }++-- | Creates a binding for a C++ variable.+makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable+makeVariable identifier maybeExtName t =+ Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty++-- | Returns whether the variable is constant, i.e. whether its type is+-- @'TConst' ...@.+varIsConst :: Variable -> Bool+varIsConst v = case varType v of+ TConst _ -> True+ _ -> False++-- | Returns the external name of the getter function for the variable.+varGetterExtName :: Variable -> ExtName+varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName++-- | Returns the external name of the setter function for the variable.+varSetterExtName :: Variable -> ExtName+varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName++-- | A C++ enum declaration. An enum should actually be enumerable (in the+-- sense of Haskell's 'Enum'); if it's not, consider using a 'Bitspace' instead.+data CppEnum = CppEnum+ { enumIdentifier :: Identifier+ -- ^ The identifier used to refer to the enum.+ , enumExtName :: ExtName+ -- ^ The enum's external name.+ , enumValueNames :: [(Int, [String])]+ -- ^ The numeric values and names of the enum values. A single value's name+ -- is broken up into words. How the words and ext name get combined to make+ -- a name in a particular foreign language depends on the language.+ , enumReqs :: Reqs+ -- ^ Requirements for a 'Type' to reference this enum.+ , enumAddendum :: Addendum+ -- ^ The enum's addendum.+ }++instance Eq CppEnum where+ (==) = (==) `on` enumIdentifier++instance Show CppEnum where+ show e = concat ["<Enum ", show (enumExtName e), " ", show (enumIdentifier e), ">"]++instance HasReqs CppEnum where+ getReqs = enumReqs+ setReqs reqs e = e { enumReqs = reqs }++instance HasAddendum CppEnum where+ getAddendum = enumAddendum+ setAddendum addendum e = e { enumAddendum = addendum }++-- | Creates a binding for a C++ enum.+makeEnum :: Identifier -- ^ 'enumIdentifier'+ -> Maybe ExtName+ -- ^ An optional external name; will be automatically derived from+ -- the identifier if absent.+ -> [(Int, [String])] -- ^ 'enumValueNames'+ -> CppEnum+makeEnum identifier maybeExtName valueNames =+ CppEnum identifier (extNameOrIdentifier identifier maybeExtName) valueNames mempty mempty++-- | A C++ numeric space with bitwise operations. This is similar to a+-- 'CppEnum', but in addition to the extra operations, this differs in that+-- these values aren't enumerable.+--+-- Additionally, as a kludge for Qtah, a bitspace may have a C++ type+-- ('bitspaceCppTypeIdentifier') separate from its numeric type+-- ('bitspaceType'). Qt bitspaces aren't raw numbers but are instead type-safe+-- @QFlags@ objects that don't implicitly convert from integers, so we need a+-- means to do so manually. Barring general ad-hoc argument and return value+-- conversion support, we allow this as follows: when given a C++ type, then a+-- bitspace may also have a conversion function between the numeric and C+++-- type, in each direction. If a conversion function is present, it will be+-- used for conversions in its respective direction. The C++ type is not a full+-- 'Type', but only an 'Identifier', since additional information is not needed.+-- See 'bitspaceAddCppType'.+data Bitspace = Bitspace+ { bitspaceExtName :: ExtName+ -- ^ The bitspace's external name.+ , bitspaceType :: Type+ -- ^ The C++ type used for bits values. This should be a primitive numeric+ -- type.+ , bitspaceValueNames :: [(Int, [String])]+ -- ^ The numeric values and names of the bitspace values. See+ -- 'enumValueNames'.+ , bitspaceEnum :: Maybe CppEnum+ -- ^ An associated enum, whose values may be converted to values in the+ -- bitspace.+ , bitspaceCppTypeIdentifier :: Maybe Identifier+ -- ^ The optional C++ type for a bitspace.+ , bitspaceToCppValueFn :: Maybe String+ -- ^ The name of a C++ function to convert from 'bitspaceType' to the+ -- bitspace's C++ type.+ , bitspaceFromCppValueFn :: Maybe String+ -- ^ The name of a C++ function to convert from the bitspace's C++ type to+ -- 'bitspaceType'.+ , bitspaceReqs :: Reqs+ -- ^ Requirements for emitting the bindings for a bitspace, i.e. what's+ -- necessary to reference 'bitspaceCppTypeIdentifier',+ -- 'bitspaceFromCppValueFn', and 'bitspaceToCppValueFn'. 'bitspaceType' can+ -- take some numeric types that require includes as well, but you don't need+ -- to list these here.+ , bitspaceAddendum :: Addendum+ -- ^ The bitspace's addendum.+ }++instance Eq Bitspace where+ (==) = (==) `on` bitspaceExtName++instance Show Bitspace where+ show e = concat ["<Bitspace ", show (bitspaceExtName e), " ", show (bitspaceType e), ">"]++instance HasReqs Bitspace where+ getReqs = bitspaceReqs+ setReqs reqs b = b { bitspaceReqs = reqs }++instance HasAddendum Bitspace where+ getAddendum = bitspaceAddendum+ setAddendum addendum bs = bs { bitspaceAddendum = addendum }++-- | Creates a binding for a C++ bitspace.+makeBitspace :: ExtName -- ^ 'bitspaceExtName'+ -> Type -- ^ 'bitspaceType'+ -> [(Int, [String])] -- ^ 'bitspaceValueNames'+ -> Bitspace+makeBitspace extName t valueNames =+ Bitspace extName t valueNames Nothing Nothing Nothing Nothing mempty mempty++-- | Associates an enum with the bitspace. See 'bitspaceEnum'.+bitspaceAddEnum :: CppEnum -> Bitspace -> Bitspace+bitspaceAddEnum enum bitspace = case bitspaceEnum bitspace of+ Just enum' ->+ error $ concat+ ["bitspaceAddEnum: Adding ", show enum, " to ", show bitspace,+ ", but it already has ", show enum', "."]+ Nothing ->+ if bitspaceValueNames bitspace /= enumValueNames enum+ then error $ concat+ ["bitspaceAddEnum: Trying to add ", show enum, " to ", show bitspace,+ ", but the values aren't equal.\nBitspace values: ", show $ bitspaceValueNames bitspace,+ "\n Enum values: ", show $ enumValueNames enum]+ else bitspace { bitspaceEnum = Just enum }++-- | @bitspaceAddCppType cppTypeIdentifier toCppValueFn fromCppValueFn@+-- associates a C++ type (plus optional conversion functions) with a bitspace.+-- At least one conversion should be specified, otherwise adding the C++ type+-- will mean nothing. You should also add use requirements to the bitspace for+-- all of these arguments; see 'HasReqs'.+bitspaceAddCppType :: Identifier -> Maybe String -> Maybe String -> Bitspace -> Bitspace+bitspaceAddCppType cppTypeId toCppValueFnMaybe fromCppValueFnMaybe b =+ case bitspaceCppTypeIdentifier b of+ Just cppTypeId' ->+ error $ concat+ ["bitspaceAddCppType: Adding C++ type ", show cppTypeId,+ " to ", show b, ", but it already has ", show cppTypeId', "."]+ Nothing ->+ b { bitspaceCppTypeIdentifier = Just cppTypeId+ , bitspaceToCppValueFn = toCppValueFnMaybe+ , bitspaceFromCppValueFn = fromCppValueFnMaybe+ }++-- | Whether or not a function may cause side-effects.+--+-- Haskell bindings for pure functions will not be in 'IO', and calls to pure+-- functions will be executed non-strictly. Calls to impure functions will+-- execute in the IO monad.+--+-- Member functions for mutable classes should not be made pure, because it is+-- difficult in general to control when the call will be made.+data Purity = Nonpure -- ^ Side-affects are possible.+ | Pure -- ^ Side-affects will not happen.+ deriving (Eq, Show)++-- | A C++ function declaration.+data Function = Function+ { fnCName :: FnName Identifier+ -- ^ The identifier used to call the function.+ , fnExtName :: ExtName+ -- ^ The function's external name.+ , fnPurity :: Purity+ -- ^ Whether the function is pure.+ , fnParams :: [Type]+ -- ^ The function's parameter types.+ , fnReturn :: Type+ -- ^ The function's return type.+ , fnReqs :: Reqs+ -- ^ Requirements for a binding to call the function.+ , fnAddendum :: Addendum+ -- ^ The function's addendum.+ }++instance Show Function where+ show fn =+ concat ["<Function ", show (fnExtName fn), " ", show (fnCName fn),+ show (fnParams fn), " ", show (fnReturn fn), ">"]++instance HasReqs Function where+ getReqs = fnReqs+ setReqs reqs fn = fn { fnReqs = reqs }++instance HasAddendum Function where+ getAddendum = fnAddendum+ setAddendum addendum fn = fn { fnAddendum = addendum }++-- | Creates a binding for a C++ function.+makeFn :: IsFnName Identifier name+ => name+ -> Maybe ExtName+ -- ^ An optional external name; will be automatically derived from+ -- the identifier if absent.+ -> Purity+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Function+makeFn cName maybeExtName purity paramTypes retType =+ let fnName = toFnName cName+ in Function fnName+ (extNameOrFnIdentifier fnName maybeExtName)+ purity paramTypes retType mempty mempty++-- | A C++ class declaration. A class's external name is automatically combined+-- with the external names of things inside the class, by way of+-- 'HasClassyExtName'.+data Class = Class+ { classIdentifier :: Identifier+ -- ^ The identifier used to refer to the class.+ , classExtName :: ExtName+ -- ^ The class's external name.+ , classSuperclasses :: [Class]+ -- ^ The class's public superclasses.+ , classCtors :: [Ctor]+ -- ^ The class's constructors.+ , classDtorIsPublic :: Bool+ -- ^ Whether the class's destructor has public visibility.+ , classMethods :: [Method]+ -- ^ The class's methods.+ , classConversion :: ClassConversion+ -- ^ Behaviour for converting objects to and from foriegn values.+ , classReqs :: Reqs+ -- ^ Requirements for a 'Type' to reference this class.+ , classAddendum :: Addendum+ -- ^ The class's addendum.+ , classIsMonomorphicSuperclass :: Bool+ -- ^ This is true for classes passed through+ -- 'classSetMonomorphicSuperclass'.+ , classIsSubclassOfMonomorphic :: Bool+ -- ^ This is true for classes passed through+ -- 'classSetSubclassOfMonomorphic'.+ }++instance Eq Class where+ (==) = (==) `on` classIdentifier++instance Show Class where+ show cls =+ concat ["<Class ", show (classExtName cls), " ", show (classIdentifier cls), ">"]++instance HasReqs Class where+ getReqs = classReqs+ setReqs reqs cls = cls { classReqs = reqs }++instance HasAddendum Class where+ getAddendum = classAddendum+ setAddendum addendum cls = cls { classAddendum = addendum }++-- | Creates a binding for a C++ class and its contents.+makeClass :: Identifier+ -> Maybe ExtName+ -- ^ An optional external name; will be automatically derived from the+ -- identifier if absent.+ -> [Class] -- ^ Superclasses.+ -> [Ctor]+ -> [Method]+ -> Class+makeClass identifier maybeExtName supers ctors methods = Class+ { classIdentifier = identifier+ , classExtName = extNameOrIdentifier identifier maybeExtName+ , classSuperclasses = supers+ , classCtors = ctors+ , classDtorIsPublic = True+ , classMethods = methods+ , classConversion = classConversionNone+ , classReqs = mempty+ , classAddendum = mempty+ , classIsMonomorphicSuperclass = False+ , classIsSubclassOfMonomorphic = False+ }++-- | Adds constructors to a class.+classAddCtors :: [Ctor] -> Class -> Class+classAddCtors ctors cls =+ if null ctors then cls else cls { classCtors = classCtors cls ++ ctors }++-- | Marks a class's destructor as private, so that a binding for it won't be+-- generated.+classSetDtorPrivate :: Class -> Class+classSetDtorPrivate cls = cls { classDtorIsPublic = False }++-- | Explicitly marks a class as being monomorphic (i.e. not having any+-- virtual methods or destructors). By default, Hoppy assumes that a class that+-- is derived is also polymorphic, but it can happen that this is not the case.+-- Downcasting with @dynamic_cast@ from such classes is not available. See also+-- 'classSetSubclassOfMonomorphic'.+classSetMonomorphicSuperclass :: Class -> Class+classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }++-- | Marks a class as being derived from some monomorphic superclass. This+-- prevents any downcasting to this class. Generally it is better to use+-- 'classSetMonomorphicSuperclass' on the specific superclasses that are+-- monomorphic, but in cases where this is not possible, this function can be+-- applied to the subclass instead.+classSetSubclassOfMonomorphic :: Class -> Class+classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }++-- | Adds methods to a class.+classAddMethods :: [Method] -> Class -> Class+classAddMethods methods cls =+ if null methods then cls else cls { classMethods = classMethods cls ++ methods }++-- | When a class object is returned from a function or taken as a parameter by+-- value (i.e. with 'TObj'), it will be converted to or from a foreign (non-C++)+-- object. Conversion may also be performed explicitly. This data type+-- describes how to perform those conversions. A class may or may not support+-- conversion, for any particular foreign language; what is said below only+-- applies to classes that are convertible for a language.+--+-- When converting between a C++ value and a foreign value, a pointer to the+-- object is passed between C++ and the foreign language. Then, for each+-- foreign language, a binding author can provide pieces of code in that+-- language to translate between the pointer and a foreign value (usually by+-- invoking the FFI functions generated by Hoppy), and generated bindings will+-- perform these conversions automatically. The code supplied to convert in+-- each direction should leave the original object unchanged (and alive, in case+-- of manual memory management). (Internally, during a function call in either+-- direction, the side that creates a value is in charge of its lifetime, but+-- this is managed by Hoppy.)+--+-- In foreign code, foreign values can be explicitly converted to new C++ (heap)+-- objects, and C++ object pointers can be explicitly converted to foreign+-- values, via special functions generated for the class.+data ClassConversion = ClassConversion+ { classHaskellConversion :: Maybe ClassHaskellConversion+ -- ^ Conversions to and from Haskell.+ }++-- | Encoding parameters for a class that is not encodable or decodable.+classConversionNone :: ClassConversion+classConversionNone = ClassConversion Nothing++-- | Modifies classes' 'ClassEncoding' structures with a given function.+classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class+classModifyConversion f cls = cls { classConversion = f $ classConversion cls }++-- | Controls how conversions between C++ objects and Haskell values happen in+-- Haskell bindings.+data ClassHaskellConversion = ClassHaskellConversion+ { classHaskellConversionType :: Haskell.Generator HsType+ -- ^ Produces the Haskell type that represents a value of the corresponding+ -- C++ class. This generator may add imports, but must not output code or+ -- add exports.+ , classHaskellConversionToCppFn :: Haskell.Generator ()+ -- ^ Produces a Haskell expression that evaluates to a function that takes+ -- an object of the type that 'classHaskellConversionType' generates, and+ -- returns a pointer to a new non-const C++ class object in IO. The+ -- generator must output code and may add imports, but must not add exports.+ , classHaskellConversionFromCppFn :: Haskell.Generator ()+ -- ^ Produces a Haskell expression that evaluates to a function that takes a+ -- pointer to a const C++ class object, and returns an object of the type+ -- that 'classHaskellConversionType' generates, in IO. The generator must+ -- output code and may add imports, but must not add exports.+ }++-- | Things that live inside of a class, and have the class's external name+-- prepended to their own in generated code. With an external name of @\"bar\"@+-- and a class with external name @\"foo\"@, the resulting name will be+-- @\"foo_bar\"@.+class HasClassyExtName a where+ -- | Extracts the external name of the object, without the class name added.+ getClassyExtNameSuffix :: a -> ExtName++ -- | Computes the external name to use in generated code, containing both the+ -- class's and object's external names.+ --+ -- See also 'Foreign.Hoppy.Generator.Language.Haskell.General.toHsMethodName'.+ getClassyExtName :: Class -> a -> ExtName+ getClassyExtName cls x =+ toExtName $ concat [fromExtName $ classExtName cls, "_", fromExtName $ getClassyExtNameSuffix x]++-- | A C++ class constructor declaration.+data Ctor = Ctor+ { ctorExtName :: ExtName+ -- ^ The constructor's external name.+ , ctorParams :: [Type]+ -- ^ The constructor's parameter types.+ }++instance Show Ctor where+ show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]++instance HasClassyExtName Ctor where+ getClassyExtNameSuffix = ctorExtName++-- | Creates a 'Ctor' with full generality.+makeCtor :: ExtName+ -> [Type] -- ^ Parameter types.+ -> Ctor+makeCtor = Ctor++-- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@.+mkCtor :: String+ -> [Type] -- ^ Parameter types.+ -> Ctor+mkCtor = makeCtor . toExtName++-- | A C++ class method declaration.+--+-- Any operator function that can be written as a method may have its binding be+-- written either as part of the associated class or as a separate entity,+-- independently of how the function is declared in C++.+data Method = Method+ { methodImpl :: MethodImpl+ -- ^ The underlying code that the binding calls.+ , methodExtName :: ExtName+ -- ^ The method's external name.+ , methodApplicability :: MethodApplicability+ -- ^ How the method is associated to its class.+ , methodPurity :: Purity+ -- ^ Whether the method is pure.+ , methodParams :: [Type]+ -- ^ The method's parameter types.+ , methodReturn :: Type+ -- ^ The method's return type.+ }++instance Show Method where+ show method =+ concat ["<Method ", show (methodExtName method), " ",+ case methodImpl method of+ RealMethod name -> show name+ FnMethod name -> show name, " ",+ show (methodApplicability method), " ",+ show (methodPurity method), " ",+ show (methodParams method), " ",+ show (methodReturn method), ">"]++instance HasClassyExtName Method where+ getClassyExtNameSuffix = methodExtName++-- | The C++ code to which a 'Method' is bound.+data MethodImpl =+ RealMethod (FnName String)+ -- ^ The 'Method' is bound to an actual class method.+ | FnMethod (FnName Identifier)+ -- ^ The 'Method' is bound to a wrapper function. When wrapping a method+ -- with another function, this is preferrable to just using a 'Function'+ -- binding because a method will still appear to be part of the class in+ -- foreign bindings.+ deriving (Eq, Show)++-- | How a method is associated to its class. A method may be static, const, or+-- neither (a regular method).+data MethodApplicability = MNormal | MStatic | MConst+ deriving (Bounded, Enum, Eq, Show)++-- | Whether or not a method is const.+data Constness = Nonconst | Const+ deriving (Bounded, Enum, Eq, Show)++-- | Returns the opposite constness value.+constNegate :: Constness -> Constness+constNegate Nonconst = Const+constNegate Const = Nonconst++-- | Whether or not a method is static.+data Staticness = Nonstatic | Static+ deriving (Bounded, Enum, Eq, Show)++-- | Returns the constness of a method, based on its 'methodApplicability'.+methodConst :: Method -> Constness+methodConst method = case methodApplicability method of+ MConst -> Const+ _ -> Nonconst++-- | Returns the staticness of a method, based on its 'methodApplicability'.+methodStatic :: Method -> Staticness+methodStatic method = case methodApplicability method of+ MStatic -> Static+ _ -> Nonstatic++-- | Creates a 'Method' with full generality and manual name specification.+makeMethod :: IsFnName String name+ => name -- ^ The C++ name of the method.+ -> ExtName -- ^ The external name of the method.+ -> MethodApplicability+ -> Purity+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+makeMethod name = Method $ RealMethod $ toFnName name++-- | Creates a 'Method' that is in fact backed by a C++ non-member function (a+-- la 'makeFn'), but appears to be a regular method. This is useful for+-- wrapping a method on the C++ side when its arguments aren't right for binding+-- directly.+--+-- A @this@ pointer parameter is __not__ automatically added to the parameter+-- list for non-static methods created with @makeFnMethod@.+makeFnMethod :: IsFnName Identifier name+ => name+ -> String+ -> MethodApplicability+ -> Purity+ -> [Type]+ -> Type+ -> Method+makeFnMethod cName foreignName = Method (FnMethod $ toFnName cName) (toExtName foreignName)++-- | This function is internal.+--+-- Creates a method similar to 'makeMethod', but with automatic naming. The+-- method's external name will be @className ++ \"_\" ++ cppMethodName@. If the+-- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded+-- to the class name.+--+-- For creating multiple bindings to a method, see 'makeMethod''.+makeMethod' :: IsFnName String name+ => name -- ^ The C++ name of the method.+ -> MethodApplicability+ -> Purity+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+makeMethod' name = makeMethod''' (toFnName name) Nothing++-- | This function is internal.+--+-- Creates a method similar to 'makeMethod'', but with an custom string that+-- will be appended to the class name to form the method's external name. This+-- is useful for making multiple bindings to a method, e.g. for overloading and+-- optional arguments.+makeMethod'' :: IsFnName String name+ => name -- ^ The C++ name of the method.+ -> String -- ^ A foreign name for the method.+ -> MethodApplicability+ -> Purity+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName++-- | The implementation of 'makeMethod'' and 'makeMethod'''.+makeMethod''' :: FnName String -- ^ The C++ name of the method.+ -> Maybe String -- ^ A foreign name for the method.+ -> MethodApplicability+ -> Purity+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+makeMethod''' (FnName "") maybeForeignName _ _ paramTypes retType =+ error $ concat ["makeMethod''': Given an empty method name with foreign name ",+ show maybeForeignName, ", parameter types ", show paramTypes,+ ", and return type ", show retType, "."]+makeMethod''' name (Just "") _ _ paramTypes retType =+ error $ concat ["makeMethod''': Given an empty foreign name with method ",+ show name, ", parameter types ", show paramTypes, ", and return type ",+ show retType, "."]+makeMethod''' name maybeForeignName appl purity paramTypes retType =+ let extName = flip fromMaybe (toExtName <$> maybeForeignName) $ case name of+ FnName s -> toExtName s+ FnOp op -> operatorPreferredExtName op+ in makeMethod name extName appl purity paramTypes retType++-- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose+-- external name is @class_methodName@. If the name is an operator, then the+-- 'operatorPreferredExtName' will be used in the external name.+--+-- For creating multiple bindings to a method, see 'mkMethod''.+mkMethod :: IsFnName String name+ => name -- ^ The C++ name of the method.+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+mkMethod name = makeMethod' name MNormal Nonpure++-- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and+-- whose external name is @class_methodName@. This enables multiple 'Method's+-- with different foreign names (and hence different external names) to bind to+-- the same method, e.g. to make use of optional arguments or overloading. See+-- 'mkMethod' for a simpler form.+mkMethod' :: IsFnName String name+ => name -- ^ The C++ name of the method.+ -> String -- ^ A foreign name for the method.+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Method+mkMethod' cName foreignName = makeMethod'' cName foreignName MNormal Nonpure++-- | Same as 'mkMethod', but returns an 'MConst' method.+mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> Method+mkConstMethod name = makeMethod' name MConst Nonpure++-- | Same as 'mkMethod'', but returns an 'MConst' method.+mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method+mkConstMethod' cName foreignName = makeMethod'' cName foreignName MConst Nonpure++-- | Same as 'mkMethod', but returns an 'MStatic' method.+mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> Method+mkStaticMethod name = makeMethod' name MStatic Nonpure++-- | Same as 'mkMethod'', but returns an 'MStatic' method.+mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method+mkStaticMethod' cName foreignName = makeMethod'' cName foreignName MStatic Nonpure++-- | Used in conjunction with 'mkProp' and friends, this creates a list of+-- 'Method's for binding to getter/setter method pairs. This can be used as+-- follows:+--+-- > myClass =+-- > makeClass ... $+-- > [ methods... ] +++-- > mkProps+-- > [ mkBoolIsProp myClass "adjustable"+-- > , mkProp myClass "maxWidth" TInt+-- > ]+mkProps :: [[Method]] -> [Method]+mkProps = concat++-- | Creates a getter/setter binding pair for methods:+--+-- > T getFoo() const+-- > void setFoo(T)+mkProp :: String -> Type -> [Method]+mkProp name t =+ let c:cs = name+ setName = 's' : 'e' : 't' : toUpper c : cs+ in [ mkConstMethod name [] t+ , mkMethod setName [t] TVoid+ ]++-- | Creates a getter/setter binding pair for static methods:+--+-- > static T getFoo() const+-- > static void setFoo(T)+mkStaticProp :: String -> Type -> [Method]+mkStaticProp name t =+ let c:cs = name+ setName = 's' : 'e' : 't' : toUpper c : cs+ in [ mkStaticMethod name [] t+ , mkStaticMethod setName [t] TVoid+ ]++-- | Creates a getter/setter binding pair for boolean methods, where the getter+-- is prefixed with @is@:+--+-- > bool isFoo() const+-- > void setFoo(bool)+mkBoolIsProp :: String -> [Method]+mkBoolIsProp name =+ let c:cs = name+ name' = toUpper c : cs+ isName = 'i':'s':name'+ setName = 's':'e':'t':name'+ in [ mkConstMethod isName [] TBool+ , mkMethod setName [TBool] TVoid+ ]++-- | Creates a getter/setter binding pair for boolean methods, where the getter+-- is prefixed with @has@:+--+-- > bool hasFoo() const+-- > void setFoo(bool)+mkBoolHasProp :: String -> [Method]+mkBoolHasProp name =+ let c:cs = name+ name' = toUpper c : cs+ hasName = 'h':'a':'s':name'+ setName = 's':'e':'t':name'+ in [ mkConstMethod hasName [] TBool+ , mkMethod setName [TBool] TVoid+ ]++-- | A non-C++ function that can be invoked via a C++ functor.+data Callback = Callback+ { callbackExtName :: ExtName+ -- ^ The callback's external name.+ , callbackParams :: [Type]+ -- ^ The callback's parameter types.+ , callbackReturn :: Type+ -- ^ The callback's return type.+ , callbackReqs :: Reqs+ -- ^ Requirements for the callback.+ , callbackAddendum :: Addendum+ -- ^ The callback's addendum.+ }++instance Eq Callback where+ (==) = (==) `on` callbackExtName++instance Show Callback where+ show cb =+ concat ["<Callback ", show (callbackExtName cb), " ", show (callbackParams cb), " ",+ show (callbackReturn cb)]++instance HasReqs Callback where+ getReqs = callbackReqs+ setReqs reqs cb = cb { callbackReqs = reqs }++instance HasAddendum Callback where+ getAddendum = callbackAddendum+ setAddendum addendum cb = cb { callbackAddendum = addendum }++-- | Creates a binding for constructing callbacks into foreign code.+makeCallback :: ExtName+ -> [Type] -- ^ Parameter types.+ -> Type -- ^ Return type.+ -> Callback+makeCallback extName paramTypes retType = Callback extName paramTypes retType mempty mempty++-- | Creates a 'TFn' from a callback's parameter and return types.+callbackToTFn :: Callback -> Type+callbackToTFn = TFn <$> callbackParams <*> callbackReturn++-- | A collection of imports for a Haskell module. This is a monoid: import+-- Statements are merged to give the union of imported bindings.+--+-- This structure supports two specific types of imports:+-- - @import Foo (...)@+-- - @import qualified Foo as Bar@+-- Imports with @as@ but without @qualified@, and @qualified@ imports with a+-- spec list, are not supported. This satisfies the needs of the code+-- generator, and keeps the merging logic simple.+newtype HsImportSet = HsImportSet+ { getHsImportSet :: M.Map HsImportKey HsImportSpecs+ -- ^ Returns the import set's internal map from module names to imported+ -- bindings.+ } deriving (Show)++instance Monoid HsImportSet where+ mempty = HsImportSet M.empty++ mappend (HsImportSet m) (HsImportSet m') =+ HsImportSet $ M.unionWith mergeImportSpecs m m'++ mconcat sets =+ HsImportSet $ M.unionsWith mergeImportSpecs $ map getHsImportSet sets++-- | A literal piece of code that will be inserted into a generated source file+-- after the regular binding glue. The 'Monoid' instance concatenates code+-- (actions).+data Addendum = Addendum+ { addendumHaskell :: Haskell.Generator ()+ -- ^ Code to be output into the Haskell binding. May also add imports and+ -- exports.+ }++instance Monoid Addendum where+ mempty = Addendum $ return ()+ mappend (Addendum a) (Addendum b) = Addendum $ a >> b++-- | A typeclass for types that have an addendum.+class HasAddendum a where+ {-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-}++ -- | Returns an object's addendum.+ getAddendum :: a -> Addendum++ -- | Replaces and object's addendum with another.+ setAddendum :: Addendum -> a -> a+ setAddendum addendum = modifyAddendum $ const addendum++ -- | Modified an object's addendum.+ modifyAddendum :: (Addendum -> Addendum) -> a -> a+ modifyAddendum f x = setAddendum (f $ getAddendum x) x++-- | Adds a Haskell addendum to an object.+addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a+addAddendumHaskell gen = modifyAddendum $ \addendum ->+ addendum `mappend` mempty { addendumHaskell = gen }++-- | Constructor for an import set.+makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet+makeHsImportSet = HsImportSet++-- | Sets all of the import specifications in an import set to be+-- @{-#SOURCE#-}@ imports.+hsImportSetMakeSource :: HsImportSet -> HsImportSet+hsImportSetMakeSource (HsImportSet m) =+ HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m++-- | A Haskell module name.+type HsModuleName = String++-- | References an occurrence of an import statement, under which bindings can+-- be imported. Only imported specs under equal 'HsImportKey's may be merged.+data HsImportKey = HsImportKey+ { hsImportModule :: HsModuleName+ , hsImportQualifiedName :: Maybe HsModuleName+ } deriving (Eq, Ord, Show)++-- | A specification of bindings to import from a module. If 'Nothing', then+-- the entire module is imported. If @'Just' 'M.empty'@, then only instances+-- are imported.+data HsImportSpecs = HsImportSpecs+ { getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal)+ , hsImportSource :: Bool+ } deriving (Show)++-- | Combines two 'HsImportSpecs's into one that imports everything that the two+-- did separately.+mergeImportSpecs :: HsImportSpecs -> HsImportSpecs -> HsImportSpecs+mergeImportSpecs (HsImportSpecs mm s) (HsImportSpecs mm' s') =+ HsImportSpecs (liftM2 mergeMaps mm mm') (s || s')+ where mergeMaps = M.unionWith mergeValues+ mergeValues v v' = case (v, v') of+ (HsImportValAll, _) -> HsImportValAll+ (_, HsImportValAll) -> HsImportValAll+ (HsImportValSome s, HsImportValSome s') -> HsImportValSome $ s ++ s'+ (x@(HsImportValSome _), _) -> x+ (_, x@(HsImportValSome _)) -> x+ (HsImportVal, HsImportVal) -> HsImportVal++-- | An identifier that can be imported from a module. Symbols may be used here+-- when surrounded by parentheses. Examples are @\"fmap\"@ and @\"(++)\"@.+type HsImportName = String++-- | Specifies how a name is imported.+data HsImportVal =+ HsImportVal+ -- ^ The name is imported, and nothing underneath it is.+ | HsImportValSome [HsImportName]+ -- ^ The name is imported, as are specific names underneath it. This is a+ -- @X (a, b, c)@ import.+ | HsImportValAll+ -- ^ The name is imported, along with all names underneath it. This is a @X+ -- (..)@ import.+ deriving (Show)++-- | An import for the entire contents of a Haskell module.+hsWholeModuleImport :: HsModuleName -> HsImportSet+hsWholeModuleImport moduleName =+ HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+ HsImportSpecs Nothing False++-- | A qualified import of a Haskell module.+hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet+hsQualifiedImport moduleName qualifiedName =+ HsImportSet $ M.singleton (HsImportKey moduleName $ Just qualifiedName) $+ HsImportSpecs Nothing False++-- | An import of a single name from a Haskell module.+hsImport1 :: HsModuleName -> HsImportName -> HsImportSet+hsImport1 moduleName valueName = hsImport1' moduleName valueName HsImportVal++-- | A detailed import of a single name from a Haskell module.+hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet+hsImport1' moduleName valueName valueType =+ HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+ HsImportSpecs (Just $ M.singleton valueName valueType) False++-- | An import of multiple names from a Haskell module.+hsImports :: HsModuleName -> [HsImportName] -> HsImportSet+hsImports moduleName names =+ hsImports' moduleName $ map (\name -> (name, HsImportVal)) names++-- | A detailed import of multiple names from a Haskell module.+hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet+hsImports' moduleName values =+ HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+ HsImportSpecs (Just $ M.fromList values) False++-- | Imports "Data.Bits" qualified as @HoppyDB@.+hsImportForBits :: HsImportSet+hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB"++-- | Imports "Data.Int" qualified as @HoppyDI@.+hsImportForInt :: HsImportSet+hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI"++-- | Imports "Data.Word" qualified as @HoppyDW@.+hsImportForWord :: HsImportSet+hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW"++-- | Imports "Foreign" qualified as @HoppyF@.+hsImportForForeign :: HsImportSet+hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF"++-- | Imports "Foreign.C" qualified as @HoppyFC@.+hsImportForForeignC :: HsImportSet+hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC"++-- | Imports "Prelude" qualified as @HoppyP@.+hsImportForPrelude :: HsImportSet+hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP"++-- | Imports "Foreign.Hoppy.Runtime" qualified as @HoppyFHR@.+hsImportForRuntime :: HsImportSet+hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR"++-- | Imports "System.Posix.Types" qualified as @HoppySPT@.+hsImportForSystemPosixTypes :: HsImportSet+hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT"++-- | Imports "System.IO.Unsafe" qualified as @HoppySIU@.+hsImportForUnsafeIO :: HsImportSet+hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU"++-- | Returns an error message indicating that 'TObjToHeap' is used where data is+-- going from a foreign langauge into C++.+tObjToHeapWrongDirectionErrorMsg :: Maybe String -> Class -> String+tObjToHeapWrongDirectionErrorMsg maybeCaller cls =+ concat [maybe "" (++ ": ") maybeCaller,+ "(TObjToHeap ", show cls, ") cannot be passed into C++",+ maybe "" (const ".") maybeCaller]
+ src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs view
@@ -0,0 +1,96 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Bindings for common class operations, such as copy construction.+module Foreign.Hoppy.Generator.Spec.ClassFeature (+ ClassFeature (..),+ classAddFeatures,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mempty)+#endif+import Foreign.Hoppy.Generator.Spec++-- | Sets of functionality that can be stamped onto a class with+-- 'classAddFeatures'.+data ClassFeature =+ Assignable+ -- ^ Provides the assignment operator, @Foo& Foo::operator=(const Foo&)@.+ | Comparable+ -- ^ Provides operators @<@, @<=@, @>@, @>=@, for example @bool+ -- Foo::operator<(const Foo&)@. This feature does not automatically include+ -- 'Equatable'.+ | Copyable+ -- ^ Provides copy construction, @Foo::Foo(const Foo&)@.+ | Equatable+ -- ^ Provides @operator==@ and @operator!=@, for example @bool+ -- Foo::operator==(const Foo&)@.+ deriving (Eq, Show)++featureContents :: ClassFeature -> Class -> ([Ctor], [Method], Reqs)+featureContents feature cls = case feature of+ Assignable -> assignableContents cls+ Comparable -> comparableContents cls+ Copyable -> copyableContents cls+ Equatable -> equatableContents cls++assignableContents :: Class -> ([Ctor], [Method], Reqs)+assignableContents cls =+ ([],+ [ mkMethod OpAssign [TRef $ TConst $ TObj cls] $ TRef $ TObj cls+ ],+ mempty)++comparableContents :: Class -> ([Ctor], [Method], Reqs)+comparableContents cls =+ ([],+ [ mkConstMethod OpLt [TRef $ TConst $ TObj cls] TBool+ , mkConstMethod OpLe [TRef $ TConst $ TObj cls] TBool+ , mkConstMethod OpGt [TRef $ TConst $ TObj cls] TBool+ , mkConstMethod OpGe [TRef $ TConst $ TObj cls] TBool+ ],+ mempty)++copyableContents :: Class -> ([Ctor], [Method], Reqs)+copyableContents cls =+ ([ mkCtor "newCopy" [TObj cls]+ ],+ [],+ mempty)++equatableContents :: Class -> ([Ctor], [Method], Reqs)+equatableContents cls =+ ([],+ [ mkConstMethod OpEq [TObj cls] TBool+ , mkConstMethod OpNe [TObj cls] TBool+ ],+ mempty)++-- | Adds the contents of a feature to a class. Does not check for overlap with+-- existing class contents.+classAddFeatures :: [ClassFeature] -> Class -> Class+classAddFeatures features cls =+ foldr (\feature cls' ->+ let (ctors, methods, reqs) = featureContents feature cls'+ in addReqs reqs $+ classAddCtors ctors $+ classAddMethods methods cls')+ cls+ features
+ src/Foreign/Hoppy/Generator/Version.hs view
@@ -0,0 +1,101 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++-- | Utilities for conditional compilation of parts of interfaces.+--+-- This module provides wrappers around 'Maybe' and 'catMaybes' so that you can+-- write code such as:+--+-- > myClass =+-- > makeClass ...+-- > [ ...ctors... ] $+-- > collect+-- > [ just $ mkMethod "foo" ...+-- > , test (apiVersion >= [1, 2]) $ mkMethod "bar" ...+-- > , test featureBaz $ mkMethod "baz" ...+-- > ]+module Foreign.Hoppy.Generator.Version (+ -- * General filtering+ Filtered,+ collect,+ none,+ just,+ test,+ -- * C++ Standard version+ CppVersion (..),+ defaultCppVersion,+ activeCppVersion,+ ) where++import Data.Maybe (catMaybes)+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)++-- | Placeholder 'Maybe'-like type that may be more general in the future.+type Filtered = Maybe++-- | Filters a list of 'Filtered' values down to the elements that are actually+-- present.+collect :: [Filtered a] -> [a]+collect = catMaybes++-- | A 'Filtered' value that is always absent.+none :: Filtered a+none = Nothing++-- | Returns a 'Filtered' value that is always present.+just :: a -> Filtered a+just = Just++-- | Returns a 'Filtered' value that is only present if the boolean is true.+test :: Bool -> a -> Filtered a+test True = Just+test False = const Nothing++-- | Versions of the C++ standard.+data CppVersion =+ Cpp1998+ | Cpp2011+ | Cpp2014+ deriving (Bounded, Enum, Eq, Ord, Show)++-- | The 'CppVersion' chosen when one is not explicitly requested. This is+-- 'Cpp2011'.+defaultCppVersion :: CppVersion+defaultCppVersion = Cpp2011++-- | The active version of the C++ standard. This looks to the @HOPPY_CPP_STD@+-- environment variable, and accepts the values @c++98@, @c++11@, and @c++14@,+-- which map to the corresponding 'CppVersion' values. If a value other than+-- these is set, then a warning is printed and the default is used. If no value+-- is set, the default is used.+--+-- This uses 'unsafePerformIO' internally and won't cope with a changing+-- environment.+activeCppVersion :: CppVersion+{-# NOINLINE activeCppVersion #-}+activeCppVersion = unsafePerformIO $ do+ strMaybe <- lookupEnv "HOPPY_CPP_STD"+ case strMaybe of+ Nothing -> return defaultCppVersion+ Just "" -> return defaultCppVersion+ Just "c++98" -> return Cpp1998+ Just "c++11" -> return Cpp2011+ Just "c++14" -> return Cpp2014+ Just str -> do hPutStrLn stderr $ "Warning: Invalid HOPPY_CPP_STD value " ++ show str ++ "."+ return defaultCppVersion