diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/modulo.cabal b/modulo.cabal new file mode 100644 --- /dev/null +++ b/modulo.cabal @@ -0,0 +1,54 @@ + +name: modulo +version: 1.1 +cabal-version: >= 1.6 +author: Hans Hoglund +maintainer: Hans Hoglund +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 + diff --git a/src/Language/Modulo.hs b/src/Language/Modulo.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo.hs @@ -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? + diff --git a/src/Language/Modulo/C.hs b/src/Language/Modulo/C.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/C.hs @@ -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 _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 + diff --git a/src/Language/Modulo/Haskell.hs b/src/Language/Modulo/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Haskell.hs @@ -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 diff --git a/src/Language/Modulo/JavaScript.hs b/src/Language/Modulo/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/JavaScript.hs @@ -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 +-- +------------------------------------------------------------------------------------- + +module Language.Modulo.JavaScript ( + ) where diff --git a/src/Language/Modulo/Lisp.hs b/src/Language/Modulo/Lisp.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Lisp.hs @@ -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 diff --git a/src/Language/Modulo/Load.hs b/src/Language/Modulo/Load.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Load.hs @@ -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 + diff --git a/src/Language/Modulo/Parse.hs b/src/Language/Modulo/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Parse.hs @@ -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 + diff --git a/src/Language/Modulo/Rename.hs b/src/Language/Modulo/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Rename.hs @@ -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 diff --git a/src/Language/Modulo/Util.hs b/src/Language/Modulo/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Util.hs @@ -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 diff --git a/src/Language/Modulo/Util/Mangle.hs b/src/Language/Modulo/Util/Mangle.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Util/Mangle.hs @@ -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 "_" diff --git a/src/Language/Modulo/Util/Unmangle.hs b/src/Language/Modulo/Util/Unmangle.hs new file mode 100644 --- /dev/null +++ b/src/Language/Modulo/Util/Unmangle.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 +