From e34407b0080fa5c7176522b42783ad3c55a0f722 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 25 Feb 2019 20:35:29 -0500 Subject: cabal file and license --- LICENSE | 674 ++++++++++++++++++++++++++++++++++++++ c2haskell.hs | 955 ----------------------------------------------------- monkeypatch.cabal | 69 ++++ monkeypatch.hs | 956 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1699 insertions(+), 955 deletions(-) create mode 100644 LICENSE delete mode 100644 c2haskell.hs create mode 100644 monkeypatch.cabal create mode 100644 monkeypatch.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/c2haskell.hs b/c2haskell.hs deleted file mode 100644 index 8b1d843..0000000 --- a/c2haskell.hs +++ /dev/null @@ -1,955 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -import Control.Arrow (left) -import Data.Generics.Aliases -import Data.Generics.Schemes --- import Debug.Trace -import Control.Monad -import qualified Data.ByteString.Char8 as B -import Data.Char -import Data.Data -import Data.List -import qualified Data.IntMap as IntMap - ;import Data.IntMap (IntMap) -import qualified Data.Map as Map - ;import Data.Map (Map) -import Data.Maybe -import qualified Data.Set as Set - ;import Data.Set (Set) -import Language.C.Data.Ident as C -import Language.C as C hiding (prettyUsingInclude) -import qualified Language.C as C -import Language.C.System.GCC -import Language.C.System.Preprocess -import Language.C.Data.Position -import Language.Haskell.Exts.Parser as HS -import Language.Haskell.Exts.Pretty as HS -import Language.Haskell.Exts.Syntax as HS -import Language.Haskell.TH -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Syntax as TH -import System.Directory -import System.Environment -import System.IO -import System.Process -import System.Exit -import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), - (<+>)) -import Text.Show.Pretty - -trace _ = id - --- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. --- --- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful --- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers. -prettyUsingInclude :: IncludeStack -> CTranslUnit -> Doc -prettyUsingInclude incs (CTranslUnit edecls _) = - vcat (map (either includeHeader pretty) $ sortBy sysfst mappedDecls) - where - (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls - tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((includeTopLevel incs . posFile . posOf) edecl) - | otherwise = Right edecl - addDecl decl@(Left headerRef) (headerSet, ds) - | null headerRef || Set.member headerRef headerSet - = (headerSet, ds) - | otherwise = (Set.insert headerRef headerSet, decl : ds) - addDecl decl (headerSet,ds) = (headerSet, decl : ds) - - includeHeader hFile = text "#include" <+> text hFile - isHeaderFile = (".h" `isSuffixOf`) - - sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT - sysfst _ _ = Prelude.LT - -includeTopLevel (IncludeStack incs) f = do - stacks <- maybeToList $ Map.lookup f incs - stack <- take 1 stacks - top <- take 1 $ drop 4 $ reverse (f:stack) - if take 1 top == "/" - then let ws = groupBy (\_ c -> c /='/') top - (xs,ys) = break (=="/include") ws - ys' = drop 1 ys - in if not (null ys') then '<': drop 1 (concat ys') ++ ">" - else '"':top++"\"" - else '"':top ++"\"" - -specs :: CExternalDeclaration a -> [CDeclarationSpecifier a] -specs (CFDefExt (CFunDef ss _ _ _ _)) = ss -specs (CDeclExt (CDecl ss _ _)) = ss -specs _ = [] - -declrSym :: CDeclarator t -> Maybe Ident -declrSym (CDeclr m _ _ _ _) = m - --- Used by update to add a symbols to the database. -sym :: CExternalDeclaration a -> [Maybe Ident] -sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ] -sym (CDeclExt (CDecl specs ms _)) = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m -sym _ = [] - -isStatic :: CDeclarationSpecifier a -> Bool -isStatic (CStorageSpec (CStatic _)) = True -isStatic _ = False - -capitalize :: String -> String -capitalize xs = concatMap (cap . drop 1) gs - where - gs = groupBy (\a b -> b/='_') $ '_':xs - cap (c:cs) = toUpper c : cs - -transField :: CDeclaration t -> [(TH.Name, TH.Bang, TH.Type)] -transField (CDecl [CTypeSpec (CTypeDef ctyp _)] vars _) - = do - let typname = mkName . capitalize . identToString $ ctyp - (var,Nothing,Nothing) <- vars - CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var - let fieldName = mkName $ identToString fident - ftyp = case ptrdeclr of - [] -> ConT typname - [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) - [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] -transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) - | Just typname <- mkName . capitalize . identToString <$> mctyp - = do - (var,Nothing,Nothing) <- vars - CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var - let fieldName = mkName $ identToString fident - ftyp = case ptrdeclr of - [] -> ConT typname - [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) - [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] - - -transField _ = [] - -transpile (CDeclExt (CDecl [ CTypeSpec (CSUType - (CStruct CStructTag mbIdent (Just fields) [] _) - _) ] - [] - _) ) - | Just struct_name <- capitalize . identToString <$> mbIdent - , let typ = mkName struct_name - = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] [] - where fs = fields >>= transField - -transpile _ = Nothing - - -isHeaderDecl :: CNode a => a -> Bool -isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode - --- bar :: CExternalDeclaration NodeInfo -> () --- bar (CDeclExt (CDecl xs [] (NodeInfo pos poslen name))) = () - -data SymbolInformation c = SymbolInformation - { symbolLocal :: Bool - , symbolStatic :: Bool - , symbolSource :: c - } - deriving (Eq,Ord,Show,Functor) - -symbolInformation = SymbolInformation - { symbolLocal = False - , symbolStatic = False - , symbolSource = mempty - } - -data Transpile c = Transpile - { syms :: Map String (SymbolInformation c) - } - -initTranspile = Transpile - { syms = Map.empty - } - --- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation -grokSymbol d k msi = - let si = fromMaybe symbolInformation msi - in Just $ si - { symbolLocal = symbolLocal si || not (isHeaderDecl d) - , symbolStatic = symbolStatic si || any isStatic (specs d) - , symbolSource = d : symbolSource si - } - -update :: CExternalDeclaration NodeInfo - -> Transpile [CExternalDeclaration NodeInfo] - -> Transpile [CExternalDeclaration NodeInfo] -update d transpile = transpile - { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile) - $ map (maybe "" identToString) $ sym d - } - -data FunctionSignature t = FunctionSignature - { funReturnType :: t - , funArgTypes :: [t] - } - -hsMkName :: String -> HS.QName () -hsMkName str = HS.UnQual () (foo () str) - where - foo = HS.Ident -- alternative: HS.Symbol - - -notKnown "Word8" = False -notKnown "Word16" = False -notKnown "Word32" = False -notKnown "Word64" = False -notKnown "Int8" = False -notKnown "Int16" = False -notKnown "Int32" = False -notKnown "Int64" = False -notKnown "Bool" = False -notKnown "Word" = False -notKnown "Int" = False -notKnown "Char" = False -notKnown "()" = False -notKnown _ = True - -hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String] -hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "size_t" _ _) _)) = [ Right "Word"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _)) = [ Right "Word8"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _)) = [ Right "Word16"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _)) = [ Right "Word32"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint64_t" _ _) _)) = [ Right "Word64"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int8_t" _ _) _)) = [ Right "Int8"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int16_t" _ _) _)) = [ Right "Int16"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int32_t" _ _) _)) = [ Right "Int32"] -hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int64_t" _ _) _)) = [ Right "Int64"] -hsTypeSpec (CTypeSpec (CTypeDef ctyp _)) = [ Left ctyp ] -hsTypeSpec (CTypeSpec (CBoolType _)) = [ Right "Bool"] -hsTypeSpec (CTypeSpec (CIntType _)) = [ Right "Int"] -hsTypeSpec (CTypeSpec (CCharType _)) = [ Right "Char"] -hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp - -hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ [] -hsTypeSpec _ = [] - - --- fieldInfo :: CDeclarator b -> (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) --- fieldInfo var = (Just var,Nothing,Nothing) -fieldInfo :: (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) -> [CDeclarator b] -fieldInfo (Just var,_,_) = [var] -fieldInfo _ = [] - --- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()] --- recursive for function signatures. -hsTransField :: Show b => - [CDeclarationSpecifier b] -- c structure name - -- -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations - -> [CDeclarator b] -- c variable declarations - -> [(String{-field name-}, HS.Type () {- haskell type -}) ] -hsTransField ctyps vars - = do - typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps) - trace ("typname="++show typname) $ return () - -- (var,Nothing,Nothing) <- vars - var <- vars - trace ("var="++show var) $ return () - -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var - let CDeclr mfident ptrdeclr Nothing [] _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c) - -- let CDeclr mfident ptrdeclr _ _ _ = var - trace ("fident="++show mfident) $ return () - trace ("ptrdeclr="++show ptrdeclr) $ return () - let btyp = HS.TyCon () typname - grok bs b = case bs of - [] -> b - (CPtrDeclr [] _:cs) -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) - CFunDeclr (Right (args,flg)) attrs _:p -> - let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs $ concatMap fieldInfo as) args - b0 = case p of - CPtrDeclr [] _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) - [] -> b - in foldr (HS.TyFun ()) b0 ts - _ -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr) - ftyp = grok ptrdeclr btyp - fieldName = maybe ("_") identToString mfident - [ ( fieldName, ftyp ) ] -{- -transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) - | Just typname <- mkName . capitalize . identToString <$> mctyp - = do - (var,Nothing,Nothing) <- vars - CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var - let fieldName = mkName $ identToString fident - ftyp = case ptrdeclr of - [] -> ConT typname - [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) - [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] -hsTransField _ _ = [] --} - -extractType (HS.TypeDecl _ _ ftyp) = ftyp -extractType (HS.TypeSig _ _ ftyp) = ftyp -extractType _ = TyCon () (Special () (UnitCon ())) - -{- -hsTransFieldExt :: Show b => - [CDeclarationSpecifier b] - -> [(Maybe (CDeclarator b), Maybe (CInitializer b), - Maybe (CExpression b))] - -> [Decl ()] --} -hsTransFieldExt :: Show b => - [CDeclarationSpecifier b] -> [CDeclarator b] -> [Decl ()] -hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ]) - $ hsTransField rs as - -hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ]) - $ hsTransField rs as - -types (HS.TypeDecl _ _ typ) = primtypes typ - -primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b -primtypes t = [t] - -tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str -tname _ = "_unkonwn" - -getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x -getPtrType _ = Nothing - --- pointers :: [HS.Decl ()] -> [String] -pointers :: [HS.Type l] -> [HS.Type l] -pointers decls = do - d <- decls - maybeToList $ getPtrType d - -unpointer t = case getPtrType t of - Nothing -> t - Just t' -> t' - --- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()] -sig :: CExternalDeclaration NodeInfo -> [Decl ()] -sig = sigf hsTransFieldExt - --- • Couldn't match expected type ‘CDerivedDeclarator a -> (Maybe (CDeclarator a), Maybe (CInitializer a), Maybe (CExpression a))’ --- with actual type ‘(CDerivedDeclarator NodeInfo -> Maybe (CDeclarator NodeInfo), Maybe a0, Maybe a1)’ - - --- CDeclr (Maybe Ident) --- [CDerivedDeclarator a] --- (Maybe (CStringLiteral a)) --- [CAttribute a] --- a --- sigf f d@(CDeclExt (CDecl rs ((Just (CDeclr i x j k l),b,c):zs) n)) = f rs $ map (\v -> (Just (CDeclr Nothing [v] Nothing [] n),Nothing,Nothing)) x -sigf :: ([CDeclarationSpecifier b] -> [CDeclarator b] -> p) -> CExternalDeclaration b -> p -sigf f (CDeclExt (CDecl rs as _)) = f rs $ concatMap fieldInfo as -sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [cdeclr] -{- -sigf f d = f (getReturnValue d) $ do - arg <- getArgList d - let node (CDeclExt (CDecl rs as n)) = n - node (CFDefExt (CFunDef rs cdeclr [] bdy n)) = n - s = listToMaybe $ catMaybes $ sym d - return $ CDeclr s [arg] Nothing [] (node d) --} - -body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy -body0 _ = Nothing - -body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy -body _ = [] - -data SideEffect = PointerWrite | FunctionCall - -calls :: Data t => t -> [CExpression NodeInfo] -calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] })) - -mutations1 e@(CAssign {}) = [e] -mutations1 e@(CUnary CPreIncOp _ _) = [e] -mutations1 e@(CUnary CPreDecOp _ _) = [e] -mutations1 e@(CUnary CPostIncOp _ _) = [e] -mutations1 e@(CUnary CPostDecOp _ _) = [e] -mutations1 _ = [] - -mutations :: Data t => t -> [CExpression NodeInfo] -mutations = everything (++) (mkQ [] mutations1) - - --- gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a --- --- gfoldl app con --- --- does is to turn such a value into --- --- con C `app` x_1 `app` x_2 ... `app` x_n - - -commented :: String -> String -commented s = unlines $ map ("-- " ++) (lines s) - -data C2HaskellOptions = C2HaskellOptions - { selectFunction :: Maybe String - , prettyC :: Bool - , prettyTree :: Bool - , verbose :: Bool - , preprocess :: Bool - } - -defopts = C2HaskellOptions - { selectFunction = Nothing - , prettyC = False - , prettyTree = False - , verbose = False - , preprocess = False - } - -parseOptions [] opts = opts -parseOptions ("-f":f:args) opts = parseOptions args opts - { selectFunction = Just f - } -parseOptions ("-t":args) opts = parseOptions args opts - { prettyTree = True - } -parseOptions ("-p":args) opts = parseOptions args opts - { prettyC = True - } -parseOptions ("--cpp":args) opts = parseOptions args opts - { preprocess = True - } -parseOptions ("-v":args) opts = parseOptions args opts - { verbose = True - } -parseOptions as x = error (show as) - -getsig (k,si) = do - d0 <- take 1 $ symbolSource si - let d = case getArgList d0 of - oargs:xs -> let args = fst $ makeParameterNames oargs - in changeArgList (const $ args:xs) d0 - _ -> d0 - ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d - s = sig d - [(ts,(k,s,d))] - -isAcceptableImport (HS.TyFun _ (TyCon _ (UnQual _ (HS.Ident _ x))) xs) | not (notKnown x) = isAcceptableImport xs -isAcceptableImport (HS.TyFun _ (TyApp _ (TyCon _ (UnQual _ (HS.Ident _ "Ptr"))) x) xs) = isAcceptableImport xs -isAcceptableImport (TyCon _ _) = True -isAcceptableImport (TyApp _ _ _) = True -isAcceptableImport _ = False - -makeFunctionUseIO :: HS.Type () -> HS.Type () -makeFunctionUseIO (HS.TyFun a x xs) = (HS.TyFun a x (makeFunctionUseIO xs)) -makeFunctionUseIO t@(TyApp a (TyCon b (UnQual c (HS.Ident d "IO"))) x) = t -makeFunctionUseIO t = TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) t - - -makeAcceptableImport (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) xs) | not (notKnown x) - = (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) (makeAcceptableImport xs)) -makeAcceptableImport (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) xs) - = (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) (makeAcceptableImport xs)) -makeAcceptableImport (HS.TyFun a (TyCon c (UnQual d (HS.Ident e x))) xs) - = (HS.TyFun a (TyApp c (TyCon c (UnQual d (HS.Ident e "Ptr"))) (TyCon e (UnQual e (HS.Ident e x)))) (makeAcceptableImport xs)) -makeAcceptableImport t = t - --- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO () -c2haskell :: C2HaskellOptions - -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO () -c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do - let db = foldr update initTranspile edecls - es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db) - case selectFunction opts of - Nothing -> do - createDirectoryIfMissing False "MonkeyPatch" - let fname = ("MonkeyPatch/" ++ modname ++ ".hs") - basename f = case break (=='.') $ takeWhile (/='/') $ reverse f of - (ext,_:rname) -> reverse rname - (rname,_) -> reverse rname - modname = capitalize $ basename cmodname - stubsname = "MonkeyPatch/" ++ modname ++ "_patch.c" - putStrLn $ "writing " ++ fname - withFile fname WriteMode $ \haskmod -> do - hPutStrLn haskmod $ "module MonkeyPatch." ++ modname ++" where" - hPutStrLn haskmod $ "import Foreign.Ptr" - hPutStrLn haskmod $ "import Data.Word" - hPutStrLn haskmod $ "import Data.Int" - putStrLn $ "-- " ++ show (fmap (fmap (fmap (const ()))) <$> Map.lookup "ip_is_lan" (syms db)) - let sigs = concatMap getsig (Map.toList es) - sigs2 = concatMap (\s -> do - x <- maybeToList $ Map.lookup s (syms db) - (y,_) <- getsig (s,x) - y) - missings - ts = concatMap fst sigs - putStrLn $ "-- IP `elem` db = " ++ show (length . symbolSource <$> Map.lookup "IP" (syms db)) - putStrLn $ "-- IP `elem` sigs2 = " ++ show (elem "IP" sigs2) - putStrLn $ "-- ip_is_lan `elem` db = " ++ show (length . symbolSource <$> Map.lookup "ip_is_lan" (syms db)) - putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2) - forM_ (uniq $ ts ++ sigs2) $ \t -> do - hPutStrLn haskmod $ "data " ++ t - forM_ sigs $ \(_,(k,hs,d)) -> do - forM_ hs $ \hdecl -> do - {- - hPutStr haskmod (commented k) - hPutStr haskmod (commented $ show $ pretty d) - hPutStr haskmod (commented $ show $ getReturnValue d) - hPutStr haskmod (commented $ show hdecl) - -- hPutStr haskmod $ commented $ show $ length $ symbolSource si - forM_ (take 1 $ symbolSource si) $ \d -> do - let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d - -- putStr $ commented (ppShow (fmap (const ()) d)) - -- putStr $ commented (show $ pretty d) - let typ = (TyCon () (Special () (UnitCon ()))) - -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) - forM_ (sig d) $ \hs -> case hs of - htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp - -} - let htyp = makeFunctionUseIO $ extractType hdecl - hPutStrLn haskmod $ (if isAcceptableImport htyp then id else commented) - $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k) - (HS.Ident () k) - htyp) - forM_ missings $ \sym -> goMissing haskmod db sym - {- - forM_ (Map.lookup sym $ syms db) $ \si -> do - forM_ (take 1 $ symbolSource si) $ \d -> do - let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d - -- putStr $ commented (ppShow (fmap (const ()) d)) - -- putStr $ commented (show $ pretty d) - let typ = (TyCon () (Special () (UnitCon ()))) - -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) - forM_ (sig d) $ \htyp -> do - putStrLn $ HS.prettyPrint htyp - - -- mapM_ (putStrLn . HS.prettyPrint) (sig d) - {- - forM_ (body d) $ \stmt -> do - putStr $ commented (take 130 $ show (fmap (const ()) stmt)) - putStr $ commented (ppShow (fmap (const ()) stmt)) - putStrLn $ commented . show . pretty $ stmt - putStr $ commented "calls" - mapM_ (putStr . commented . show . pretty) (calls (body d)) - putStrLn "--" - putStr $ commented "mutations" - mapM_ (putStr . commented . show . pretty) (mutations (body d)) - -} - -} - putStrLn $ "writing " ++ stubsname - withFile stubsname WriteMode $ \stubsfile -> do - {- - forM_ missings $ \sym -> - forM_ (Map.lookup sym$ syms db) $ \si -> do - forM_ (take 1 $ symbolSource si) $ \d -> do - hPutStrLn stubsfile $ show $ pretty $ makeFunctionPointer d - hPutStrLn stubsfile $ show $ pretty $ makeSetter d - hPutStrLn stubsfile $ show $ pretty $ makeStub d - -} - -- mkNodeInfo :: Position -> Name -> NodeInfo - let decls = map (setPos $ initPos stubsname) $ do - sym <- missings - si <- maybeToList $ Map.lookup sym (syms db) - d <- take 1 $ symbolSource si - [ makeFunctionPointer d, makeSetter d, makeStub d] - ns = listify (mkQ False (\ni -> let _ = ni :: C.NodeInfo in True)) decls :: [C.NodeInfo] - headerOfNode n = do - f <- fileOfNode n - case includeTopLevel incs f of - "" -> Nothing - h -> Just h - is = uniq $ mapMaybe headerOfNode ns - hPutStrLn stubsfile "#include " - hPutStrLn stubsfile $ concatMap (\i -> "#include " ++ i ++ "\n") is - hPutStrLn stubsfile $ show $ pretty $ CTranslUnit decls undefNode - - Just cfun -> do - forM_ (Map.lookup cfun $ syms db) $ \si -> do - forM_ (take 1 $ symbolSource si) $ \d -> do - putStrLn $ concatMap HS.prettyPrint $ sig d - putStrLn $ show $ pretty d - putStrLn $ show $ pretty $ makeFunctionPointer d - putStrLn $ show $ pretty $ makeSetter d - putStrLn $ show $ pretty $ makeStub d - putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) d -- <$> makeFunctionPointer d - --- TODO: make idempotent -makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] -makeStatic xs = CStorageSpec (CStatic undefNode) : xs --- makeStatic xs = CStorageSpec (CStatic ()) : xs - -makePointer1 (Just (CDeclr a bs c d e)) - = (Just (CDeclr a (p:bs) c d e)) - where - p = CPtrDeclr [] undefNode - -- p = CPtrDeclr [] () - -makePointer :: [(Maybe (CDeclarator NodeInfo), b, c)] - -> [(Maybe (CDeclarator NodeInfo), b, c)] -makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs - -setNull1 :: Maybe (CInitializer NodeInfo) -setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode) - -setNull ((a,_,b):zs) = (a,setNull1,b):zs - -makeFunctionPointer :: CExternalDeclaration NodeInfo - -> CExternalDeclaration NodeInfo -makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos) -makeFunctionPointer d = d - -changeName2 f (Just (CDeclr (Just (C.Ident nm n p)) bs c d e)) - = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e)) -changeName2 f d = d - -changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs - -changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos) -changeName f d = d - -makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp) - = (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp)) -makeAcceptableDecl (HS.TypeSig a b ftyp) = HS.TypeSig a b (makeFunctionUseIO $ makeAcceptableImport ftyp) - -makeSetter d = -- @(CDeclExt (CDecl xs ys pos)) = - let name = concatMap identToString $ take 1 $ catMaybes $ sym d - in setBody (setterBody ("f_"++name)) $ changeReturnValue (const voidReturnType) $ changeArgList (const voidp) $ changeName ("setf_"++) d - -changeArgList1 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d - -changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs - -changeArgList3 f (Just (CDeclr a x b c d)) = Just (CDeclr a (f x) b c d) - -changeArgList :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) - -> CExternalDeclaration a -> CExternalDeclaration a -changeArgList f (CFDefExt (CFunDef xs ys zs c d)) = CFDefExt (CFunDef xs (changeArgList1 f ys) zs c d) -changeArgList f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl xs (changeArgList2 f ys) pos)) - -setPosOfNode :: Position -> NodeInfo -> NodeInfo -setPosOfNode pos n = maybe (mkNodeInfoOnlyPos pos) (mkNodeInfo pos) $ nameOfNode n - -setPos pos (CFDefExt (CFunDef xs ys zs c n)) = (CFDefExt (CFunDef xs ys zs c $ setPosOfNode pos n)) -setPos pos (CDeclExt (CDecl xs ys n)) = (CDeclExt (CDecl xs ys $ setPosOfNode pos n)) - -getArgList1 (CDeclr a xs b c d) = xs - -getArgList2 ((a,b,c):zs) = getArgList3 a - -getArgList3 (Just (CDeclr a x b c d)) = x - -getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a] -getArgList (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys -getArgList (CDeclExt (CDecl xs ys pos)) = getArgList2 ys - -changeReturnValue f (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef (f xs) ys zs c d)) -changeReturnValue f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl (f xs) ys pos)) - -getReturnValue (CFDefExt (CFunDef xs ys zs c d)) = xs -getReturnValue (CDeclExt (CDecl xs ys pos)) = xs - -voidReturnType = [ CTypeSpec (CVoidType undefNode) ] - -setBody bdy (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef xs ys zs bdy d)) -setBody bdy (CDeclExt (CDecl xs ys pos)) = (CFDefExt (CFunDef xs v [] bdy pos)) - where v = case ys of - (Just y,_,_):_ -> y - _ -> CDeclr Nothing [] Nothing [] pos - -makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = - let rval = case getReturnValue d of - [ CTypeSpec (CVoidType _) ] -> False -- void function. - _ -> True - name = concatMap identToString $ take 1 $ catMaybes $ sym d - msg = "undefined: " ++ concatMap (HS.prettyPrint . makeAcceptableDecl) (take 1 $ sig d) ++ "\n" - in case getArgList d of - oargs:xs -> - let (args,vs) = makeParameterNames oargs - in setBody (stubBody ("f_"++name) vs rval msg) $ changeArgList (const $ args:xs) d - [] -> setBody (stubBody ("f_"++name) [] rval msg) d - - -parameterIdent :: CDeclaration a -> Maybe Ident -parameterIdent (CDecl _ xs n) = listToMaybe $ do - (Just (CDeclr (Just x) _ _ _ _),_,_) <- xs - return x - - --- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo]) -makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n]) -makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of - [CDecl [CTypeSpec (CVoidType _)] [] _] -> ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list. - _ -> ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs ) - where - -- TODO: ensure uniqueness of generated parameter names - qs = zipWith mkp [0..] ps - mkp num (CDecl rtyp ((Just (CDeclr Nothing typ x ys z),a,b):xs) n) - = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) typ x ys z),a,b):xs) n) - mkp num (CDecl rtyp [] n) - = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) [] Nothing [] n),Nothing,Nothing):[]) n) - mkp num p = p - -expr :: CDeclaration a -> CExpression a -expr (CDecl rtyp ((Just (CDeclr (Just i) typ x ys z),a,b):xs) n) = CVar i n - -mkidn :: Show a => a -> NodeInfo -> Ident -mkidn num n = C.Ident ("a"++show num) 0 n - -voidp :: [CDerivedDeclarator NodeInfo] -voidp = [ CFunDeclr - (Right ( [ CDecl - [ CTypeSpec (CVoidType n) ] - [ ( Just (CDeclr - (Just (C.Ident "p" 0 n)) - [ CPtrDeclr [] n ] - Nothing - [] - n) - , Nothing - , Nothing - ) - ] - n - ] - , False)) - [] - n] - where n = undefNode - - -stubBody name vs rval msg = - CCompound [] - [ CBlockStmt - (CIf - (CVar (C.Ident name 0 undefNode) undefNode) - (if rval - then (CReturn - (Just - (C.CCall - (CVar (C.Ident name 0 undefNode) undefNode) - vs - undefNode)) - undefNode) - else (CExpr (Just (C.CCall (CVar (C.Ident name 0 undefNode) undefNode) - vs - undefNode)) - undefNode)) - (Just - (if rval - then CCompound [] - [ CBlockStmt printmsg - , CBlockStmt (CReturn (Just $ CConst (CIntConst (cInteger 0) undefNode)) undefNode)] - undefNode - else printmsg)) - undefNode) - ] - undefNode - where - printmsg = (CExpr (Just (C.CCall (CVar (C.Ident "fputs" 0 undefNode) undefNode) - [ CConst (CStrConst (cString msg) undefNode) - , CVar (C.Ident "stderr" 0 undefNode) undefNode - ] - undefNode)) undefNode) - -setterBody :: String -> CStatement NodeInfo -setterBody name = - CCompound [] - [ CBlockStmt - (CExpr - (Just - (CAssign - CAssignOp - (CVar (C.Ident name 0 undefNode) undefNode) - (CVar (C.Ident "p" 0 undefNode) undefNode) - undefNode)) - undefNode) - ] - undefNode - - -goMissing :: Show b => - Handle -> Transpile [CExternalDeclaration b] -> String -> IO () -goMissing haskmod db cfun = do - forM_ (Map.lookup cfun $ syms db) $ \si -> do - forM_ (take 1 $ symbolSource si) $ \d0 -> do - -- putStr $ commented (ppShow (fmap (const ()) d)) - -- putStr $ commented (show $ pretty d) - -- when (verbose opts) $ print (sig d) - let d = case getArgList d0 of - oargs:xs -> let args = fst $ makeParameterNames oargs - in changeArgList (const $ args:xs) d0 - _ -> d0 - let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d - -- forM_ ts $ \t -> putStrLn $ "data " ++ t - forM_ (sigf hsTransSig d) $ \hs -> do - hPutStrLn haskmod . HS.prettyPrint $ makeAcceptableDecl hs - case hs of - HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp -> do - let wrapname = "wrap" ++ drop 3 signame - settername = "setf" ++ drop 3 signame - funptr = (TyApp () (TyCon () (UnQual () (HS.Ident () "FunPtr"))) - (TyCon () (UnQual () (HS.Ident () signame)))) - -- hPutStrLn haskmod $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)" - -- mapM_ (hPutStrLn haskmod . HS.prettyPrint) (importWrapper $ sigf hsTransSig d) - hPutStrLn haskmod $ HS.prettyPrint $ - (HS.ForImp () (HS.CCall ()) Nothing (Just "wrapper") - (HS.Ident () wrapname) - (TyFun () - (TyCon () (UnQual () (HS.Ident () signame))) - (TyApp () - (TyCon () (UnQual () (HS.Ident () "IO"))) - (TyParen () funptr)))) - hPutStrLn haskmod $ HS.prettyPrint $ - (HS.ForImp () (HS.CCall ()) Nothing (Just settername) - (HS.Ident () settername) - (TyFun () - funptr - (TyApp () - (TyCon () (UnQual () (HS.Ident () "IO"))) - (TyCon () (Special () (UnitCon ())))))) - - - htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp - - -readComments :: (Num lin, Num col) => - FilePath -> IO [(lin, col, [Char])] -readComments fname = parseComments 1 1 <$> readFile fname - -findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) => - a1 -> (a4, a2, a3) -> [Char] -> (a4, a2, a3) -findCloser !1 (l,c,b) ('*':'/':_) = (l,c+2,b+2) -findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs -findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs -findCloser !d (l,c,b) ('\n':xs) = findCloser d (l+1,1,b+1) xs -findCloser !d (l,c,b) (_:xs) = findCloser d (l,c+1,b+1) xs -findCloser !d (l,c,b) [] = (l,c,b) - -mkComment :: a -> b -> c -> (a, b, c) -mkComment lin no str = (lin,no,str) - -parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])] -parseComments !lin !col = \case - ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs - (xs,cs') = splitAt bcnt cs - in mkComment lin col xs : parseComments (lin + lcnt) col' cs' - ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs - in mkComment lin col comment : parseComments (lin + 1) 1 cs - ('\n' : cs) -> parseComments (lin+1) 1 cs - ( x : cs) -> parseComments lin (col+1) cs - [] -> [] - -sanitizeArgs :: [String] -> [String] -sanitizeArgs (('-':'M':_):args) = sanitizeArgs args -sanitizeArgs (('-':'O':_):args) = sanitizeArgs args -sanitizeArgs (('-':'c':_):args) = sanitizeArgs args -sanitizeArgs ("-o":args) = sanitizeArgs $ drop 1 args -sanitizeArgs (arg:args) = arg : sanitizeArgs args -sanitizeArgs [] = [] - -isModule :: FilePath -> Bool -isModule fname = (".c" `isSuffixOf` fname) || (".o" `isSuffixOf` fname) - -usage :: [String] -> Maybe (C2HaskellOptions, [String], [FilePath]) -usage args = - case break (=="--") args of - (targs,_:cargs0) -> do - let (rfs,ropts) = span isModule $ reverse cargs0 - opts = reverse ropts - cargs = (sanitizeArgs opts) - hopts = parseOptions targs defopts - return (hopts,cargs,rfs) - _ -> Nothing - -(<&>) :: Functor f => f a -> (a -> b) -> f b -m <&> f = fmap f m - -uniq :: (Ord k, Foldable t) => t k -> [k] -uniq xs = Map.keys $ foldr (\x m -> Map.insert x () m) Map.empty xs - -unquote :: String -> String -unquote xs = zipWith const (drop 1 xs) (drop 2 xs) - -missingSymbols :: String -> [String] -missingSymbols s = uniq $ do - e <- lines s - let (_,us) = break (=="undefined") $ words e - if null us then [] - else do - let q = concat $ take 1 $ reverse us - c <- take 1 q - guard $ c=='`' || c=='\'' - return $ unquote q - - -linker :: [String] -> String -> IO [String] -linker cargs fname = do - print (cargs,fname) - (hin,hout,Just herr,hproc) <- createProcess (proc "gcc" $ cargs ++ [fname]) - { std_err = CreatePipe } - linkerrs <- hGetContents herr - ecode <- waitForProcess hproc - case ecode of - ExitSuccess -> hPutStrLn stderr $ "Oops: "++fname++" has main() symbol." - _ -> return () - return $ missingSymbols linkerrs - -eraseNodeInfo :: NodeInfo -> NodeInfo -eraseNodeInfo _ = OnlyPos p (p,0) -- undefNode value doesn't ppShow well. - where - p = position 0 "" 0 0 Nothing - - -newtype IncludeStack = IncludeStack - { includes :: Map FilePath [[FilePath]] - } - deriving Show - -emptyIncludes = IncludeStack Map.empty - -openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m - where - go Nothing = Just [stack] - go (Just s) = Just $ stack : s - -findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs - -includeStack bs = foldr go (const emptyIncludes) incs [] - where - incs = filter (\b -> fmap fst (B.uncons b) == Just '#') $ B.lines bs - - fp inc = findQuoted $ B.unpack inc - -- fno inc = read $ concat $ take 1 $ words $ drop 2 $ B.unpack inc - - go inc xs stack - | "1" `elem` B.words inc = let f = fp inc in openInclude f stack (xs (f : stack)) - | "2" `elem` B.words inc = xs (drop 1 stack) - | otherwise = xs stack - -main :: IO () -main = do - self <- getProgName - args <- getArgs - let usageString = self ++ " [--cpp | -p | -t ] [-v] [-f ] -- [gcc options] [modules] " - let m = usage args - fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do - prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname) - let r = do - pre <- left Left $ prer - c <- left Right $ parseC pre (initPos fname) - return (includeStack pre,c) - -- putStrLn $ "fname = " ++ fname - -- putStrLn $ "includes = " ++ ppShow (fmap fst r) - cs <- readComments fname - case () of - _ | preprocess hopts -- --cpp - -> do - case prer of - Left e -> print e - Right bs -> putStrLn $ ppShow $ includeStack $ bs - _ | prettyC hopts -- -p - -> do - either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r - _ | prettyTree hopts -- -t - -> do - putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r - _ -> do - syms <- linker (cargs ++ reverse fs) fname - either print (uncurry $ c2haskell hopts cs fname syms) r diff --git a/monkeypatch.cabal b/monkeypatch.cabal new file mode 100644 index 0000000..4c66cb7 --- /dev/null +++ b/monkeypatch.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.2 +name: monkeypatch +version: 0.1.0.0 +synopsis: Monkey-patch C module dependencies from haskell. +description: This tool generates all the glue neccessary to make use of + functions defined in a C source code file from Haskell. This + includes generating stubs for C functions the C file does not + define but does expect to be linked with. These stubs can be + overwritten at run-time from Haskell by using a setter (i.e. they + may be monkey-patched). Any stub that is called before it is + monkey-patched, has a default implementation that outputs a + console message with the symbol name and Haskell type. + . + For example, + . + > $ ./monkeypatch -- ctox/toxcore/onion_client.c + > writing MonkeyPatch/OnionClient.hs + > writing MonkeyPatch/OnionClient_patch.c + . + The C file name onion_client.c yielded a Haskell module + MonkeyPatch.OnionClient and another C module named + OnionClient_patch.c. The first contains all the foreign imports + neccessary to call functions defined in onion_client.c and also + setters for setting Haskell implementations for functions used, + but not defined, in the module. The OnionClient_patch.c provides + the symbols neccessary to link onion_client.c and invoke whatever + Haskell functions are set as their implementation. + . + Any options, such as -I include paths, neccessary to compile the C + file, may be passed before the file name, but after the \-\-. + Options provided before that symbol are interpretted by the + monkeypatch tool itself. + . + In some cases, such as when an external symbol is used that refers + to a variable or constant that is not a function, the tool will be + unable to generate a monkey-patchable stub. To work around this, + more than one C file can be specified. Only the last one on the + command line will export symbols to Haskell, the others may + provide C-implementations for dependencies that will not be + monkey-patched. These support modules may also be provided in + already-compiled form (as .o object files). + +homepage: http://github.com/joecrayne/monkeypatch +bug-reports: http://github.com/joecrayne/monkeypatch/issues +license: GPL-3.0-only +license-file: LICENSE +author: Joe Crayne +maintainer: joe@jerkface.net +copyright: (c) 2018 Joseph Crayne +category: Development +extra-source-files: CHANGELOG.md + +executable monkeypatch + main-is: monkeypatch.hs + -- other-modules: + -- other-extensions: + build-depends: base ^>=4.10.1.0 + , containers ^>=0.5.10.2 + , language-c + , haskell-src-exts + , bytestring + , syb + , template-haskell + , pretty + , pretty-show + , process + , directory + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/monkeypatch.hs b/monkeypatch.hs new file mode 100644 index 0000000..7c9d75d --- /dev/null +++ b/monkeypatch.hs @@ -0,0 +1,956 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Arrow (left) +import Data.Generics.Aliases +import Data.Generics.Schemes +-- import Debug.Trace +import Control.Monad +import qualified Data.ByteString.Char8 as B +import Data.Char +import Data.Data +import Data.List +import qualified Data.IntMap as IntMap + ;import Data.IntMap (IntMap) +import qualified Data.Map as Map + ;import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set + ;import Data.Set (Set) +import Language.C.Data.Ident as C +import Language.C as C hiding (prettyUsingInclude) +import qualified Language.C as C +import Language.C.System.GCC +import Language.C.System.Preprocess +import Language.C.Data.Position +import Language.Haskell.Exts.Parser as HS +import Language.Haskell.Exts.Pretty as HS +import Language.Haskell.Exts.Syntax as HS +import Language.Haskell.TH +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Syntax as TH +import System.Directory +import System.Environment +import System.IO +import System.Process +import System.Exit +import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), + (<+>)) +import Text.Show.Pretty + +trace _ = id + +-- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. +-- +-- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful +-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers. +prettyUsingInclude :: IncludeStack -> CTranslUnit -> Doc +prettyUsingInclude incs (CTranslUnit edecls _) = + vcat (map (either includeHeader pretty) $ sortBy sysfst mappedDecls) + where + (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls + tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((includeTopLevel incs . posFile . posOf) edecl) + | otherwise = Right edecl + addDecl decl@(Left headerRef) (headerSet, ds) + | null headerRef || Set.member headerRef headerSet + = (headerSet, ds) + | otherwise = (Set.insert headerRef headerSet, decl : ds) + addDecl decl (headerSet,ds) = (headerSet, decl : ds) + + includeHeader hFile = text "#include" <+> text hFile + isHeaderFile = (".h" `isSuffixOf`) + + sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT + sysfst _ _ = Prelude.LT + +includeTopLevel (IncludeStack incs) f = do + stacks <- maybeToList $ Map.lookup f incs + stack <- take 1 stacks + top <- take 1 $ drop 4 $ reverse (f:stack) + if take 1 top == "/" + then let ws = groupBy (\_ c -> c /='/') top + (xs,ys) = break (=="/include") ws + ys' = drop 1 ys + in if not (null ys') then '<': drop 1 (concat ys') ++ ">" + else '"':top++"\"" + else '"':top ++"\"" + +specs :: CExternalDeclaration a -> [CDeclarationSpecifier a] +specs (CFDefExt (CFunDef ss _ _ _ _)) = ss +specs (CDeclExt (CDecl ss _ _)) = ss +specs _ = [] + +declrSym :: CDeclarator t -> Maybe Ident +declrSym (CDeclr m _ _ _ _) = m + +-- Used by update to add a symbols to the database. +sym :: CExternalDeclaration a -> [Maybe Ident] +sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ] +sym (CDeclExt (CDecl specs ms _)) = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m +sym _ = [] + +isStatic :: CDeclarationSpecifier a -> Bool +isStatic (CStorageSpec (CStatic _)) = True +isStatic _ = False + +capitalize :: String -> String +capitalize xs = concatMap (cap . drop 1) gs + where + gs = groupBy (\a b -> b/='_') $ '_':xs + cap (c:cs) = toUpper c : cs + +transField :: CDeclaration t -> [(TH.Name, TH.Bang, TH.Type)] +transField (CDecl [CTypeSpec (CTypeDef ctyp _)] vars _) + = do + let typname = mkName . capitalize . identToString $ ctyp + (var,Nothing,Nothing) <- vars + CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + let fieldName = mkName $ identToString fident + ftyp = case ptrdeclr of + [] -> ConT typname + [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) + [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] +transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) + | Just typname <- mkName . capitalize . identToString <$> mctyp + = do + (var,Nothing,Nothing) <- vars + CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + let fieldName = mkName $ identToString fident + ftyp = case ptrdeclr of + [] -> ConT typname + [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) + [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] + + +transField _ = [] + +transpile (CDeclExt (CDecl [ CTypeSpec (CSUType + (CStruct CStructTag mbIdent (Just fields) [] _) + _) ] + [] + _) ) + | Just struct_name <- capitalize . identToString <$> mbIdent + , let typ = mkName struct_name + = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] [] + where fs = fields >>= transField + +transpile _ = Nothing + + +isHeaderDecl :: CNode a => a -> Bool +isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode + +-- bar :: CExternalDeclaration NodeInfo -> () +-- bar (CDeclExt (CDecl xs [] (NodeInfo pos poslen name))) = () + +data SymbolInformation c = SymbolInformation + { symbolLocal :: Bool + , symbolStatic :: Bool + , symbolSource :: c + } + deriving (Eq,Ord,Show,Functor) + +symbolInformation = SymbolInformation + { symbolLocal = False + , symbolStatic = False + , symbolSource = mempty + } + +data Transpile c = Transpile + { syms :: Map String (SymbolInformation c) + } + +initTranspile = Transpile + { syms = Map.empty + } + +-- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation +grokSymbol d k msi = + let si = fromMaybe symbolInformation msi + in Just $ si + { symbolLocal = symbolLocal si || not (isHeaderDecl d) + , symbolStatic = symbolStatic si || any isStatic (specs d) + , symbolSource = d : symbolSource si + } + +update :: CExternalDeclaration NodeInfo + -> Transpile [CExternalDeclaration NodeInfo] + -> Transpile [CExternalDeclaration NodeInfo] +update d transpile = transpile + { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile) + $ map (maybe "" identToString) $ sym d + } + +data FunctionSignature t = FunctionSignature + { funReturnType :: t + , funArgTypes :: [t] + } + +hsMkName :: String -> HS.QName () +hsMkName str = HS.UnQual () (foo () str) + where + foo = HS.Ident -- alternative: HS.Symbol + + +notKnown "Word8" = False +notKnown "Word16" = False +notKnown "Word32" = False +notKnown "Word64" = False +notKnown "Int8" = False +notKnown "Int16" = False +notKnown "Int32" = False +notKnown "Int64" = False +notKnown "Bool" = False +notKnown "Word" = False +notKnown "Int" = False +notKnown "Char" = False +notKnown "()" = False +notKnown _ = True + +hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String] +hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "size_t" _ _) _)) = [ Right "Word"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _)) = [ Right "Word8"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _)) = [ Right "Word16"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _)) = [ Right "Word32"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint64_t" _ _) _)) = [ Right "Word64"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int8_t" _ _) _)) = [ Right "Int8"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int16_t" _ _) _)) = [ Right "Int16"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int32_t" _ _) _)) = [ Right "Int32"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int64_t" _ _) _)) = [ Right "Int64"] +hsTypeSpec (CTypeSpec (CTypeDef ctyp _)) = [ Left ctyp ] +hsTypeSpec (CTypeSpec (CBoolType _)) = [ Right "Bool"] +hsTypeSpec (CTypeSpec (CIntType _)) = [ Right "Int"] +hsTypeSpec (CTypeSpec (CCharType _)) = [ Right "Char"] +hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp + +hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ [] +hsTypeSpec _ = [] + + +-- fieldInfo :: CDeclarator b -> (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) +-- fieldInfo var = (Just var,Nothing,Nothing) +fieldInfo :: (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) -> [CDeclarator b] +fieldInfo (Just var,_,_) = [var] +fieldInfo _ = [] + +-- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()] +-- recursive for function signatures. +hsTransField :: Show b => + [CDeclarationSpecifier b] -- c structure name + -- -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations + -> [CDeclarator b] -- c variable declarations + -> [(String{-field name-}, HS.Type () {- haskell type -}) ] +hsTransField ctyps vars + = do + typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps) + trace ("typname="++show typname) $ return () + -- (var,Nothing,Nothing) <- vars + var <- vars + trace ("var="++show var) $ return () + -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + let CDeclr mfident ptrdeclr Nothing [] _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c) + -- let CDeclr mfident ptrdeclr _ _ _ = var + trace ("fident="++show mfident) $ return () + trace ("ptrdeclr="++show ptrdeclr) $ return () + let btyp = HS.TyCon () typname + grok bs b = case bs of + [] -> b + (CPtrDeclr [] _:cs) -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) + CFunDeclr (Right (args,flg)) attrs _:p -> + let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs $ concatMap fieldInfo as) args + b0 = case p of + CPtrDeclr [] _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) + [] -> b + in foldr (HS.TyFun ()) b0 ts + _ -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr) + ftyp = grok ptrdeclr btyp + fieldName = maybe ("_") identToString mfident + [ ( fieldName, ftyp ) ] +{- +transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) + | Just typname <- mkName . capitalize . identToString <$> mctyp + = do + (var,Nothing,Nothing) <- vars + CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + let fieldName = mkName $ identToString fident + ftyp = case ptrdeclr of + [] -> ConT typname + [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) + [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] +hsTransField _ _ = [] +-} + +extractType (HS.TypeDecl _ _ ftyp) = ftyp +extractType (HS.TypeSig _ _ ftyp) = ftyp +extractType _ = TyCon () (Special () (UnitCon ())) + +{- +hsTransFieldExt :: Show b => + [CDeclarationSpecifier b] + -> [(Maybe (CDeclarator b), Maybe (CInitializer b), + Maybe (CExpression b))] + -> [Decl ()] +-} +hsTransFieldExt :: Show b => + [CDeclarationSpecifier b] -> [CDeclarator b] -> [Decl ()] +hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ]) + $ hsTransField rs as + +hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ]) + $ hsTransField rs as + +types (HS.TypeDecl _ _ typ) = primtypes typ + +primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b +primtypes t = [t] + +tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str +tname _ = "_unkonwn" + +getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x +getPtrType _ = Nothing + +-- pointers :: [HS.Decl ()] -> [String] +pointers :: [HS.Type l] -> [HS.Type l] +pointers decls = do + d <- decls + maybeToList $ getPtrType d + +unpointer t = case getPtrType t of + Nothing -> t + Just t' -> t' + +-- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()] +sig :: CExternalDeclaration NodeInfo -> [Decl ()] +sig = sigf hsTransFieldExt + +-- • Couldn't match expected type ‘CDerivedDeclarator a -> (Maybe (CDeclarator a), Maybe (CInitializer a), Maybe (CExpression a))’ +-- with actual type ‘(CDerivedDeclarator NodeInfo -> Maybe (CDeclarator NodeInfo), Maybe a0, Maybe a1)’ + + +-- CDeclr (Maybe Ident) +-- [CDerivedDeclarator a] +-- (Maybe (CStringLiteral a)) +-- [CAttribute a] +-- a +-- sigf f d@(CDeclExt (CDecl rs ((Just (CDeclr i x j k l),b,c):zs) n)) = f rs $ map (\v -> (Just (CDeclr Nothing [v] Nothing [] n),Nothing,Nothing)) x +sigf :: ([CDeclarationSpecifier b] -> [CDeclarator b] -> p) -> CExternalDeclaration b -> p +sigf f (CDeclExt (CDecl rs as _)) = f rs $ concatMap fieldInfo as +sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [cdeclr] +{- +sigf f d = f (getReturnValue d) $ do + arg <- getArgList d + let node (CDeclExt (CDecl rs as n)) = n + node (CFDefExt (CFunDef rs cdeclr [] bdy n)) = n + s = listToMaybe $ catMaybes $ sym d + return $ CDeclr s [arg] Nothing [] (node d) +-} + +body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy +body0 _ = Nothing + +body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy +body _ = [] + +data SideEffect = PointerWrite | FunctionCall + +calls :: Data t => t -> [CExpression NodeInfo] +calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] })) + +mutations1 e@(CAssign {}) = [e] +mutations1 e@(CUnary CPreIncOp _ _) = [e] +mutations1 e@(CUnary CPreDecOp _ _) = [e] +mutations1 e@(CUnary CPostIncOp _ _) = [e] +mutations1 e@(CUnary CPostDecOp _ _) = [e] +mutations1 _ = [] + +mutations :: Data t => t -> [CExpression NodeInfo] +mutations = everything (++) (mkQ [] mutations1) + + +-- gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a +-- +-- gfoldl app con +-- +-- does is to turn such a value into +-- +-- con C `app` x_1 `app` x_2 ... `app` x_n + + +commented :: String -> String +commented s = unlines $ map ("-- " ++) (lines s) + +data C2HaskellOptions = C2HaskellOptions + { selectFunction :: Maybe String + , prettyC :: Bool + , prettyTree :: Bool + , verbose :: Bool + , preprocess :: Bool + } + +defopts = C2HaskellOptions + { selectFunction = Nothing + , prettyC = False + , prettyTree = False + , verbose = False + , preprocess = False + } + +parseOptions [] opts = opts +parseOptions ("-f":f:args) opts = parseOptions args opts + { selectFunction = Just f + } +parseOptions ("-t":args) opts = parseOptions args opts + { prettyTree = True + } +parseOptions ("-p":args) opts = parseOptions args opts + { prettyC = True + } +parseOptions ("--cpp":args) opts = parseOptions args opts + { preprocess = True + } +parseOptions ("-v":args) opts = parseOptions args opts + { verbose = True + } +parseOptions as x = error (show as) + +getsig (k,si) = do + d0 <- take 1 $ symbolSource si + let d = case getArgList d0 of + oargs:xs -> let args = fst $ makeParameterNames oargs + in changeArgList (const $ args:xs) d0 + _ -> d0 + ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d + s = sig d + [(ts,(k,s,d))] + +isAcceptableImport (HS.TyFun _ (TyCon _ (UnQual _ (HS.Ident _ x))) xs) | not (notKnown x) = isAcceptableImport xs +isAcceptableImport (HS.TyFun _ (TyApp _ (TyCon _ (UnQual _ (HS.Ident _ "Ptr"))) x) xs) = isAcceptableImport xs +isAcceptableImport (TyCon _ _) = True +isAcceptableImport (TyApp _ _ _) = True +isAcceptableImport _ = False + +makeFunctionUseIO :: HS.Type () -> HS.Type () +makeFunctionUseIO (HS.TyFun a x xs) = (HS.TyFun a x (makeFunctionUseIO xs)) +makeFunctionUseIO t@(TyApp a (TyCon b (UnQual c (HS.Ident d "IO"))) x) = t +makeFunctionUseIO t = TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) t + + +makeAcceptableImport (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) xs) | not (notKnown x) + = (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) (makeAcceptableImport xs)) +makeAcceptableImport (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) xs) + = (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) (makeAcceptableImport xs)) +makeAcceptableImport (HS.TyFun a (TyCon c (UnQual d (HS.Ident e x))) xs) + = (HS.TyFun a (TyApp c (TyCon c (UnQual d (HS.Ident e "Ptr"))) (TyCon e (UnQual e (HS.Ident e x)))) (makeAcceptableImport xs)) +makeAcceptableImport t = t + +-- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO () +c2haskell :: C2HaskellOptions + -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO () +c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do + let db = foldr update initTranspile edecls + es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db) + case selectFunction opts of + Nothing -> do + createDirectoryIfMissing False "MonkeyPatch" + let fname = ("MonkeyPatch/" ++ modname ++ ".hs") + basename f = case break (=='.') $ takeWhile (/='/') $ reverse f of + (ext,_:rname) -> reverse rname + (rname,_) -> reverse rname + modname = capitalize $ basename cmodname + stubsname = "MonkeyPatch/" ++ modname ++ "_patch.c" + putStrLn $ "writing " ++ fname + withFile fname WriteMode $ \haskmod -> do + hPutStrLn haskmod $ "module MonkeyPatch." ++ modname ++" where" + hPutStrLn haskmod $ "import Foreign.Ptr" + hPutStrLn haskmod $ "import Data.Word" + hPutStrLn haskmod $ "import Data.Int" + putStrLn $ "-- " ++ show (fmap (fmap (fmap (const ()))) <$> Map.lookup "ip_is_lan" (syms db)) + let sigs = concatMap getsig (Map.toList es) + sigs2 = concatMap (\s -> do + x <- maybeToList $ Map.lookup s (syms db) + (y,_) <- getsig (s,x) + y) + missings + ts = concatMap fst sigs + putStrLn $ "-- IP `elem` db = " ++ show (length . symbolSource <$> Map.lookup "IP" (syms db)) + putStrLn $ "-- IP `elem` sigs2 = " ++ show (elem "IP" sigs2) + putStrLn $ "-- ip_is_lan `elem` db = " ++ show (length . symbolSource <$> Map.lookup "ip_is_lan" (syms db)) + putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2) + forM_ (uniq $ ts ++ sigs2) $ \t -> do + hPutStrLn haskmod $ "data " ++ t + forM_ sigs $ \(_,(k,hs,d)) -> do + forM_ hs $ \hdecl -> do + {- + hPutStr haskmod (commented k) + hPutStr haskmod (commented $ show $ pretty d) + hPutStr haskmod (commented $ show $ getReturnValue d) + hPutStr haskmod (commented $ show hdecl) + -- hPutStr haskmod $ commented $ show $ length $ symbolSource si + forM_ (take 1 $ symbolSource si) $ \d -> do + let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d + -- putStr $ commented (ppShow (fmap (const ()) d)) + -- putStr $ commented (show $ pretty d) + let typ = (TyCon () (Special () (UnitCon ()))) + -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) + forM_ (sig d) $ \hs -> case hs of + htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp + -} + let htyp = makeFunctionUseIO $ extractType hdecl + hPutStrLn haskmod $ (if isAcceptableImport htyp then id else commented) + $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k) + (HS.Ident () k) + htyp) + forM_ missings $ \sym -> goMissing haskmod db sym + {- + forM_ (Map.lookup sym $ syms db) $ \si -> do + forM_ (take 1 $ symbolSource si) $ \d -> do + let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d + -- putStr $ commented (ppShow (fmap (const ()) d)) + -- putStr $ commented (show $ pretty d) + let typ = (TyCon () (Special () (UnitCon ()))) + -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) + forM_ (sig d) $ \htyp -> do + putStrLn $ HS.prettyPrint htyp + + -- mapM_ (putStrLn . HS.prettyPrint) (sig d) + {- + forM_ (body d) $ \stmt -> do + putStr $ commented (take 130 $ show (fmap (const ()) stmt)) + putStr $ commented (ppShow (fmap (const ()) stmt)) + putStrLn $ commented . show . pretty $ stmt + putStr $ commented "calls" + mapM_ (putStr . commented . show . pretty) (calls (body d)) + putStrLn "--" + putStr $ commented "mutations" + mapM_ (putStr . commented . show . pretty) (mutations (body d)) + -} + -} + putStrLn $ "writing " ++ stubsname + withFile stubsname WriteMode $ \stubsfile -> do + {- + forM_ missings $ \sym -> + forM_ (Map.lookup sym$ syms db) $ \si -> do + forM_ (take 1 $ symbolSource si) $ \d -> do + hPutStrLn stubsfile $ show $ pretty $ makeFunctionPointer d + hPutStrLn stubsfile $ show $ pretty $ makeSetter d + hPutStrLn stubsfile $ show $ pretty $ makeStub d + -} + -- mkNodeInfo :: Position -> Name -> NodeInfo + let decls = map (setPos $ initPos stubsname) $ do + sym <- missings + si <- maybeToList $ Map.lookup sym (syms db) + d <- take 1 $ symbolSource si + [ makeFunctionPointer d, makeSetter d, makeStub d] + ns = listify (mkQ False (\ni -> let _ = ni :: C.NodeInfo in True)) decls :: [C.NodeInfo] + headerOfNode n = do + f <- fileOfNode n + case includeTopLevel incs f of + "" -> Nothing + h -> Just h + is = uniq $ mapMaybe headerOfNode ns + hPutStrLn stubsfile "#include " + hPutStrLn stubsfile $ concatMap (\i -> "#include " ++ i ++ "\n") is + hPutStrLn stubsfile $ show $ pretty $ CTranslUnit decls undefNode + + Just cfun -> do + forM_ (Map.lookup cfun $ syms db) $ \si -> do + forM_ (take 1 $ symbolSource si) $ \d -> do + putStrLn $ concatMap HS.prettyPrint $ sig d + putStrLn $ show $ pretty d + putStrLn $ show $ pretty $ makeFunctionPointer d + putStrLn $ show $ pretty $ makeSetter d + putStrLn $ show $ pretty $ makeStub d + putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) d -- <$> makeFunctionPointer d + +-- TODO: make idempotent +makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] +makeStatic xs = CStorageSpec (CStatic undefNode) : xs +-- makeStatic xs = CStorageSpec (CStatic ()) : xs + +makePointer1 (Just (CDeclr a bs c d e)) + = (Just (CDeclr a (p:bs) c d e)) + where + p = CPtrDeclr [] undefNode + -- p = CPtrDeclr [] () + +makePointer :: [(Maybe (CDeclarator NodeInfo), b, c)] + -> [(Maybe (CDeclarator NodeInfo), b, c)] +makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs + +setNull1 :: Maybe (CInitializer NodeInfo) +setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode) + +setNull ((a,_,b):zs) = (a,setNull1,b):zs + +makeFunctionPointer :: CExternalDeclaration NodeInfo + -> CExternalDeclaration NodeInfo +makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos) +makeFunctionPointer d = d + +changeName2 f (Just (CDeclr (Just (C.Ident nm n p)) bs c d e)) + = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e)) +changeName2 f d = d + +changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs + +changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos) +changeName f d = d + +makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp) + = (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp)) +makeAcceptableDecl (HS.TypeSig a b ftyp) = HS.TypeSig a b (makeFunctionUseIO $ makeAcceptableImport ftyp) + +makeSetter d = -- @(CDeclExt (CDecl xs ys pos)) = + let name = concatMap identToString $ take 1 $ catMaybes $ sym d + in setBody (setterBody ("f_"++name)) $ changeReturnValue (const voidReturnType) $ changeArgList (const voidp) $ changeName ("setf_"++) d + +changeArgList1 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d + +changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs + +changeArgList3 f (Just (CDeclr a x b c d)) = Just (CDeclr a (f x) b c d) + +changeArgList :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) + -> CExternalDeclaration a -> CExternalDeclaration a +changeArgList f (CFDefExt (CFunDef xs ys zs c d)) = CFDefExt (CFunDef xs (changeArgList1 f ys) zs c d) +changeArgList f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl xs (changeArgList2 f ys) pos)) + +setPosOfNode :: Position -> NodeInfo -> NodeInfo +setPosOfNode pos n = maybe (mkNodeInfoOnlyPos pos) (mkNodeInfo pos) $ nameOfNode n + +setPos pos (CFDefExt (CFunDef xs ys zs c n)) = (CFDefExt (CFunDef xs ys zs c $ setPosOfNode pos n)) +setPos pos (CDeclExt (CDecl xs ys n)) = (CDeclExt (CDecl xs ys $ setPosOfNode pos n)) + +getArgList1 (CDeclr a xs b c d) = xs + +getArgList2 ((a,b,c):zs) = getArgList3 a + +getArgList3 (Just (CDeclr a x b c d)) = x + +getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a] +getArgList (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys +getArgList (CDeclExt (CDecl xs ys pos)) = getArgList2 ys + +changeReturnValue f (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef (f xs) ys zs c d)) +changeReturnValue f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl (f xs) ys pos)) + +getReturnValue (CFDefExt (CFunDef xs ys zs c d)) = xs +getReturnValue (CDeclExt (CDecl xs ys pos)) = xs + +voidReturnType = [ CTypeSpec (CVoidType undefNode) ] + +setBody bdy (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef xs ys zs bdy d)) +setBody bdy (CDeclExt (CDecl xs ys pos)) = (CFDefExt (CFunDef xs v [] bdy pos)) + where v = case ys of + (Just y,_,_):_ -> y + _ -> CDeclr Nothing [] Nothing [] pos + +makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = + let rval = case getReturnValue d of + [ CTypeSpec (CVoidType _) ] -> False -- void function. + _ -> True + name = concatMap identToString $ take 1 $ catMaybes $ sym d + msg = "undefined: " ++ concatMap (HS.prettyPrint . makeAcceptableDecl) (take 1 $ sig d) ++ "\n" + in case getArgList d of + oargs:xs -> + let (args,vs) = makeParameterNames oargs + in setBody (stubBody ("f_"++name) vs rval msg) $ changeArgList (const $ args:xs) d + [] -> setBody (stubBody ("f_"++name) [] rval msg) d + + +parameterIdent :: CDeclaration a -> Maybe Ident +parameterIdent (CDecl _ xs n) = listToMaybe $ do + (Just (CDeclr (Just x) _ _ _ _),_,_) <- xs + return x + + +-- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo]) +makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n]) +makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of + [CDecl [CTypeSpec (CVoidType _)] [] _] -> ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list. + _ -> ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs ) + where + -- TODO: ensure uniqueness of generated parameter names + qs = zipWith mkp [0..] ps + mkp num (CDecl rtyp ((Just (CDeclr Nothing typ x ys z),a,b):xs) n) + = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) typ x ys z),a,b):xs) n) + mkp num (CDecl rtyp [] n) + = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) [] Nothing [] n),Nothing,Nothing):[]) n) + mkp num p = p + +expr :: CDeclaration a -> CExpression a +expr (CDecl rtyp ((Just (CDeclr (Just i) typ x ys z),a,b):xs) n) = CVar i n + +mkidn :: Show a => a -> NodeInfo -> Ident +mkidn num n = C.Ident ("a"++show num) 0 n + +voidp :: [CDerivedDeclarator NodeInfo] +voidp = [ CFunDeclr + (Right ( [ CDecl + [ CTypeSpec (CVoidType n) ] + [ ( Just (CDeclr + (Just (C.Ident "p" 0 n)) + [ CPtrDeclr [] n ] + Nothing + [] + n) + , Nothing + , Nothing + ) + ] + n + ] + , False)) + [] + n] + where n = undefNode + + +stubBody name vs rval msg = + CCompound [] + [ CBlockStmt + (CIf + (CVar (C.Ident name 0 undefNode) undefNode) + (if rval + then (CReturn + (Just + (C.CCall + (CVar (C.Ident name 0 undefNode) undefNode) + vs + undefNode)) + undefNode) + else (CExpr (Just (C.CCall (CVar (C.Ident name 0 undefNode) undefNode) + vs + undefNode)) + undefNode)) + (Just + (if rval + then CCompound [] + [ CBlockStmt printmsg + , CBlockStmt (CReturn (Just $ CConst (CIntConst (cInteger 0) undefNode)) undefNode)] + undefNode + else printmsg)) + undefNode) + ] + undefNode + where + printmsg = (CExpr (Just (C.CCall (CVar (C.Ident "fputs" 0 undefNode) undefNode) + [ CConst (CStrConst (cString msg) undefNode) + , CVar (C.Ident "stderr" 0 undefNode) undefNode + ] + undefNode)) undefNode) + +setterBody :: String -> CStatement NodeInfo +setterBody name = + CCompound [] + [ CBlockStmt + (CExpr + (Just + (CAssign + CAssignOp + (CVar (C.Ident name 0 undefNode) undefNode) + (CVar (C.Ident "p" 0 undefNode) undefNode) + undefNode)) + undefNode) + ] + undefNode + + +goMissing :: Show b => + Handle -> Transpile [CExternalDeclaration b] -> String -> IO () +goMissing haskmod db cfun = do + forM_ (Map.lookup cfun $ syms db) $ \si -> do + forM_ (take 1 $ symbolSource si) $ \d0 -> do + -- putStr $ commented (ppShow (fmap (const ()) d)) + -- putStr $ commented (show $ pretty d) + -- when (verbose opts) $ print (sig d) + let d = case getArgList d0 of + oargs:xs -> let args = fst $ makeParameterNames oargs + in changeArgList (const $ args:xs) d0 + _ -> d0 + let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d + -- forM_ ts $ \t -> putStrLn $ "data " ++ t + forM_ (sigf hsTransSig d) $ \hs -> do + hPutStrLn haskmod . HS.prettyPrint $ makeAcceptableDecl hs + case hs of + HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp -> do + let wrapname = "wrap" ++ drop 3 signame + settername = "setf" ++ drop 3 signame + funptr = (TyApp () (TyCon () (UnQual () (HS.Ident () "FunPtr"))) + (TyCon () (UnQual () (HS.Ident () signame)))) + -- hPutStrLn haskmod $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)" + -- mapM_ (hPutStrLn haskmod . HS.prettyPrint) (importWrapper $ sigf hsTransSig d) + hPutStrLn haskmod $ HS.prettyPrint $ + (HS.ForImp () (HS.CCall ()) Nothing (Just "wrapper") + (HS.Ident () wrapname) + (TyFun () + (TyCon () (UnQual () (HS.Ident () signame))) + (TyApp () + (TyCon () (UnQual () (HS.Ident () "IO"))) + (TyParen () funptr)))) + hPutStrLn haskmod $ HS.prettyPrint $ + (HS.ForImp () (HS.CCall ()) Nothing (Just settername) + (HS.Ident () settername) + (TyFun () + funptr + (TyApp () + (TyCon () (UnQual () (HS.Ident () "IO"))) + (TyCon () (Special () (UnitCon ())))))) + + + htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp + + +readComments :: (Num lin, Num col) => + FilePath -> IO [(lin, col, [Char])] +readComments fname = parseComments 1 1 <$> readFile fname + +findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) => + a1 -> (a4, a2, a3) -> [Char] -> (a4, a2, a3) +findCloser !1 (l,c,b) ('*':'/':_) = (l,c+2,b+2) +findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs +findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs +findCloser !d (l,c,b) ('\n':xs) = findCloser d (l+1,1,b+1) xs +findCloser !d (l,c,b) (_:xs) = findCloser d (l,c+1,b+1) xs +findCloser !d (l,c,b) [] = (l,c,b) + +mkComment :: a -> b -> c -> (a, b, c) +mkComment lin no str = (lin,no,str) + +parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])] +parseComments !lin !col = \case + ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs + (xs,cs') = splitAt bcnt cs + in mkComment lin col xs : parseComments (lin + lcnt) col' cs' + ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs + in mkComment lin col comment : parseComments (lin + 1) 1 cs + ('\n' : cs) -> parseComments (lin+1) 1 cs + ( x : cs) -> parseComments lin (col+1) cs + [] -> [] + +sanitizeArgs :: [String] -> [String] +sanitizeArgs (('-':'M':_):args) = sanitizeArgs args +sanitizeArgs (('-':'O':_):args) = sanitizeArgs args +sanitizeArgs (('-':'c':_):args) = sanitizeArgs args +sanitizeArgs ("-o":args) = sanitizeArgs $ drop 1 args +sanitizeArgs (arg:args) = arg : sanitizeArgs args +sanitizeArgs [] = [] + +isModule :: FilePath -> Bool +isModule fname = (".c" `isSuffixOf` fname) || (".o" `isSuffixOf` fname) + +usage :: [String] -> Maybe (C2HaskellOptions, [String], [FilePath]) +usage args = + case break (=="--") args of + (targs,_:cargs0) -> do + let (rfs,ropts) = span isModule $ reverse cargs0 + opts = reverse ropts + cargs = (sanitizeArgs opts) + hopts = parseOptions targs defopts + return (hopts,cargs,rfs) + _ -> Nothing + +(<&>) :: Functor f => f a -> (a -> b) -> f b +m <&> f = fmap f m + +uniq :: (Ord k, Foldable t) => t k -> [k] +uniq xs = Map.keys $ foldr (\x m -> Map.insert x () m) Map.empty xs + +unquote :: String -> String +unquote xs = zipWith const (drop 1 xs) (drop 2 xs) + +missingSymbols :: String -> [String] +missingSymbols s = uniq $ do + e <- lines s + let (_,us) = break (=="undefined") $ words e + if null us then [] + else do + let q = concat $ take 1 $ reverse us + c <- take 1 q + guard $ c=='`' || c=='\'' + return $ unquote q + + +linker :: [String] -> String -> IO [String] +linker cargs fname = do + print (cargs,fname) + (hin,hout,Just herr,hproc) <- createProcess (proc "gcc" $ cargs ++ [fname]) + { std_err = CreatePipe } + linkerrs <- hGetContents herr + ecode <- waitForProcess hproc + case ecode of + ExitSuccess -> hPutStrLn stderr $ "Oops: "++fname++" has main() symbol." + _ -> return () + return $ missingSymbols linkerrs + +eraseNodeInfo :: NodeInfo -> NodeInfo +eraseNodeInfo _ = OnlyPos p (p,0) -- undefNode value doesn't ppShow well. + where + p = position 0 "" 0 0 Nothing + + +newtype IncludeStack = IncludeStack + { includes :: Map FilePath [[FilePath]] + } + deriving Show + +emptyIncludes = IncludeStack Map.empty + +openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m + where + go Nothing = Just [stack] + go (Just s) = Just $ stack : s + +findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs + +includeStack bs = foldr go (const emptyIncludes) incs [] + where + incs = filter (\b -> fmap fst (B.uncons b) == Just '#') $ B.lines bs + + fp inc = findQuoted $ B.unpack inc + -- fno inc = read $ concat $ take 1 $ words $ drop 2 $ B.unpack inc + + go inc xs stack + | "1" `elem` B.words inc = let f = fp inc in openInclude f stack (xs (f : stack)) + | "2" `elem` B.words inc = xs (drop 1 stack) + | otherwise = xs stack + +main :: IO () +main = do + self <- getProgName + args <- getArgs + let usageString = self ++ " [--cpp | -p | -t ] [-v] [-f ] -- [gcc options] [modules] " + let m = usage args + fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do + prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname) + let r = do + pre <- left Left $ prer + c <- left Right $ parseC pre (initPos fname) + return (includeStack pre,c) + -- putStrLn $ "fname = " ++ fname + -- putStrLn $ "includes = " ++ ppShow (fmap fst r) + cs <- readComments fname + case () of + _ | preprocess hopts -- --cpp + -> do + case prer of + Left e -> print e + Right bs -> putStrLn $ ppShow $ includeStack $ bs + _ | prettyC hopts -- -p + -> do + either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r + _ | prettyTree hopts -- -t + -> do + putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r + _ -> do + syms <- linker (cargs ++ reverse fs) fname + either print (uncurry $ c2haskell hopts cs fname syms) r -- cgit v1.2.3