diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU 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. + + + Copyright (C) + + 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 . + +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 +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,19 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +import Distribution.Simple +main = defaultMain diff --git a/hoppy-generator.cabal b/hoppy-generator.cabal new file mode 100644 --- /dev/null +++ b/hoppy-generator.cabal @@ -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 +maintainer: Bryan Gardiner +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 diff --git a/src/Foreign/Hoppy/Generator/Common.hs b/src/Foreign/Hoppy/Generator/Common.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Common.hs @@ -0,0 +1,93 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 diff --git a/src/Foreign/Hoppy/Generator/Common/Consume.hs b/src/Foreign/Hoppy/Generator/Common/Consume.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Common/Consume.hs @@ -0,0 +1,84 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp.hs b/src/Foreign/Hoppy/Generator/Language/Cpp.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Cpp.hs @@ -0,0 +1,266 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 +-- @\ \@, where @\@ is the given name, and @\@ 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 diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs @@ -0,0 +1,616 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 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(f_));\n" + say " if (releaseRelease_) {\n" + say " release_(reinterpret_cast(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 diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell.hs b/src/Foreign/Hoppy/Generator/Language/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Haskell.hs @@ -0,0 +1,674 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 +-- > +-- > ... +-- > +-- > in +-- > +-- +-- 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 diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot b/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Haskell.hs-boot @@ -0,0 +1,47 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs @@ -0,0 +1,1107 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 diff --git a/src/Foreign/Hoppy/Generator/Main.hs b/src/Foreign/Hoppy/Generator/Main.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Main.hs @@ -0,0 +1,220 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 \@:__ Generates C++ bindings in the given directory. +-- +-- - __@--gen-hs \@:__ 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 Generate C++ bindings in a directory." + , " --gen-hs 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 diff --git a/src/Foreign/Hoppy/Generator/Spec.hs b/src/Foreign/Hoppy/Generator/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec.hs @@ -0,0 +1,1796 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# LANGUAGE CPP #-} + +-- | The primary data types for specifying C++ interfaces. +-- +-- 'Show' instances in this module produce strings of the form @\"\\"@. 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 [""] + +-- | 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 [""] + +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 [""] + show (FnOp op) = concat [""] + +-- | 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 $ ""]) $ + 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 [""] + +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 [""] + +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 [""] + +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 [""] + +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 [""] + +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 [""] + +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 [" 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 [" [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] diff --git a/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs @@ -0,0 +1,96 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +{-# 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 diff --git a/src/Foreign/Hoppy/Generator/Version.hs b/src/Foreign/Hoppy/Generator/Version.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Version.hs @@ -0,0 +1,101 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2015-2016 Bryan Gardiner +-- +-- 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 . + +-- | 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