modulo (empty) → 1.1
raw patch · 15 files changed
+3034/−0 lines, 15 filesdep +atto-lispdep +basedep +data-defaultsetup-changed
Dependencies added: atto-lisp, base, data-default, haskell-src, language-c, parsec, prettify, semigroups, text
Files
- COPYING +674/−0
- Setup.lhs +4/−0
- modulo.cabal +54/−0
- src/Language/Modulo.hs +250/−0
- src/Language/Modulo/C.hs +697/−0
- src/Language/Modulo/Haskell.hs +18/−0
- src/Language/Modulo/JavaScript.hs +20/−0
- src/Language/Modulo/Lisp.hs +304/−0
- src/Language/Modulo/Load.hs +140/−0
- src/Language/Modulo/Parse.hs +336/−0
- src/Language/Modulo/Rename.hs +125/−0
- src/Language/Modulo/Util.hs +164/−0
- src/Language/Modulo/Util/Mangle.hs +42/−0
- src/Language/Modulo/Util/Unmangle.hs +62/−0
- src/Main.hs +144/−0
+ COPYING view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU 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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.++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:++ <program> Copyright (C) <year> <name of author>+ 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+<http://www.gnu.org/licenses/>.++ 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+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ modulo.cabal view
@@ -0,0 +1,54 @@++name: modulo+version: 1.1+cabal-version: >= 1.6+author: Hans Hoglund+maintainer: Hans Hoglund <hans@hanshoglund.se>+license: GPL-3+license-file: COPYING+synopsis: Modular C code generator+category: Language, FFI+build-type: Simple++description: + Modulo is a tool that generates modular, standard C interfaces based on a high-level + description language. The idea is to specify functionality in the module language + and implement it in any language that supports C-style calling conventions. + + This package include generators for C and Common Lisp (JavaScript and Haskell on the way).++source-repository head+ type: git+ location: git://github.com/hanshoglund/modulo.git+ +library + build-depends: + base >= 4 && < 5,+ semigroups, + data-default,+ text, + parsec >= 3.1.2 && < 4, + prettify >= 1.0 && < 2,+ language-c, + haskell-src,+ atto-lisp+ hs-source-dirs: src+ exposed-modules:+ Language.Modulo++ Language.Modulo.C+ Language.Modulo.Lisp+ Language.Modulo.Haskell+ Language.Modulo.JavaScript++ Language.Modulo.Load+ Language.Modulo.Parse+ Language.Modulo.Rename+ Language.Modulo.Util+ Language.Modulo.Util.Mangle+ Language.Modulo.Util.Unmangle++executable "modulo"+ hs-source-dirs: src+ main-is: Main.hs+
+ src/Language/Modulo.hs view
@@ -0,0 +1,250 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+-- +-- This Haskell module defines the Modulo description language. Typically, modules are created+-- by writing @.module@ files and using the parser defined in "Language.Modulo.Parser", or+-- the @modulo@ command-line tool. The abstract syntax tree is given below.+-- +-- The module language is very simple. Each module consists of a name followed by+-- eventual import declarations, followed by all other declarations. Here is an example module:+--+-- > module Scl.List+-- > {+-- > opaque Elem;+-- > opaque List;+-- > +-- > nil : () -> List;+-- > cons : (Elem, List) -> List;+-- > head : (List) -> Elem;+-- > tail : (List) -> List;+-- > +-- > empty : (List) -> Bool;+-- > lenght : (List) -> Int;+-- > +-- > reverse : (List) -> List;+-- > sort : (List) -> List;+-- > }+--+-- Like C, the module language uses structural typing for pointers and functions, but+-- nominal typing for structures and unions. Thus in the following example values of type+-- @A@ and @B@ are interchangeable, but values of type @C@ and @D@ are not.+--+-- > type A = Ptr Int+-- > type B = Ptr Int+-- > type C = struct { x : Int, y : Int }+-- > type D = struct { x : Int, y : Int }+--+-- The pointer type constructor can be used with any type:+--+-- > type IntPtr = Int*+-- > type FloatPtr = Float*+--+-- The array type constructor need an explicit length:+--+-- > type IntVec = [Int x 10]+--+-- Functions are written as in Haskell, except for the parentheses enclosing the arguments.+-- Thus, higher-arity functions are easily distinguished.+--+-- > type NoCurry = (A, B) -> C+-- > type Curry = (A) -> (B) -> C+--+-- Compound types are written in a uniform manner:+--+-- > type IntCounter = struct { a : Int, b : Int -> Int }+-- > type NumValue = union { left : Int, right : Float }+-- > type Color = enum { Red, Green, Blue }+--+-- The following primitive types are provided:+-- +-- > Void Size Ptrdiff Intptr UIntptr +-- > Char Short Int Long LongLong+-- > UChar UShort UInt ULong ULongLong+-- > Float Double LongDouble+-- > Int8 Int16 Int32 Int64 UInt8 UInt16 UInt32 UInt64+-- +--+--+-------------------------------------------------------------------------------------++module Language.Modulo (+ -- ** Modules+ Module(..),+ ModuleName(..),+ toModuleName,+ getModuleNameList,++ -- ** Names+ Name(..),+ getName,+ + -- ** Declarations+ Decl(..),+ getDeclName,+ Value(..),++ -- ** Types+ Type(..),+ PrimType(..), + RefType(..), + FunType(..), + CompType(..), + ) where++import Data.Ord+import Numeric.Natural+import Foreign.C.Types ++import Data.List.NonEmpty ( NonEmpty(..) )++import qualified Data.List as List+import qualified Data.List.NonEmpty as NonEmpty++++-- | +-- A module is a named container of imports and declarations.+--+-- Each module can depend on a set of other modules (translated as include directives).+-- Recursive dependencies are not allowed for now.+--+data Module + = Module + { + modName :: ModuleName, -- ^ Name of module+ modImports :: [(ModuleName, Maybe String)], -- ^ Imports with optional import conventions+ modDecls :: [Decl] -- ^ List of declarations+ }+ deriving (Eq, Show)++instance Ord Module where+ compare = comparing modName+ +-- | +-- A module name is a non-empty list of strings.+--+newtype ModuleName + = ModuleName + { + getModuleName :: (NonEmpty String) + }+ deriving (Eq, Ord)++toModuleName :: [String] -> ModuleName+toModuleName = ModuleName . NonEmpty.fromList++getModuleNameList :: ModuleName -> [String]+getModuleNameList = NonEmpty.toList . getModuleName++instance Show ModuleName where+ show (ModuleName (x :| xs)) = concat . List.intersperse "." $ x : xs+++-- |+-- Name of a type, function or constant value.+--+-- Note that any Unicode string may be used as a name.+--+data Name + = Name String+ | QName ModuleName String+ deriving (Eq, Ord)++getName :: Name -> String+getName (Name n) = n+getName (QName m n) = show m ++ "." ++ n++instance Show Name where+ show = getName +++-- | +-- An declaration maps a name to type and optionally a value.+--+data Decl + = TypeDecl Name (Maybe Type) -- ^ Declares a type or opaque.+ | FunctionDecl Name FunType -- ^ Declares a function.+ | TagDecl Type -- ^ Declares a struct or enum tag.+ | ConstDecl Name (Maybe Value) Type -- ^ Declares a constant value.+ | GlobalDecl Name (Maybe Value) Type -- ^ Declares a global variable.+ deriving (Eq, Show)++getDeclName :: Decl -> Maybe Name+getDeclName (TypeDecl n t) = Just n+getDeclName (FunctionDecl n t) = Just n+getDeclName (TagDecl t) = Nothing+getDeclName (ConstDecl n v t) = Just n+getDeclName (GlobalDecl n v t) = Just n++-- | +-- A value is anything that can be declared as a C constant.+data Value + = CInt Integer+ | CFloat Double+ | CStr String+ | CWStr String+ | CInitList [Value]+ deriving (Eq, Show)++-- | +-- A type is either an alias, a primitive or a compound type.+data Type + = AliasType Name -- ^ An alias, introduced by a former type declaration.+ | PrimType PrimType+ | RefType RefType+ | FunType FunType+ | CompType CompType+ deriving (Eq, Show)++-- | A primitive type.+data PrimType+ = Void | Size | Ptrdiff | Intptr | UIntptr + | Char | Short | Int | Long | LongLong+ | SChar+ | Bool+ | UChar | UShort | UInt | ULong | ULongLong+ | Float | Double | LongDouble+ | Int8 | Int16 | Int32 | Int64 | UInt8 | UInt16 | UInt32 | UInt64+ deriving (Eq, Show)+ -- StrUtf8+ -- StrUcs16Be+ -- StrUcs16Le+ -- StrUtf16Be+ -- StrUtf16Le++data RefType+ = Pointer Type -- ^ The C pointer type @t*@.+ | Array Type Natural -- ^ The C array type @t[n]@.+ deriving (Eq, Show)++-- | A function type.+data FunType + = Function [Type] Type -- ^ The C function type @Tn(T1, ... Tn-1)@.+ deriving (Eq, Show)++data CompType+ = Enum (NonEmpty Name) -- ^ A C enum type.+ | Struct (NonEmpty (Name, Type)) -- ^ A C struct type.+ | Union (NonEmpty (Name, Type)) -- ^ A C union type.+ | BitField (NonEmpty (Name, Type, Natural)) -- ^ A C bitfield type.+ deriving (Eq, Show)+ +++-- TODO Decl of struct/union tags++-- TODO use Foreign.C values for Value++-- TODO Decl order by sort and name?+
+ src/Language/Modulo/C.hs view
@@ -0,0 +1,697 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Renders module descriptions as C header files.+--+-------------------------------------------------------------------------------------++module Language.Modulo.C (+ -- ** Styles+ GuardStyle(..),+ ImportStyle(..),+ CStyle(..),+ stdStyle,+ cairoStyle,+ gtkStyle,+ -- appleStyle,+ -- haskellStyle,+ + -- ** Conversion+ translType,+ translFun,+ translConst,+ translGlobal,+ translStructField,+ translUnionField,+ translEnumField,+ + -- ** Rendering+ printModule,+ renderModule,+ printModuleStyle,+ renderModuleStyle,+ ) where++import Data.Default+import Data.Semigroup++import Language.Modulo+import Language.Modulo.Util+import Language.Modulo.Util.Mangle+import Language.Modulo.Util.Unmangle++import Language.C.Syntax.AST+import Language.C.Syntax.Constants+import Language.C.Parser+import Language.C.Pretty+import Language.C.Data.Node+import Language.C.Data.Ident+import Language.C.Data.Position+import Language.C.Data.InputStream++import qualified Data.List as List+import qualified Data.Char as Char+import qualified Data.List.NonEmpty as NonEmpty++-------------------------------------------------------------------------------------+-- Styles+-------------------------------------------------------------------------------------++data GuardStyle+ = Pragma -- ^ Write pragma guards+ | Ifndef -- ^ Write conditional guards++data ImportStyle+ = SystemPath -- ^ Import external modules using system paths+ | LocalPath -- ^ Import external modules using local paths++data CStyle =+ CStyle {+ -- Guards+ guardStyle :: GuardStyle, -- ^ How to write guards+ includeStyle :: ImportStyle, -- ^ How to write import declarations+ includeDirective :: String, -- ^ Import directive, usually @include@.+ guardMangler :: [String] -> String, -- ^ Mangler for names of header guards+ innerHeader :: [String] -> String, -- ^ Inner header mangler+ innerFooter :: [String] -> String, -- ^ Inner footer mangler++ -- Prefix+ typePrefixMangler :: [String] -> String, -- ^ Prefix for types+ valuePrefixMangler :: [String] -> String, -- ^ Prefix for values++ -- Types+ typeMangler :: [String] -> String, -- ^ Mangler for implementation struct names++ -- Fields+ structFieldMangler :: [String] -> String, -- ^ Mangler for struct fields+ unionFieldMangler :: [String] -> String, -- ^ Mangler for union fields+ enumFieldMangler :: [String] -> String, -- ^ Mangler for enum fields++ -- Functions and values+ constMangler :: [String] -> String, -- ^ Mangler for constant values+ globalMangler :: [String] -> String, -- ^ Mangler for global variables+ funcMangler :: [String] -> String -- ^ Mangler for global functions++ -- Options+ -- Wrap in extern C block+ -- Add Doxygen stubs (which?)+ -- Add <PREFIX>_API declaration+ }++-- | Default instance using 'stdStyle'.+instance Default CStyle where+ def = stdStyle+-- | Left-biased Semigroup instance.+instance Semigroup CStyle where+ a <> b = a+-- | Left-biased Monoid instance.+instance Monoid CStyle where+ mempty = def+ mappend = (<>)+++stdInnerHeader :: CStyle -> [String] -> String+stdInnerHeader _ ns = concat (post " @{\n" cs) ++ end+ where+ c1 = ["/** "] ++ repeat " "+ c2 = repeat "@defgroup "+ c3 = map concat . drop 1 . List.inits $ ns+ c4 = repeat " "+ c5 = ns+ c6 = repeat "\n"+ cs = List.zipWith6 (\a b c d e f -> a ++ b ++ c ++ d ++ e ++ f) c1 c2 c3 c4 c5 c6+ end = " */"++stdInnerFooter :: CStyle -> [String] -> String+stdInnerFooter _ ns = (concat $ List.zipWith (++) c1 c2) ++ end+ where+ c1 = ["/** "] ++ repeat " "+ c2 = replicate (length ns) "@}\n"+ end = " */"+++-- |+-- Style used in the C standard library.+--+-- * Types: @ foo_bar_type_t @+--+-- * Functions: @ foo_bar_func @+--+-- * Constants: @ FOO_BAR_VAL @+--+-- * Fields: @ foo_bar @+stdStyle :: CStyle+stdStyle = CStyle+ {+ guardStyle = Ifndef,+ includeStyle = SystemPath, + includeDirective = "include",+ guardMangler = (withPrefix "_" . concatSep "_" . fmap toUpperString),+ innerHeader = (stdInnerHeader stdStyle),+ innerFooter = (stdInnerFooter stdStyle),+ + typePrefixMangler = (withSuffix "_" . concatSep "_" . fmap toLowerString),+ valuePrefixMangler = (withSuffix "_" . concatSep "_" . fmap toLowerString),+ + typeMangler = (concatSep "_" . withSuffix ["t"] . fmap toLowerString),+ structFieldMangler = (concatSep "_" . fmap toLowerString),+ unionFieldMangler = (concatSep "_" . fmap toLowerString),+ enumFieldMangler = (concatSep "_" . fmap toLowerString),+ + constMangler = (concatSep "_" . fmap toLowerString),+ globalMangler = (concatSep "_" . fmap toLowerString),+ funcMangler = (concatSep "_" . fmap toLowerString)+ }++-- |+-- Style used in Cairo.+--+-- * Types: @ p_foo_bar_t @+--+-- * Opaques: @ _p_foo_bar_t @+--+-- * Functions: @ p_foo_bar @+--+-- * Constants: @ P_FOO_BAR @+--+-- * Fields: @ foo_bar @+cairoStyle :: CStyle+cairoStyle = CStyle+ Ifndef SystemPath "include"+ (withPrefix "_" . concatSep "_" . fmap toUpperString)+ (stdInnerHeader cairoStyle)+ (stdInnerFooter cairoStyle)+ (concatSep "_")+ (concatSep "_")++ (concatSep "_" . withSuffix ["t"] . fmap toLowerString)+ (concatSep "_")+ (concatSep "_")+ (concatSep "_")++ (concatSep "_")+ (concatSep "_")+ (concatSep "_")+++-- |+-- Style used in GTK.+--+-- * Types: @ PFooBar @+--+-- * Opaques: @ _PFooBar @+--+-- * Functions: @ p_foo_bar @+--+-- * Constants: @ P_FOO_BAR @+--+-- * Fields: @ foo_bar @+gtkStyle :: CStyle+gtkStyle = CStyle+ Ifndef SystemPath "include"+ (withPrefix "_" . concatSep "_" . fmap toUpperString)+ (stdInnerHeader gtkStyle)+ (stdInnerFooter gtkStyle)+ (concatSep "_")+ (concatSep "_")++ capitalCase+ (concatSep "_")+ (concatSep "_")+ (concatSep "_")++ (concatSep "_")+ (concatSep "_")+ (concatSep "_")++-- |+-- Style used in Apple Frameworks.+--+-- * Types: @ PFooBar @+--+-- * Opaques: @ PFooBarOpaque @+--+-- * Functions: @ PFooBar @+--+-- * Constants: @ kPFooBar @+--+-- * Fields: @ mFooBar @+appleStyle :: CStyle+appleStyle = CStyle+ Ifndef SystemPath "include"+ (withPrefix "_" . concatSep "_" . fmap toUpperString)+ (stdInnerHeader stdStyle)+ (stdInnerFooter stdStyle)+ (capitalCase)+ (mixedCase)++ capitalCase++ (withPrefix "m" . capitalCase)+ (withPrefix "m" . capitalCase)+ (withPrefix "m" . capitalCase)++ (withPrefix "k" . capitalCase)+ (withPrefix "g" . capitalCase)+ capitalCase+--+-- |+-- Style similar to Haskell conventions.+--+-- * Types: @ PFooBar @+--+-- * Opaques: @ PFooBarOpaque @+--+-- * Functions: @ pfooBar @+--+-- * Constants: @ pfooBar @+--+-- * Fields: @ pfooBar @+haskellStyle :: CStyle+haskellStyle = CStyle+ Ifndef SystemPath "include"+ (withPrefix "_" . concatSep "_" . fmap toUpperString)+ (stdInnerHeader stdStyle)+ (stdInnerFooter stdStyle)+ (capitalCase)+ (mixedCase)++ capitalCase++ mixedCase+ mixedCase+ mixedCase++ mixedCase+ mixedCase+ mixedCase+++-------------------------------------------------------------------------------------+-- Codegen+-------------------------------------------------------------------------------------++-- |+-- Print a module using the default style.+--+printModule :: Module -> String+printModule = printModuleStyle def++-- |+-- Print a module using the specified style.+--+printModuleStyle :: CStyle -> Module -> String+printModuleStyle style = (\(x,y,z) -> x ++ (show . pretty $ y) ++ z) . renderModuleStyle style++-- |+-- Render a module using the default style.+--+-- Returns a C header file, represented as a 'CTranslUnit' with enclosing header and footer strings.+--+renderModule :: Module -> (String, CTranslUnit, String)+renderModule = renderModuleStyle def++-- |+-- Render a module using the specified style.+--+-- Returns a C header file, represented as a 'CTranslUnit' with enclosing header and footer strings.+--+renderModuleStyle :: CStyle -> Module -> (String, CTranslUnit, String)+renderModuleStyle style mod = (header, decls, footer)+ where+ header = convertHeader style mod'+ decls = convertTopLevel style mod'+ footer = convertFooter style mod'+ mod' = flattenModule style mod+++-------------------------------------------------------------------------------------+-- Header and footer++convertHeader :: CStyle -> Module -> String+convertHeader st mod = mempty+ ++ "\n"+ ++ guardBegin (guardStyle st) guard+ ++ "\n"+ ++ imports+ ++ "\n\n"+ ++ innerHeader st name+ ++ "\n\n"+ where+ name = getModuleNameList . modName $ mod+ guard = guardMangler st name+ mangleImport = concatSep "/" . map toLowerString . map (concatSep "_") . map unmangle+ imports = concatSep "\n"+ . map (withPrefix ("#" ++ includeDirective st ++ " <") + . withSuffix ".h>" + . mangleImport + . getModuleNameList)+ . map fst+ . modImports+ $ mod++guardBegin :: GuardStyle -> String -> String+guardBegin Pragma name = mempty+ ++ "#pragma once\n"+guardBegin Ifndef name = mempty+ ++ "#ifndef " ++ name ++ "\n"+ ++ "#define " ++ name ++ "\n"++guardEnd :: GuardStyle -> String -> String+guardEnd Pragma name = mempty+ ++ "// " ++ name+guardEnd Ifndef name = mempty+ ++ "#endif // " ++ name++convertFooter :: CStyle -> Module -> String+convertFooter st mod = mempty+ ++ "\n\n"+ ++ innerFooter st name+ ++ "\n\n"+ ++ guardEnd (guardStyle st) guard+ ++ "\n\n"+ where+ name = getModuleNameList . modName $ mod+ guard = guardMangler st name+++-------------------------------------------------------------------------------------+-- Flattening+++-- |+-- Rewrite a module to use C-style (flat) names.+--+-- (This used to be called rename, until the addition of the eponymous module that does name +-- resolution. This function assumes names have already been resolved.)+--+-- The module returned from this function will have no QName constructors.+--+flattenModule :: CStyle -> Module -> Module+flattenModule st (Module n is ds) = Module n is (map (flattenDecl st) ds)++flattenDecl st (TypeDecl n t) = TypeDecl (translType st n) (fmap (flattenType st) t)+flattenDecl st (FunctionDecl n t) = FunctionDecl (translFun st n) (flattenFunType st t)+flattenDecl st (TagDecl t) = TagDecl (flattenType st t)+flattenDecl st (ConstDecl n v t) = ConstDecl (translConst st n) v (flattenType st t)+flattenDecl st (GlobalDecl n v t) = GlobalDecl (translGlobal st n) v (flattenType st t)++flattenType st (PrimType t) = PrimType t+flattenType st (AliasType n) = AliasType $ flattenAlias st n+flattenType st (RefType t) = RefType $ flattenRefType st t+flattenType st (FunType t) = FunType $ flattenFunType st t+flattenType st (CompType t) = CompType $ flattenCompType st t++flattenAlias :: CStyle -> Name -> Name+flattenAlias st n = translType st n++flattenRefType :: CStyle -> RefType -> RefType+flattenRefType st (Pointer t) = Pointer (flattenType st t)+flattenRefType st (Array t n) = Array (flattenType st t) n++flattenFunType :: CStyle -> FunType -> FunType+flattenFunType st (Function as r) = Function (fmap (flattenType st) as) (flattenType st r)++flattenCompType :: CStyle -> CompType -> CompType+flattenCompType st (Enum ns) = Enum $ fmap (translEnumField st) ns+flattenCompType st (Struct ns) = Struct $ fmap (\(n,t) -> (translStructField st n, flattenType st t)) ns+flattenCompType st (Union ns) = Union $ fmap (\(n,t) -> (translUnionField st n, flattenType st t)) ns+flattenCompType st (BitField ns) = notSupported "Bit-fields"++translType :: CStyle -> Name -> Name+translType st = mangleName (typePrefixMangler st) (typeMangler st)++translFun :: CStyle -> Name -> Name+translConst :: CStyle -> Name -> Name+translGlobal :: CStyle -> Name -> Name+translFun st = mangleName (valuePrefixMangler st) (funcMangler st)+translConst st = mangleName (valuePrefixMangler st) (constMangler st)+translGlobal st = mangleName (valuePrefixMangler st) (globalMangler st)++translStructField :: CStyle -> Name -> Name+translUnionField :: CStyle -> Name -> Name+translEnumField :: CStyle -> Name -> Name+translStructField st = mangleName (valuePrefixMangler st) (structFieldMangler st)+translUnionField st = mangleName (valuePrefixMangler st) (unionFieldMangler st)+translEnumField st = mangleName (valuePrefixMangler st) (enumFieldMangler st)+ +mangleName :: ([String] -> String) -> ([String] -> String) -> Name -> Name+mangleName p q (Name n) = Name $ q (unmangle n)+mangleName p q (QName m n) = Name $ (p . concatMap unmangle . getModuleNameList $ m) ++ q (unmangle n)++++-------------------------------------------------------------------------------------+-- Top-level declarations+++convertTopLevel :: CStyle -> Module -> CTranslUnit+convertTopLevel st (Module n is ds) = CTranslUnit cds defInfo+ where+ cds = map (CDeclExt . convertDecl st) ds++convertDecl :: CStyle -> Decl -> CDecl+convertDecl st (TypeDecl n Nothing) = declOpaque st n+convertDecl st (TypeDecl n (Just t)) = declType st n t -- typedef T N;+convertDecl st (FunctionDecl n t) = declFun st n t -- T n (as);+convertDecl st (TagDecl t) = notSupported "Tag decls" -- T;+convertDecl st (ConstDecl n v t) = notSupported "Constants" -- T n; or T n = v;+convertDecl st (GlobalDecl n v t) = notSupported "Globals" -- T n; or T n = v;++-- TODO for now opaques are always structs+-- TODO use separate mangler for struct name+declOpaque :: CStyle -> Name -> CDecl+declOpaque st n = CDecl spec decList defInfo+ where+ typ = CSUType (CStruct CStructTag (Just $ ident ("_" ++ getName n)) Nothing [] defInfo) defInfo+ spec = [CStorageSpec (CTypedef defInfo)] ++ [CTypeSpec typ]+ declr = CDeclr (Just $ identName n) [CPtrDeclr [] defInfo] Nothing [] defInfo+ decList = [topLevelDeclr declr]+ ++declType :: CStyle -> Name -> Type -> CDecl+declType st n t = CDecl spec decList defInfo+ where+ (typ, decl) = convertType st t+ spec = [CStorageSpec (CTypedef defInfo)] ++ map CTypeSpec typ+ declr = CDeclr (Just $ identName n) decl Nothing [] defInfo+ decList = [topLevelDeclr declr]++declVar :: CStyle -> Name -> Type -> CDecl+declVar st n t = CDecl spec decList defInfo+ where+ (typ, decl) = convertType st t+ spec = [] ++ map CTypeSpec typ+ declr = CDeclr (Just $ identName n) decl Nothing [] defInfo+ decList = [topLevelDeclr declr]++declFun :: CStyle -> Name -> FunType -> CDecl+declFun st n t = CDecl spec decList defInfo+ where+ (typ, decl) = convertFunType st t+ spec = [] ++ map CTypeSpec typ+ declr = CDeclr (Just $ identName n) decl Nothing [] defInfo+ decList = [topLevelDeclr declr]++++-- These are used recursively from below++declParam :: CStyle -> Maybe Name -> Type -> CDecl+declParam st n t = CDecl spec decList defInfo+ where+ (typ, decl) = convertType st t+ spec = map CTypeSpec typ+ declr = CDeclr (fmap identName n) decl Nothing [] defInfo+ decList = [memberDeclr declr]++-- struct or union member+declStructMember :: CStyle -> Name -> Type -> CDecl+declStructMember st n t = CDecl spec decList defInfo+ where+ (typ, decl) = convertType st t+ spec = map CTypeSpec typ+ declr = CDeclr (Just $ identName n) decl Nothing [] defInfo+ decList = [memberDeclr declr]++declBitfieldMember :: CStyle -> Maybe Name -> Type -> Int -> CDecl+declBitfieldMember = notSupported "Bit-fields"++-- |+-- C types are represented by+--+-- 1) A sequence of (declaration-specific) type specifiers such as 'unsigned', 'long', 'int' etc+--+-- 2) A sequence of (variable-specific) qualifiers such as '*', '[]' or function arguments+--+convertType :: CStyle -> Type -> ([CTypeSpec], [CDerivedDeclr])+convertType st (AliasType n) = convertAlias st n+convertType st (PrimType t) = convertPrimType st t+convertType st (RefType t) = convertRefType st t+convertType st (FunType t) = convertFunType st t+convertType st (CompType t) = convertCompType st t++convertAlias :: CStyle -> Name -> ([CTypeSpec], [CDerivedDeclr])+convertAlias st n = (alias, [])+ where+ alias = [CTypeDef (identName n) defInfo]++convertPrimType :: CStyle -> PrimType -> ([CTypeSpec], [CDerivedDeclr])+convertPrimType st t = (prim t, [])+ where+ -- prim Bool = [CBoolType defInfo]+ prim Bool = return $ CTypeDef (ident "bool") defInfo+ prim Void = [CVoidType defInfo]+ prim Char = [CCharType defInfo]+ prim Short = [CShortType defInfo]+ prim Int = [CIntType defInfo]+ prim Long = [CLongType defInfo]+ prim LongLong = [CLongType defInfo, CLongType defInfo]+ prim SChar = [CSignedType defInfo, CCharType defInfo]+ prim UChar = [CUnsigType defInfo, CCharType defInfo]+ prim UShort = [CUnsigType defInfo, CShortType defInfo]+ prim UInt = [CUnsigType defInfo, CIntType defInfo]+ prim ULong = [CUnsigType defInfo, CLongType defInfo]+ prim ULongLong = [CUnsigType defInfo, CLongType defInfo, CLongType defInfo]+ prim Float = [CFloatType defInfo]+ prim Double = [CDoubleType defInfo]+ prim LongDouble = [CLongType defInfo, CDoubleType defInfo]+ prim Size = return $ CTypeDef (ident "size_t") defInfo+ prim Ptrdiff = return $ CTypeDef (ident "ptrdiff_t") defInfo+ prim Intptr = return $ CTypeDef (ident "intptr_t") defInfo+ prim UIntptr = return $ CTypeDef (ident "uintptr_t") defInfo+ prim Int8 = return $ CTypeDef (ident "int8_t") defInfo+ prim Int16 = return $ CTypeDef (ident "int16_t") defInfo+ prim Int32 = return $ CTypeDef (ident "int32_t") defInfo+ prim Int64 = return $ CTypeDef (ident "int64_t") defInfo+ prim UInt8 = return $ CTypeDef (ident "uint8_t") defInfo+ prim UInt16 = return $ CTypeDef (ident "uint16_t") defInfo+ prim UInt32 = return $ CTypeDef (ident "uint32_t") defInfo+ prim UInt64 = return $ CTypeDef (ident "uint64_t") defInfo++++convertRefType :: CStyle -> RefType -> ([CTypeSpec], [CDerivedDeclr])+convertRefType st (Pointer t) = (typ, [CPtrDeclr [] defInfo] ++ decls)+ where+ (typ, decls) = convertType st t+convertRefType st (Array t n) = (typ, [CArrDeclr [] size defInfo] ++ decls)+ where+ size = (CArrSize isStatic (CConst (CIntConst (fromIntegral n) defInfo)))+ isStatic = False+ (typ, decls) = convertType st t++convertFunType :: CStyle -> FunType -> ([CTypeSpec], [CDerivedDeclr])+convertFunType st (Function as r) = (typ, [CFunDeclr (Right (args, False)) [] defInfo ] ++ decls)+ where+ (typ, decls) = convertType st r+ args :: [CDecl]+ args = map (\t -> declParam st Nothing t) as++convertCompType :: CStyle -> CompType -> ([CTypeSpec], [CDerivedDeclr])+convertCompType st (Enum as) = ([typ], [])+ where+ typ = CEnumType enum defInfo+ enum = CEnum tag (Just names) [] defInfo+ tag = Nothing+ names = map (\n -> (identName n, Nothing)) $ NonEmpty.toList as++convertCompType st (Struct as) = ([typ], [])+ where+ typ = cStruct tag (Just decls)+ tag = Nothing+ decls = map (\(n,t) -> declStructMember st n t) $ NonEmpty.toList as++convertCompType st (Union as) = ([typ], [])+ where+ typ = cUnion tag (Just decls)+ tag = Nothing+ decls = map (\(n,t) -> declStructMember st n t) $ NonEmpty.toList as++convertCompType st (BitField as) = notSupported "Bitfields"+++++-------------------------------------------------------------------------------------+-- Util++-- | An identifier+ident :: String -> Ident+ident name = Ident name 0 defInfo++identName :: Name -> Ident+identName = ident . getName++-- | Top-level declaration.+topLevelDeclr :: CDeclr -> (Maybe CDeclr, Maybe CInit, Maybe CExpr)+topLevelDeclr declr = (Just declr, Nothing, Nothing)++-- | Top-level declaration with initial value.+topLevelDeclrInit :: CDeclr -> CInit -> (Maybe CDeclr, Maybe CInit, Maybe CExpr)+topLevelDeclrInit declr init = (Just declr, Just init, Nothing)++-- | Member declaration.+memberDeclr :: CDeclr -> (Maybe CDeclr, Maybe CInit, Maybe CExpr)+memberDeclr declr = (Just declr, Nothing, Nothing)++-- | Member declaration with size.+memberDeclrSize :: CDeclr -> CExpr -> (Maybe CDeclr, Maybe CInit, Maybe CExpr)+memberDeclrSize declr size = (Just declr, Nothing, Just size)++-- | Parameter declaration.+paramDeclr :: CDeclr -> (Maybe CDeclr, Maybe CInit, Maybe CExpr)+paramDeclr declr = (Just declr, Nothing, Nothing)+++cStruct t ds = CSUType r defInfo where r = CStruct CStructTag t ds [] defInfo+cUnion t ds = CSUType r defInfo where r = CStruct CUnionTag t ds [] defInfo++-- | Used for all NodeInfo values in generated code+defInfo :: NodeInfo+defInfo = error "Can not read nodeInfo"+-- defInfo = OnlyPos $ Position undefined 0 0++notSupported x = error $ "Not supported yet: " ++ x++deriving instance Show CTranslUnit+deriving instance Show CExtDecl+deriving instance Show CStrLit+deriving instance Show CFunDef+deriving instance Show CDecl+deriving instance Show CStat+deriving instance Show CDeclr+deriving instance Show CInit+deriving instance Show CDeclSpec+deriving instance Show CAsmStmt+deriving instance Show CBlockItem+deriving instance Show CAttr+deriving instance Show CDerivedDeclr+deriving instance Show CDesignator+deriving instance Show CExpr+deriving instance Show CTypeQual+deriving instance Show CTypeSpec+deriving instance Show CAsmOperand+deriving instance Show CArrSize+deriving instance Show CBuiltin+deriving instance Show CConst+deriving instance Show CEnum+deriving instance Show CStructUnion+deriving instance Show CStructTag++instance Num CInteger where+ (CInteger a r f) + (CInteger b _ _) = CInteger (a+b) r f+ (CInteger a r f) * (CInteger b _ _) = CInteger (a*b) r f+ abs (CInteger a r f) = CInteger (abs a) r f+ signum (CInteger a r f) = CInteger (signum a) r f+ fromInteger a = CInteger a DecRepr noFlags+
+ src/Language/Modulo/Haskell.hs view
@@ -0,0 +1,18 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Renders module descriptions as Haskell 2010 foreign declarations.+--+-------------------------------------------------------------------------------------++module Language.Modulo.Haskell ( + ) where
+ src/Language/Modulo/JavaScript.hs view
@@ -0,0 +1,20 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Renders module descriptions as JavaScript imports, using Node package @ffi@.+--+-- See <https://github.com/rbranson/node-ffi>+--+-------------------------------------------------------------------------------------++module Language.Modulo.JavaScript ( + ) where
+ src/Language/Modulo/Lisp.hs view
@@ -0,0 +1,304 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Renders module descriptions as Common Lisp (CFFI) declarations.+--+-------------------------------------------------------------------------------------++module Language.Modulo.Lisp (+ -- ** Styles+ LispStyle(..),+ stdLispStyle,+ -- ** Rendering+ printModuleLisp,+ renderModuleLisp,+ printModuleLispStyle,+ renderModuleLispStyle+ ) where++import Data.Default+import Data.Semigroup+import Data.Char (chr)+import Data.Text (pack)+import Data.AttoLisp++import Language.Modulo.C+import Language.Modulo.Util+import Language.Modulo.Util.Unmangle+import Language.Modulo++import qualified Data.List as List++-- import qualified Data.List as List+-- import qualified Data.Char as Char+-- import qualified Data.List.NonEmpty as NonEmpty++data LispStyle =+ LispStyle {+ cStyle :: CStyle, -- ^ For generating foreign declarations+ package :: String, -- ^ Package in which to generate definitions+ safeOpaque :: Bool -- ^ If true, generate a wrapper class for each opaque type.+ }++stdLispStyle = LispStyle { + cStyle = stdStyle,+ package = "cl-user",+ safeOpaque = True+ }++-- | Default instance using 'stdStyle'.+instance Default LispStyle where+ def = stdLispStyle+-- | Left-biased Semigroup instance.+instance Semigroup LispStyle where+ a <> b = a+-- | Left-biased Monoid instance.+instance Monoid LispStyle where+ mempty = def+ mappend = (<>)++-- |+-- Print a module using the default style.+--+printModuleLisp :: Module -> String+printModuleLisp = printModuleLispStyle def++-- |+-- Print a module using the specified style.+--+printModuleLispStyle :: LispStyle -> Module -> String+printModuleLispStyle style = concatSep "\n" . map show . renderModuleLispStyle style+-- TODO more intelligent splitting++-- |+-- Render a module using the default style.+--+-- Returns a Lisp file, represented as a sequence of S-expressions.+--+renderModuleLisp :: Module -> [Lisp]+renderModuleLisp = renderModuleLispStyle def++-- |+-- Render a module using the specified style.+--+-- Returns a Lisp file, represented as a sequence of S-expressions.+--+renderModuleLispStyle :: LispStyle -> Module -> [Lisp]+renderModuleLispStyle st = withPrefix (convertPackage st) . convertTopLevel st++convertPackage :: LispStyle -> [Lisp]+convertPackage st = [list [symbol "in-package", keyword (package st)]]++convertTopLevel :: LispStyle -> Module -> [Lisp]+convertTopLevel st (Module n is ds) = cds+ where+ cds = concatMap (convertDecl st) ds++convertDecl :: LispStyle -> Decl -> [Lisp]+convertDecl st (TypeDecl n Nothing) = declOpaque st n+convertDecl st (TypeDecl n (Just t)) = declType st n t -- typedef T N;+convertDecl st (FunctionDecl n t) = declFun st n t -- T n (as);+convertDecl st (TagDecl t) = notSupported "Tag decls" -- T;+convertDecl st (ConstDecl n v t) = notSupported "Constants" -- T n; or T n = v;+convertDecl st (GlobalDecl n v t) = notSupported "Globals" -- T n; or T n = v;++-- TODO Generate+--+-- (define-foreign-type T-type () () (:actual-type :pointer))+-- (define-parse-method T () (make-instance 'T-type))+--+-- OR+-- (define-foreign-type T-type () () (:actual-type :pointer) (:simple-parser T))+--+-- If safeOpaque true, also generate+-- (defclass T () ((nat :initarg :nat)) )+--+-- (defmethod translate-to-foreign (x (type T-type))+-- (slot-value x 'nat)) +-- (defmethod translate-from-foreign (x (type T-type))+-- (make-instance 'T :nat x))+++declOpaque :: LispStyle -> Name -> [Lisp] +declOpaque st n = [defType, defParse] ++ if (safeOpaque st) then [defClass, defInput, defOutput] else []+ where+ defType = list [symbol "define-foreign-type", metaName, nil, nil, actual]+ actual = list [keyword "actual-type", keyword "pointer"]+ defParse = list [symbol "define-parse-method", typeName, nil, create]+ create = list [symbol "make-instance", qualMetaName]+ + defClass = list [symbol "defclass", typeName, nil, slots]+ slots = list [list [symbol slot, keyword "initarg", keyword slot]]+ defInput = list [symbol "defmethod", symbol "translate-to-foreign", + list [symbol "x", list [symbol "type", metaName]],+ list [symbol "slot-value", symbol "x", symbol (withPrefix "'" slot)]]+ defOutput = list [symbol "defmethod", symbol "translate-from-foreign",+ list [symbol "x", list [symbol "type", metaName]],+ list [symbol "make-instance", qualTypeName, keyword slot, symbol "x"]]++ slot = withSuffix "-ptr" $ convertName n+ qualMetaName = symbol $ withPrefix "'" $ withSuffix "-type" $ convertName n + metaName = symbol $ withSuffix "-type" $ convertName n + qualTypeName = symbol $ withPrefix "'" $ convertName n+ typeName = symbol $ convertName n+ ++-- return $ list [symbol "defctype", symbolName n, keyword "pointer"]+++declType :: LispStyle -> Name -> Type -> [Lisp] +declType st n t = return $ list [symbol "defctype", symbolName n, convertType st t]++declFun :: LispStyle -> Name -> FunType -> [Lisp] +declFun st n (Function as r) = + return $ list $ [symbol "defcfun", list [name, cname], ret] ++ args+ where+ name = symbolName n+ ret = convertType st r+ cname = string $ convertCFunName (cStyle st) n+ argNames = map (symbol . return . chr) [97..(97+25)]+ argTypes = map (convertType st) as + args = map (\(n,t) -> list [n, t]) (zip argNames argTypes)++ +convertType :: LispStyle -> Type -> Lisp+convertType st (AliasType n) = convertAlias st n+convertType st (PrimType t) = convertPrimType st t+convertType st (RefType t) = convertRefType st t+convertType st (FunType t) = convertFunType st t+convertType st (CompType t) = convertCompType st t++convertAlias :: LispStyle -> Name -> Lisp+convertAlias st n = symbolName n++convertPrimType :: LispStyle -> PrimType -> Lisp+convertPrimType st Bool = keyword "boolean"+convertPrimType st Void = keyword "void"+convertPrimType st Char = keyword "char" +convertPrimType st Short = keyword "short" +convertPrimType st Int = keyword "int" +convertPrimType st Long = keyword "long" +convertPrimType st LongLong = keyword "long-long"+convertPrimType st UChar = keyword "unsigned-char" +convertPrimType st UShort = keyword "unsigned-short" +convertPrimType st UInt = keyword "unsigned-int" +convertPrimType st ULong = keyword "unsigned-long" +convertPrimType st ULongLong = keyword "unsigned-long-long" +convertPrimType st Float = keyword "float" +convertPrimType st Double = keyword "double" +convertPrimType st LongDouble = keyword "long-double"+convertPrimType st Int8 = keyword "int8" +convertPrimType st Int16 = keyword "int16" +convertPrimType st Int32 = keyword "int32" +convertPrimType st Int64 = keyword "int64" +convertPrimType st UInt8 = keyword "uint8" +convertPrimType st UInt16 = keyword "uint16" +convertPrimType st UInt32 = keyword "uint32" +convertPrimType st UInt64 = keyword "uint64"+-- convertPrimType st Size = keyword "size"+-- Note: Size etc are declared in cffi-sys, unfortunately not visible to cffi+convertPrimType st Size = keyword "int32" -- FIXME assume? -- FIXME shouldn't this be unsigned?+convertPrimType st Ptrdiff = keyword "ptrdiff"+convertPrimType st Intptr = keyword "pointer" +convertPrimType st UIntptr = notSupported "Uintptr with Lisp"+convertPrimType st SChar = notSupported "Signed chars with Lisp"+++convertRefType :: LispStyle -> RefType -> Lisp+convertRefType st (Pointer t) = list [keyword "pointer", convertType st t]+convertRefType st (Array t n) = notSupported "Array types with Lisp"+-- TODO++convertFunType :: LispStyle -> FunType -> Lisp+convertFunType st (Function as r) = convertType st voidPtr++convertCompType :: LispStyle -> CompType -> Lisp+convertCompType st (Enum as) = convertType st (PrimType Int) -- TODO+convertCompType st (Struct as) = convertType st voidPtr+convertCompType st (Union as) = convertType st voidPtr+convertCompType st (BitField as) = error "Not implemented: bitfields" -- TODO+++++++++string :: String -> Lisp+string = String . pack++symbol :: String -> Lisp+symbol = Symbol . pack++keyword :: String -> Lisp+keyword x = Symbol (pack $ ":" ++ x)++stringName :: Name -> Lisp+stringName = string . convertName {- getName-}++symbolName :: Name -> Lisp+symbolName = symbol . convertName {- getName-}++keywordName :: Name -> Lisp+keywordName = keyword . convertName {- getName-}++convertName :: Name -> String+convertName (Name n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (unmangle n)+convertName (QName m n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (stripPackage (getModuleNameList m) ++ unmangle n)++stripPackage :: [String] -> [String]+stripPackage = tail+-- TODO only strip prefix that matches (unmangle (package st))++convertCTypeName :: CStyle -> Name -> String+convertCTypeName st n = getName (translType st n)++convertCFunName :: CStyle -> Name -> String+convertCFunName st n = getName (translFun st n)++-- TODO type fun const global enumF structF unionF+++voidPtr = RefType (Pointer $ PrimType Void)++++instance Default Lisp where+ def = nil+instance Semigroup Lisp where+ (<>) = appendLisp+instance Monoid Lisp where+ mempty = def+ mappend = (<>)++list :: [Lisp] -> Lisp+list = List++single :: Lisp -> Lisp+single a = List [a]++appendLisp :: Lisp -> Lisp -> Lisp+appendLisp a b = List (as ++ bs)+ where+ (List as) = assureList a+ (List bs) = assureList b++assureList :: Lisp -> Lisp+assureList (List as) = List as+assureList (DotList as a) = DotList as a+assureList x = List [x]++notSupported x = error $ "Not supported yet: " ++ x++-- concatSep :: [a] -> [[a]] -> [a]+-- concatSep x = List.concat . List.intersperse x
+ src/Language/Modulo/Load.hs view
@@ -0,0 +1,140 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+--+-------------------------------------------------------------------------------------++module Language.Modulo.Load (+ -- ** Paths+ ModulePath,+ relativePath,+ absolutePaths,++ -- *** Standard paths+ stdModulePaths,+ withStdModulePaths,++ -- ** Loading+ loadModule,+ loadDependencies,+ ) where++import Control.Exception++import Language.Modulo+import Language.Modulo.Parse+import Language.Modulo.Util++import qualified Data.List.NonEmpty as NonEmpty++-- We should mimic CPP behaviour or it is a bug+-- We use usr/modules in place of usr/include etc.++-- |+-- Path where modules are stored.+--+type ModulePath = FilePath++-- |+-- Module paths, in order of preference.+stdModulePaths :: [ModulePath]+stdModulePaths = ["/usr/modules", "/usr/local/modules"]++-- |+-- Append the standard paths to the given paths.+--+-- That is, the given paths take precedence over the standards.+--+withStdModulePaths :: [ModulePath] -> [ModulePath]+withStdModulePaths = (++ stdModulePaths)++-- |+-- Converts a module name to a relative path.+--+relativePath :: ModuleName -> FilePath+relativePath n = concatSep "/" (getModuleNameList n) ++ ".module"++-- |+-- Converts a module name to a list of absolute paths, in order of preference.+--+absolutePaths :: [ModulePath] -> ModuleName -> [FilePath]+absolutePaths ps n = map (++ "/" ++ relativePath n) ps+++-- TODO detect and fail on recursive dependencies+-- TODO generally more safe version of loadModule and loadDepencencies++-- |+-- Load the dependencies of the given module.+--+-- Dependencies of the loaded modules are loaded transitively. +-- This function blocks if a recursive dependency is encountered.+-- +loadDependencies :: [ModulePath] -> Module -> IO [Module]+loadDependencies ps m = do+ let depNames =filterImports $ modImports m+ deps <- concatMapM (loadModule ps) depNames+ return $ m : deps+++-- |+-- Load a module of the given name.+-- +-- Dependencies of the loaded modules are loaded transitively. +-- This function blocks if a recursive dependency is encountered.+-- +loadModule :: [ModulePath] -> ModuleName -> IO [Module]+loadModule ps n = do+ m <- unsafeLoad ps n+ let depNames = filterImports $ modImports m+ deps <- concatMapM (loadModule ps) depNames+ return $ m : deps+ + where+ unsafeLoad :: [ModulePath] -> ModuleName -> IO Module+ unsafeLoad ps n = do+ s <- unsafeReadAny $ absolutePaths ps n+ let m = unsafeParse s+ if (modName m /= n)+ then (error $ "File name does not match module name: \n"+ ++ " Saw: `" ++ show (modName m) ++ "'\n"+ ++ " Expected: `" ++ show n ++ "'\n")+ else (return m)+ + unsafeParse :: String -> Module+ unsafeParse s = case (parse s) of+ Left e -> error $ "Parse error: " ++ show e+ Right m -> m++-- |+-- Extract imports to load based on the import convention.+--+-- This function should probably use some plugin-style system to alter the+-- loading mechanism, for now non-standard imports are just ignored.+--+filterImports :: [(ModuleName, Maybe String)] -> [ModuleName]+filterImports = concatMap $ \imp -> case imp of+ (name, Nothing) -> [name]+ (name, Just conv) -> [] -- ignore+++-- | +-- Attempt to read all given files, returning the contents of the first successful +-- read, or failing if none could be found.+unsafeReadAny :: [FilePath] -> IO String+unsafeReadAny [] = error "unsafeReadAny: Empty path list"+unsafeReadAny (f:fs) = do+ r <- try $ readFile f :: IO (Either IOException String)+ case r of+ Left e -> if (null fs) then (error $ show e) else unsafeReadAny fs+ Right s -> return s+
+ src/Language/Modulo/Parse.hs view
@@ -0,0 +1,336 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Parser for the module language, as described in "Language.Modulo".+--+-------------------------------------------------------------------------------------++module Language.Modulo.Parse (+ parse,+ parseName,+ unsafeParseFile+ ) where++import Control.Monad+import Control.Applicative hiding ((<|>), optional, many)++import Text.Parsec hiding (parse)+import Text.Parsec.Token+import Text.Parsec.String++import Language.Modulo+import Language.Modulo.Util++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty++-- |+-- Parse a module description, returning an error if unsuccessful.+--+parse :: String -> Either ParseError Module+parse = runParser modParser () ""+++-- |+-- Parse a qualified name, returning an error if unsuccessful.+--+parseName :: String -> Either ParseError Name+parseName = runParser nameParser () ""++-- |+-- Parse a module description from the given file, or fail if unsuccessful.+--+-- This unsafe function should not be used in production code.+--+unsafeParseFile :: FilePath -> IO Module+unsafeParseFile path = do+ str <- readFile path+ case (runParser modParser () path str) of+ Left e -> error . show $ e+ Right m -> return m+++-------------------------------------------------------------------------------------+-- Parser+-------------------------------------------------------------------------------------++modParser :: Parser Module+modParser = do+ optional lspace+ reserved lexer "module"+ name <- modNameParser+ llex $ char '{'+ imps <- many impParser+ decls <- many declParser+ llex $ char '}'+ return $ Module name imps decls++modNameParser :: Parser ModuleName+modNameParser = do+ (x:xs) <- identifier lexer `sepBy1` (string ".")+ return . ModuleName $ x :| xs++impParser :: Parser (ModuleName, Maybe String)+impParser = do+ reserved lexer "import"+ conv <- optionMaybe lstr+ name <- modNameParser+ semi lexer+ return (name, conv)++declParser :: Parser Decl+declParser = mzero+ <|> typeDeclParser+ <|> tagDeclParser+ <|> funDeclParser+ -- <|> constDeclParser+ -- <|> globalDeclParser++typeDeclParser :: Parser Decl+typeDeclParser = do+ reserved lexer "type"+ name <- unameParser+ llex $ char '='+ typ <- typeOpaqueParser+ semi lexer+ return $ TypeDecl name typ++tagDeclParser :: Parser Decl+tagDeclParser = do+ reserved lexer "tagname"+ typ <- typeParser+ semi lexer+ return $ TagDecl typ+++-- TODO rewrite in declarative style+funDeclParser :: Parser Decl+funDeclParser = do+ (name, typ) <- unameTypeParser+ semi lexer+ case typ of+ (FunType func) -> return $ FunctionDecl name func+ _ -> unexpected "Expected function type"+++constDeclParser :: Parser Decl+constDeclParser = notSupported "Constant parsing"++globalDeclParser :: Parser Decl+globalDeclParser = notSupported "Global parsing"++-------------------------------------------------------------------------------------++typeOpaqueParser :: Parser (Maybe Type)+typeOpaqueParser = (opaqueParser >> return Nothing) <|> fmap Just typeParser++opaqueParser :: Parser ()+opaqueParser = reserved lexer "opaque" >> return ()++typeParser :: Parser Type+typeParser = do+ typs <- typeStartParser+ mods <- typeEndParser+ return $ mods typs++typeStartParser :: Parser [Type]+typeStartParser = mzero+ <|> parenTypeParser+ <|> single <$> arrayTypeParser+ <|> single <$> enumTypeParser+ <|> single <$> unionTypeParser+ <|> single <$> structTypeParser+ <|> single <$> bitfieldTypeParser+ <|> single <$> primTypeParser+ <|> single <$> aliasTypeParser++typeEndParser :: Parser ([Type] -> Type)+typeEndParser = foldr (flip c2) head <$> many (ptr <|> func)+ where+ ptr = do+ llex $ char '*'+ return mkPtr+ func = do+ llex $ string "->"+ typ <- typeParser+ return $ mkFun typ+ + mkPtr :: [Type] -> Type+ mkPtr [x] = RefType . Pointer $ x+ mkPtr _ = error "Can not make pointer of argument head"+ -- TODO reflect up to parser hierarchy++ mkFun :: Type -> [Type] -> Type+ mkFun r as = FunType $ Function as r++ -- TODO is this (=<=) in Control.Comonad ?+ c2 :: ([b] -> c) -> ([a] -> b) -> [a] -> c+ c2 g f = g . single . f+ ++-- TODO support named arguments+parenTypeParser :: Parser [Type]+parenTypeParser = do+ llex $ char '('+ typ <- typeParser `sepBy` (llex $ char ',')+ llex $ char ')'+ return typ++arrayTypeParser :: Parser Type+arrayTypeParser = do+ llex $ char '['+ typ <- typeParser+ llex $ char 'x'+ n <- lnat+ llex $ char ']'+ return $ RefType $ Array typ (fromInteger n)++enumTypeParser :: Parser Type+enumTypeParser = do+ reserved lexer "enum"+ llex $ char '{'+ (n:ns) <- unameParser `sepBy` (llex $ char ',')+ llex $ char '}'+ return $ CompType $ Enum (n :| ns)++structTypeParser :: Parser Type+structTypeParser = do+ reserved lexer "struct"+ llex $ char '{'+ (n:ns) <- unameTypeParser `sepBy1` (llex $ char ',')+ llex $ char '}'+ return $ CompType $ Struct (n :| ns)++unionTypeParser :: Parser Type+unionTypeParser = do+ reserved lexer "union"+ llex $ char '{'+ (n:ns) <- unameTypeParser `sepBy1` (llex $ char ',')+ llex $ char '}'+ return $ CompType $ Union (n :| ns)++bitfieldTypeParser :: Parser Type+bitfieldTypeParser = do+ reserved lexer "bitfield"+ notSupported "Bitfield parsing"++primTypeParser :: Parser Type+primTypeParser = mzero+ <|> "Int8" ==> Int8+ <|> "Int16" ==> Int16+ <|> "Int32" ==> Int32+ <|> "Int64" ==> Int64+ <|> "UInt8" ==> UInt8+ <|> "UInt16" ==> UInt16+ <|> "UInt32" ==> UInt32+ <|> "UInt64" ==> UInt64++ <|> "Bool" ==> Bool+ <|> "Void" ==> Void+ <|> "Size" ==> Size+ <|> "Ptrdiff" ==> Ptrdiff+ <|> "Intptr" ==> Intptr+ <|> "UIntptr" ==> UIntptr++ <|> "Char" ==> Char+ <|> "Short" ==> Short+ <|> "Int" ==> Int+ <|> "Long" ==> Long+ <|> "LongLong" ==> LongLong++ <|> "UChar" ==> UChar+ <|> "UShort" ==> UShort+ <|> "UInt" ==> UInt+ <|> "ULong" ==> ULong+ <|> "ULongLong" ==> ULongLong++ <|> "Float" ==> Float+ <|> "Double" ==> Double+ <|> "LongDouble" ==> LongDouble+ where+ s ==> t = lres s >> return (PrimType t)++aliasTypeParser :: Parser Type+aliasTypeParser = do+ name <- nameParser+ return $ AliasType name++-------------------------------------------------------------------------------------++nameParser :: Parser Name+nameParser = do+ r <- identifier lexer `sepBy1` (string ".")+ return $ case r of+ [x] -> Name x+ (x:xs) -> QName (ModuleName $ x :| init xs) (last xs)++unameParser :: Parser Name+unameParser = Name <$> lname++unameTypeParser :: Parser (Name, Type)+unameTypeParser = do+ name <- unameParser+ llex $ char ':'+ typ <- typeParser+ return $ (name, typ)+++-- Extra combinators, not exported+occs p = length <$> many p+follow p q = do+ a <- p+ b <- q+ return (a, b)+-- spaceBefore p = optional lspace >> p+-- spaceAfter p = p >> optional lspace+-- spaceAround p = spaceBefore (spaceAfter p)++-------------------------------------------------------------------------------------+-- Lexer+-------------------------------------------------------------------------------------++lexer :: TokenParser ()+lexer = makeTokenParser $ LanguageDef {+ commentStart = "/*",+ commentEnd = "*/",+ commentLine = "//",+ nestedComments = True,+ identStart = (letter <|> char '_'),+ identLetter = (alphaNum <|> char '_'),+ opStart = mzero,+ opLetter = mzero,+ reservedNames = reservedNames,+ reservedOpNames = mzero,+ caseSensitive = True+ }+ where+ reservedNames = [+ "module", "import", "type", "tagname", "opaque", "enum", "union", "struct", "bitfield",+ "Int", "Void", "Size", "Ptrdiff", "Intptr", "UIntptr",+ "Char", "Short", "Int", "Long", "LongLong",+ "UChar", "UShort", "UInt", "ULong", "ULongLong",+ "Float", "Double", "LongDouble",+ "Int8", "Int16", "Int32", "Int64", "UInt8", "UInt16", "UInt32", "UInt64" ]++-- Convenient synonyms, not exported+llex = lexeme lexer+lnat = natural lexer+lstr = stringLiteral lexer+lname = identifier lexer+lres = reserved lexer+lspace = whiteSpace lexer+++single x = [x]++notSupported x = error $ "Not supported yet: " ++ x+
+ src/Language/Modulo/Rename.hs view
@@ -0,0 +1,125 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+--+-------------------------------------------------------------------------------------++module Language.Modulo.Rename (+ rename+ ) where++import Control.Exception+import Data.List (isSuffixOf)+import Data.Maybe (catMaybes)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List as List++import Language.Modulo+import Language.Modulo.Parse+import Language.Modulo.Util+import Language.Modulo.Util.Unmangle (unmangle)++import qualified Data.List.NonEmpty as NonEmpty++-- |+-- Rewrite all unqualified names as qualified names.+--+-- This function is partial with the following invariants:+--+-- * Received module has no QName constructors+--+-- * Returned module has no Name constructors+--+rename :: [Module] -> Module -> Module+rename deps mod@(Module n is ds) = Module n is (map renameDecl ds) + where+ renameDecl (TypeDecl n t) = TypeDecl (simplify $ qualify mod n) (fmap renameType t)+ renameDecl (FunctionDecl n t) = FunctionDecl (simplify $ qualify mod n) (renameFunType t)+ renameDecl (TagDecl t) = TagDecl (renameType t)+ renameDecl (ConstDecl n v t) = ConstDecl (simplify $ qualify mod n) v (renameType t)+ renameDecl (GlobalDecl n v t) = GlobalDecl (simplify $ qualify mod n) v (renameType t)++ renameType (PrimType t) = PrimType t+ renameType (AliasType n) = AliasType $ simplify $ resolveName (mod : deps) n+ renameType (RefType t) = RefType $ renameRefType t+ renameType (FunType t) = FunType $ renameFunType t+ renameType (CompType t) = CompType $ renameCompType t++ renameRefType :: RefType -> RefType+ renameRefType (Pointer t) = Pointer (renameType t)+ renameRefType (Array t j) = Array (renameType t) j+ + renameFunType :: FunType -> FunType+ renameFunType (Function as r) = Function (fmap renameType as) (renameType r)+ + renameCompType :: CompType -> CompType+ renameCompType (Enum ns) = Enum ns+ renameCompType (Struct ns) = Struct $ fmap (\(n,t) -> (n, renameType t)) ns+ renameCompType (Union ns) = Union $ fmap (\(n,t) -> (n, renameType t)) ns+ renameCompType (BitField ns) = notSupported "Bit-fields"++qualify :: Module -> Name -> Name+qualify m (Name n) = QName (modName m) n+qualify _ (QName _ _) = error "Name already qualified"++resolveName :: [Module] -> Name -> Name+resolveName ms (QName m n) = QName m n+resolveName ms n@(Name n') = case findName ms n of+ Nothing -> error $ "Could not find: " ++ show n'+ Just m -> QName m n'+ +-- | +-- Find the first module in which the given unqualified name is declared+--+findName :: [Module] -> Name -> Maybe ModuleName+findName [] n = Nothing+findName (m:ms) n+ | n `elem` mNs = Just $ modName m+ | otherwise = findName ms n+ where+ mNs = catMaybes . map getDeclName . modDecls $ m +++-- If the given name is a suffix of the module name, simplify+simplify :: Name -> Name+simplify (Name n) = Name n+simplify (QName m n) = QName (simp m n) n+ where+ simp mn@(ModuleName (m :| ms)) n+ | unmangle n `isSuffixOf` concatMap unmangle ms + = ModuleName (m :| concat (dropNestEnd (length $ unmangle n) (map unmangle ms)))+ | otherwise = mn++ x `lastOf` [] = False+ x `lastOf` xs = x == last xs+++dropNestEnd :: Int -> [[a]] -> [[a]]+dropNestEnd n = reverseDeep . dropNest n . reverseDeep++reverseDeep :: [[a]] -> [[a]]+reverseDeep = reverse . map reverse+ +dropNest :: Int -> [[a]] -> [[a]]+dropNest _ [] = []+dropNest 0 xss = xss+dropNest n (xs:xss) = drop n xs : dropNest m xss+ where+ m = n - length xs `max` 0+ +++++++notSupported x = error $ "Not supported yet: " ++ x
+ src/Language/Modulo/Util.hs view
@@ -0,0 +1,164 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-------------------------------------------------------------------------------------++module Language.Modulo.Util (+ -- ** String and Char stuff+ toUpperChar,+ toLowerChar,+ toUpperString,+ toLowerString,+ toCapitalString,++ -- ** List stuff+ withPrefix,+ withSuffix,+ sep,+ pre,+ post,+ wrap,+ concatSep,+ concatPre,+ concatPost,+ concatWrap,+ divideList,+ breakList,+ + -- ** Monad stuff+ concatMapM+ ) where++import qualified Data.Char as Char+import qualified Data.Monoid as Monoid+import qualified Data.List as List++-------------------------------------------------------------------------------------+-- String and Char+-------------------------------------------------------------------------------------++-- | +-- Synonym for 'Char.toUpper'+toUpperChar :: Char -> Char+toUpperChar = Char.toUpper++-- | +-- Synonym for 'Char.toLower'+toLowerChar :: Char -> Char+toLowerChar = Char.toLower++-- | +-- Synonym for 'fmap Char.toUpper'+toUpperString :: String -> String+toUpperString = fmap Char.toUpper++-- | +-- Synonym for 'fmap Char.toLower'+toLowerString :: String -> String+toLowerString = fmap Char.toLower++-- | +-- Convert a string to use upper case for the leading letter and lower case for +-- remaining letters.+toCapitalString :: String -> String+toCapitalString [] = []+toCapitalString (x:xs) = toUpperChar x : toLowerString xs++++-------------------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------------------++-- | +-- Synonym for '(++)'+--+withPrefix :: [a] -> [a] -> [a]+withPrefix x = (x ++)++-- | +-- Synonym for 'flip (++)'+--+withSuffix :: [a] -> [a] -> [a]+withSuffix x = (++ x)++-- | +-- Separate a list by the given element.+--+-- Equivalent to 'List.intersperse'+--+sep :: a -> [a] -> [a]+sep = List.intersperse++-- | +-- Initiate and separate a list by the given element.+--+pre :: a -> [a] -> [a]+pre x = (x :) . sep x++-- | +-- Separate and terminate a list by the given element.+--+post :: a -> [a] -> [a]+post x = withSuffix [x] . sep x++-- | +-- Separate and terminate a list by the given element.+--+wrap :: a -> a -> [a] -> [a]+wrap x y = (x :) . withSuffix [y] . sep x++-- | +-- Combination of 'concat' and 'sep'.+--+concatSep :: [a] -> [[a]] -> [a]+concatSep x = concat . sep x++-- | +-- Combination of 'concat' and 'pre'.+--+concatPre :: [a] -> [[a]] -> [a]+concatPre x = concat . pre x++-- | +-- Combination of 'concat' and 'post'.+--+concatPost :: [a] -> [[a]] -> [a]+concatPost x = concat . post x++-- | +-- Combination of 'concat' and 'wrap'.+--+concatWrap :: [a] -> [a] -> [[a]] -> [a]+concatWrap x y = concat . wrap x y++-- | +-- Divide a list into parts of maximum length n.+--+divideList :: Int -> [a] -> [[a]]+divideList n xs + | length xs <= n = [xs]+ | otherwise = [take n xs] ++ (divideList n $ drop n xs)++-- | +-- Break up a list into parts of maximum length n, inserting the given list as separator.+-- Useful for breaking up strings, as in @breakList 80 "\n" str@.+--+breakList :: Int -> [a] -> [a] -> [a]+breakList n z = Monoid.mconcat . List.intersperse z . divideList n ++-- | +-- Break up a list into parts of maximum length n, inserting the given list as separator.+-- Useful for breaking up strings, as in @breakList 80 "\n" str@.+--+concatMapM :: (Monad f, Functor f) => (a -> f [b]) -> [a] -> f [b]+concatMapM f = fmap concat . mapM f
+ src/Language/Modulo/Util/Mangle.hs view
@@ -0,0 +1,42 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Manglers for various kinds of identifiers.+--+-------------------------------------------------------------------------------------++module Language.Modulo.Util.Mangle (+ mixedCase,+ capitalCase,+ sepCase+ ) where++import Data.Semigroup+import Data.Semigroup++import Language.Modulo.Util++-- |+-- Mangle an indentifier in mixed case, i.e. @[foo, bar]@ becomes @fooBar@.+mixedCase :: [String] -> String+mixedCase [] = []+mixedCase (x:xs) = mconcat $ toLowerString x : fmap toCapitalString xs++-- |+-- Mangle an indentifier in capital case, i.e. @[foo, bar]@ becomes @FooBar@.+capitalCase :: [String] -> String+capitalCase = mconcat . fmap toCapitalString++-- |+-- Mangle an indentifier using the underscore as separator, i.e. @[foo, bar]@ becomes @foo_bar@.+sepCase :: [String] -> String+sepCase = concatSep "_"
+ src/Language/Modulo/Util/Unmangle.hs view
@@ -0,0 +1,62 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Unmanglers for various kinds of identifiers.+--+-------------------------------------------------------------------------------------++module Language.Modulo.Util.Unmangle (+ unmangle,+ uncase,+ unsep+ ) where+++import Data.Semigroup+import Data.Semigroup+import Language.Modulo.Util++import qualified Data.Char as Char+import qualified Data.List as List++-- |+-- Unmangle an indentifier in mixed or separarated case.+unmangle :: String -> [String]+unmangle "" = []+unmangle a = mconcat . fmap uncase $ unsep a++-- |+-- Unmangle an indentifier in mixed case, i.e. @fooBar@ becomes @[foo, bar]@.+uncase :: String -> [String]+uncase "" = []+uncase (c:cs) = case n of+ Nothing -> [c:cs]+ Just n -> (c : take n cs) : uncase (drop n cs)+ where+ n = List.findIndex (Char.isUpper) cs+ +-- |+-- Unmangle an indentifier using the underscore as separator, i.e. @foo_bar@ becomes @[foo, bar]@.+--+-- > unsep (sep a) = a, iff a /= []+--+unsep :: String -> [String]+unsep [] = []+unsep cs = unsep' cs++unsep' cs = case n of+ Nothing -> [cs]+ Just n -> take n cs : unsep' (drop (n+1) cs)+ where + n = List.findIndex isSep cs + isSep '_' = True+ isSep _ = False
+ src/Main.hs view
@@ -0,0 +1,144 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++module Main where++import Control.Monad (when)+import Data.List (find)+import Data.Maybe (fromMaybe, maybeToList)+import System.IO+import System.Exit+import System.Environment+import System.Console.GetOpt++import Language.Modulo+import Language.Modulo.C+import Language.Modulo.Lisp+import Language.Modulo.Load+import Language.Modulo.Parse+import Language.Modulo.Rename+import Language.Modulo.Util++data ModLang+ = C+ | Lisp+ | JavaScript+ | Haskell+ deriving (Eq, Read, Show)+modLangs = [C, Lisp, JavaScript, Haskell]++data ModCStyle+ = CStyleStd+ | CStyleCairo+ | CStyleGtk+ | CStyleApple+ | CStyleHaskell+ deriving (Eq, Show)+ +data ModOpt+ = Help + | Version+ | Package { getPackage :: String }+ | Lang { getLang :: ModLang }+ | Path { getPath :: [ModulePath] }+ deriving (Eq, Show)++readModLang :: Maybe String -> ModOpt+readModLang Nothing = Lang C+readModLang (Just s) = Lang $ case s of+ "l" -> Lisp+ "lisp" -> Lisp+ "Lisp" -> Lisp+ "js" -> JavaScript+ "JS" -> JavaScript+ "Js" -> JavaScript+ "JavaScript" -> JavaScript+ "hs" -> Haskell+ "haskell" -> Haskell+ "Haskell" -> Haskell+ _ -> C++readModPath :: Maybe String -> ModOpt+readModPath = Path . maybeToList+-- TODO accept more than one, separate by commas++readPackage :: Maybe String -> ModOpt+readPackage = Package . maybe "user" id+++version = "modulo-1.0"+header = "Usage: modulo [options]\n" +++ "Usage: modulo [options] files...\n" +++ "\n" +++ "Languages:\n " ++ concatSep "\n " (map show modLangs) ++ "\n" +++ "\n" +++ "Options:"++options = [ + (Option ['h'] ["help"] (NoArg Help) "Print help and exit"),+ (Option ['v'] ["version"] (NoArg Version) "Print version and exit"),+ (Option ['L'] ["language"] (OptArg readModLang "LANG") "Output language"),+ (Option ['M'] ["module-path"] (OptArg readModPath "PATH") "Module paths"),+ (Option [] ["lisp-package"] (OptArg readPackage "STRING") "Lisp package")+ ] + +main = do+ (opts, args, optErrs) <- getOpt Permute options `fmap` getArgs++ let usage = usageInfo header options+ let printUsage = putStr (usage ++ "\n") >> exitWith ExitSuccess+ let printVersion = putStr (version ++ "\n") >> exitWith ExitSuccess++ when (Help `elem` opts) printUsage+ when (Version `elem` opts) printVersion + runFilter opts+++findLang opts = fmap getLang $ find isLang opts+ where + isLang (Lang _) = True+ isLang _ = False+findPath opts = fmap getPath $ find isPath opts+ where + isPath (Path _) = True+ isPath _ = False+findPackage opts = fmap getPackage $ find isPackage opts+ where + isPackage (Package _) = True+ isPackage _ = False+ +-- |+-- Run as a filter from stdin to stdout.+runFilter :: [ModOpt] -> IO ()+runFilter opts = compileFile opts stdin stdout+++compileFile :: [ModOpt] -> Handle -> Handle -> IO ()+compileFile opts input output = do+ let lang = fromMaybe C (findLang opts)+ let paths = fromMaybe [] (findPath opts)+ let package = fromMaybe "user" (findPackage opts)+ + s <- hGetContents input+ let m = unsafeParse s+ mr <- unsafeRename paths m+ let c = printMod lang mr+ hPutStr output c+ + return ()+ where + unsafeRename :: [ModulePath] -> Module -> IO Module+ unsafeRename paths m = do+ deps <- loadDependencies (withStdModulePaths paths) m+ return $ rename deps m+ + unsafeParse :: String -> Module+ unsafeParse s = case (parse s) of+ Left e -> error $ "Parse error: " ++ show e+ Right m -> m+ + printMod :: ModLang -> Module -> String+ printMod C = printModule+ printMod Lisp = printModuleLisp+