diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,3 @@ +module Main (main) where + +import Nirum.Cli (main) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,69 @@ +Nirum +===== + +Nirum is an [IDL][1] compiler and [RPC][2]/[distributed object][3] framework +for [microservices][4], built on top of the modern Web server technologies +such as RESTful HTTP and JSON. + +You can find how its IDL looks like from source codes in the `examples/` +directory. + +**Note that its design is highly unstable and could be changed.** +Also the feature set is incomplete yet. + +[1]: https://en.wikipedia.org/wiki/Interface_description_language +[2]: https://en.wikipedia.org/wiki/Remote_procedure_call +[3]: https://en.wikipedia.org/wiki/Distributed_object +[4]: https://en.wikipedia.org/wiki/Microservices + + +Installation +------------ + +If you already installed [Haskell Platform][5] or [Haskell Stack][6], +you can build the project in the same way other Haskell projects are built: + + $ cabal sandbox init + $ cabal install --only-dependencies + $ cabal configure + $ cabal build + +or: + + $ stack build + +[5]: https://www.haskell.org/platform/ +[6]: https://www.haskellstack.org/ + + +Getting Started +--------------- + +In order to compile a Nirum package (`examples/`) to a Python package: + + $ mkdir out/ # directory to place generated Python files + $ nirum -o out/ examples/ + +For more infomration, use `--help` option: + + $ nirum --help + Nirum Compiler 0.1.0 + + nirum [OPTIONS] DIR + + Common flags: + -o --output-dir=DIR The directory to place object files + -? --help Display help message + -V --version Print version information + --numeric-version Print just the version number + + +Etymology +--------- + +**니름** (IPA: /niɾɯm/; *nireum*) is a sort of telepathy in the fictional world +of [The Bird That Drinks Tears][7] (눈물을 마시는 새 *Nunmureul masineun sae*) +by [Lee Yeongdo][8] (이영도). + +[7]: https://en.wikipedia.org/wiki/The_Bird_That_Drinks_Tears +[8]: https://en.wikipedia.org/wiki/Lee_Yeongdo diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/nirum.cabal b/nirum.cabal new file mode 100644 --- /dev/null +++ b/nirum.cabal @@ -0,0 +1,111 @@ +name: nirum +version: 0.1.0 +synopsis: Distributed object framework built on top of + REST HTTP and JSON +description: Distributed object framework for microservices, + built on top of RESTful HTTP and JSON +homepage: https://github.com/spoqa/nirum +bug-reports: https://github.com/spoqa/nirum/issues +license: GPL-3 +license-file: LICENSE +author: Nirum team +maintainer: Nirum team +copyright: (c) 2016 Nirum team +stability: alpha +category: Language +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Nirum.Cli + , Nirum.Constructs + , Nirum.Constructs.Annotation + , Nirum.Constructs.Declaration + , Nirum.Constructs.DeclarationSet + , Nirum.Constructs.Identifier + , Nirum.Constructs.Module + , Nirum.Constructs.ModulePath + , Nirum.Constructs.Name + , Nirum.Constructs.Service + , Nirum.Constructs.TypeDeclaration + , Nirum.Constructs.TypeExpression + , Nirum.Package + , Nirum.Parser + , Nirum.Targets.Python + , Nirum.Version + build-depends: base >=4.7 && <5 + , containers >=0.5.6.2 && <0.6 + , cmdargs >=0.10.14 && <0.11 + , directory >=1.2.5 && <1.3 + , filepath >=1.4 && <1.5 + , interpolatedstring-perl6 >=1.0.0 && <1.1.0 + , megaparsec >=5 && <5.1 + , semver >=0.3.0 && <1.0 + , text >=0.9.1.0 && <1.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -fwarn-incomplete-uni-patterns + +executable nirum + build-depends: base >=4.7 && <5 + , nirum + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -fwarn-incomplete-uni-patterns + -threaded -with-rtsopts=-N + +executable nirum-static + build-depends: base >=4.7 && <5 + , nirum + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -fwarn-incomplete-uni-patterns + -threaded -with-rtsopts=-N + -static + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Nirum.CliSpec + , Nirum.Constructs.AnnotationSpec + , Nirum.Constructs.DeclarationSpec + , Nirum.Constructs.DeclarationSetSpec + , Nirum.Constructs.IdentifierSpec + , Nirum.Constructs.ModuleSpec + , Nirum.Constructs.ModulePathSpec + , Nirum.Constructs.NameSpec + , Nirum.Constructs.TypeDeclarationSpec + , Nirum.Constructs.TypeExpressionSpec + , Nirum.PackageSpec + , Nirum.ParserSpec + , Nirum.Targets.PythonSpec + , Nirum.VersionSpec + default-language: Haskell2010 + build-depends: base >=4.7 && <5 + , containers >=0.5.6.2 && <0.6 + , directory + , filepath >=1.4 && <1.5 + , hspec + , hspec-core + , hspec-meta + , interpolatedstring-perl6 >=1.0.0 && <1.1.0 + , megaparsec >=5 && <5.1 + , nirum + , process >=1.1 && <2 + , semigroups + , semver >=0.3.0 && <1.0 + , temporary >=1.2 && <1.3 + , text >=0.9.1.0 && <1.3 + ghc-options: -fno-warn-incomplete-uni-patterns + -fno-warn-missing-signatures + -threaded -with-rtsopts=-N + +test-suite hlint + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: HLint.hs + default-language: Haskell2010 + build-depends: base >=4.7 && <5 + , hlint >=1.9 && <2 diff --git a/src/Nirum/Cli.hs b/src/Nirum/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Cli.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings, QuasiQuotes, + DeriveDataTypeable #-} +module Nirum.Cli (main, writeFiles) where + +import Control.Monad (forM_) +import GHC.Exts (IsList(toList)) +import System.IO.Error (catchIOError, ioeGetErrorString) + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.IO as TI +import System.Console.CmdArgs.Implicit ( Data + , Typeable + , argPos + , cmdArgs + , explicit + , help + , name + , program + , summary + , typDir + , (&=) + ) +import System.Console.CmdArgs.Default (def) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory, ()) +import Text.InterpolatedString.Perl6 (qq) +import Text.Megaparsec (Token) +import Text.Megaparsec.Error ( Dec + , ParseError(errorPos) + , parseErrorPretty + ) +import Text.Megaparsec.Pos (SourcePos(sourceLine, sourceColumn), unPos) + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Identifier (toText) +import Nirum.Constructs.ModulePath (ModulePath) +import Nirum.Package ( PackageError(ParseError, ImportError, ScanError) + , ImportError ( CircularImportError + , MissingImportError + , MissingModulePathError + ) + , scanModules + , scanPackage + ) +import Nirum.Targets.Python (compilePackage) +import Nirum.Version (versionString) + +data NirumCli = NirumCli { sourcePath :: FilePath + , objectPath :: FilePath + } deriving (Show, Data, Typeable) + +parseErrortoPrettyMessage :: ParseError (Token T.Text) Dec + -> FilePath + -> IO String +parseErrortoPrettyMessage parseError' filePath' = do + sourceCode <- readFile filePath' + let sourceLines = lines sourceCode + sl = if length sourceLines < errorLine then "" + else sourceLines !! (errorLine - 1) + return [qq| +{parseErrorPretty $ parseError'} +$sl +{arrow} +|] + where + error' :: SourcePos + error' = head $ toList $ errorPos parseError' + errorLine :: Int + errorLine = fromEnum $ unPos $ sourceLine error' + errorColumn :: Int + errorColumn = fromEnum $ unPos $ sourceColumn error' + arrow :: T.Text + arrow = T.snoc (T.concat (replicate (errorColumn - 1) (T.pack " "))) '^' + +toModuleNameText :: T.Text -> T.Text +toModuleNameText t = [qq|'{t}'|] + +modulePathToRepr :: ModulePath -> T.Text +modulePathToRepr = toModuleNameText . toCode + +importErrorToPrettyMessage :: ImportError -> T.Text +importErrorToPrettyMessage (CircularImportError modulePaths) = + [qq|Circular import detected in following orders: $order|] + where + circularModulesText :: [ModulePath] -> [T.Text] + circularModulesText = map modulePathToRepr + order :: T.Text + order = T.intercalate " > " $ circularModulesText modulePaths +importErrorToPrettyMessage (MissingModulePathError path path') = + [qq|No module named $dataName in $moduleName|] + where + moduleName :: T.Text + moduleName = modulePathToRepr path + dataName :: T.Text + dataName = modulePathToRepr path' +importErrorToPrettyMessage (MissingImportError path path' identifier) = + [qq|Cannot import $importText from $attrText in $foundText|] + where + importText :: T.Text + importText = (toModuleNameText . toText) identifier + foundText :: T.Text + foundText = modulePathToRepr path + attrText :: T.Text + attrText = modulePathToRepr path' + + +importErrorsToMessageList :: S.Set ImportError -> [T.Text] +importErrorsToMessageList importErrors = + S.toList $ S.map importErrorToPrettyMessage importErrors +importErrorsToPrettyMessage :: S.Set ImportError -> String +importErrorsToPrettyMessage importErrors = + T.unpack $ T.intercalate "\n" withListStyleText + where + withListStyleText :: [T.Text] + withListStyleText = + map (T.append "- ") (importErrorsToMessageList importErrors) + +nirumCli :: NirumCli +nirumCli = NirumCli { objectPath = def &= explicit + &= name "o" &= name "output-dir" &= typDir + &= help "The directory to place object files" + , sourcePath = def &= argPos 1 &= typDir + } + &= program "nirum" + &= summary ("Nirum Compiler " ++ versionString) + +main' :: IO () +main' = do + NirumCli src obj <- cmdArgs nirumCli + scanResult <- scanPackage src + case scanResult of + Left (ParseError modulePath error') -> do + -- FIXME: find more efficient way to determine filename from + -- the given module path + filePaths <- scanModules src + case M.lookup modulePath filePaths of + Just filePath' -> do + m <- parseErrortoPrettyMessage error' filePath' + putStrLn m + Nothing -> putStrLn [qq|$modulePath not found|] + Left (ImportError importErrors) -> + putStrLn [qq|Import error: +{importErrorsToPrettyMessage importErrors} +|] + Left (ScanError _ error') -> putStrLn [qq|Scan error: $error'|] + Right pkg -> writeFiles obj $ compilePackage pkg + +writeFiles :: FilePath -> M.Map FilePath (Either T.Text T.Text) -> IO () +writeFiles obj m = + forM_ files $ \(filePath, result) -> + case result of + Left compileError -> putStrLn [qq|error: $filePath: $compileError|] + Right code -> do + createDirectoryIfMissing True $ takeDirectory filePath + putStrLn filePath + TI.writeFile filePath code + where + files :: [(FilePath, Either T.Text T.Text)] + files = [(obj f, r) | (f, r) <- M.toList m] + +main :: IO () +main = catchIOError main' $ putStrLn . ioeGetErrorString diff --git a/src/Nirum/Constructs.hs b/src/Nirum/Constructs.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs.hs @@ -0,0 +1,6 @@ +module Nirum.Constructs (Construct, toCode) where + +import Data.Text (Text) + +class (Eq a, Ord a) => Construct a where + toCode :: a -> Text diff --git a/src/Nirum/Constructs/Annotation.hs b/src/Nirum/Constructs/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Annotation.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Nirum.Constructs.Annotation ( Annotation(Annotation) + , AnnotationSet(AnnotationSet) + , Metadata + , NameDuplication(AnnotationNameDuplication) + , annotations + , empty + , fromList + , toCode + , toList + ) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import Text.InterpolatedString.Perl6 (qq) + +import Nirum.Constructs (Construct (toCode)) +import Nirum.Constructs.Identifier (Identifier) + + +type Metadata = T.Text + +-- | Annotation for 'Declaration'. +data Annotation = Annotation { name :: Identifier + , metadata :: Maybe Metadata + } deriving (Eq, Ord, Show) + +instance Construct Annotation where + toCode Annotation {name = n, metadata = Just m} = + let m' = T.replace "\"" "\\\"" m in [qq|@{toCode n}("$m'")|] + toCode Annotation {name = n, metadata = Nothing} = [qq|@{toCode n}|] + +data AnnotationSet + -- | The set of 'Annotation' values. + -- Every annotation name has to be unique in the set. + = AnnotationSet { annotations :: M.Map Identifier Annotation } + deriving (Eq, Ord, Show) + +instance Construct AnnotationSet where + toCode AnnotationSet {annotations = annotations'} = + T.concat [s | e <- M.elems annotations', s <- [toCode e, "\n"]] + +data NameDuplication = AnnotationNameDuplication Identifier + deriving (Eq, Ord, Show) + +empty :: AnnotationSet +empty = AnnotationSet { annotations = M.empty } + +fromList :: [Annotation] -> Either NameDuplication AnnotationSet +fromList annotations' = + case findDup names S.empty of + Just duplication -> Left (AnnotationNameDuplication duplication) + _ -> Right AnnotationSet { annotations = M.fromList [ (name a, a) + | a <- annotations' + ] + } + where + names :: [Identifier] + names = [name a | a <- annotations'] + findDup :: [Identifier] -> S.Set Identifier -> Maybe Identifier + findDup identifiers dups = + case identifiers of + x:xs -> if x `S.member` dups + then Just x + else findDup xs $ S.insert x dups + _ -> Nothing + +toList :: AnnotationSet -> [Annotation] +toList AnnotationSet { annotations = annotations' } = M.elems annotations' diff --git a/src/Nirum/Constructs/Declaration.hs b/src/Nirum/Constructs/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Declaration.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.Declaration ( Declaration + , Docs(Docs) + , docs + , name + , toCode + , toCodeWithPrefix + , toText + ) where + +import Data.String (IsString(fromString)) + +import qualified Data.Text as T + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Name (Name) + +-- 'Construct' which has its own unique 'name' and can has its 'docs'. +class Construct a => Declaration a where + name :: a -> Name + docs :: a -> Maybe Docs + +-- | Docstring for constructs. +data Docs = Docs T.Text deriving (Eq, Ord, Show) + +-- | Convert the docs to text. +toText :: Docs -> T.Text +toText (Docs docs') = docs' + +-- | Similar to 'toCode' except it takes 'Maybe Docs' instead of 'Docs'. +-- If the given docs is 'Nothing' it simply returns an empty string. +-- Otherwise it returns a code string with the prefix. +toCodeWithPrefix :: T.Text -- | The prefix to be prepended if not empty. + -> Maybe Docs -- | The docs to convert to code. + -> T.Text +toCodeWithPrefix _ Nothing = "" +toCodeWithPrefix prefix (Just docs') = T.append prefix $ toCode docs' + +instance Construct Docs where + toCode (Docs docs') = let d = if "\n" `T.isSuffixOf` docs' + then T.dropEnd 1 docs' + else docs' + in T.append "# " $ T.replace "\n" "\n# " d + +instance IsString Docs where + fromString s = let t = T.pack s + in Docs (if "\n" `T.isSuffixOf` t + then t + else t `T.snoc` '\n') diff --git a/src/Nirum/Constructs/DeclarationSet.hs b/src/Nirum/Constructs/DeclarationSet.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/DeclarationSet.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedLists, TypeFamilies #-} +module Nirum.Constructs.DeclarationSet ( DeclarationSet() + , NameDuplication( BehindNameDuplication + , FacialNameDuplication + ) + , empty + , fromList + , lookup + , lookup' + , null + , null' + , size + , toList + , union + , (!) + ) where + +import Data.Maybe (fromJust) +import qualified GHC.Exts as L +import Prelude hiding (lookup, null) + +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Nirum.Constructs.Declaration (Declaration(name)) +import Nirum.Constructs.Identifier (Identifier) +import Nirum.Constructs.Name (Name(Name, behindName, facialName)) + +data Declaration a => DeclarationSet a + -- | The set of 'Declaration' values. + -- Every 'name' has to be unique in the set. + -- The order of declarations is maintained. + = DeclarationSet { declarations :: M.Map Identifier a + , index :: ![Identifier] + } + deriving (Eq, Ord, Show) + +data NameDuplication = FacialNameDuplication !Name + | BehindNameDuplication !Name + deriving (Eq, Show) + +empty :: Declaration a => DeclarationSet a +empty = DeclarationSet { declarations = M.empty + , index = [] + } + +fromList :: Declaration a => [a] -> Either NameDuplication (DeclarationSet a) +fromList declarations' = + case findDup names facialName S.empty of + Just dup -> Left $ FacialNameDuplication dup + _ -> case findDup names behindName S.empty of + Just dup -> Left $ BehindNameDuplication dup + _ -> Right DeclarationSet { declarations = M.fromList mapList + , index = index' + } + where + names :: [Name] + names = map name declarations' + index' :: [Identifier] + index' = map facialName names + mapList = [(facialName (name d), d) | d <- declarations'] + findDup :: [Name] -> (Name -> Identifier) -> S.Set Identifier -> Maybe Name + findDup names' f dups = + case names' of + x:xs -> let name' = f x + in if name' `S.member` dups + then Just x + else findDup xs f $ S.insert name' dups + _ -> Nothing + +toList :: Declaration a => DeclarationSet a -> [a] +toList (DeclarationSet declarations' index') = + map ((M.!) declarations') index' + +size :: Declaration a => DeclarationSet a -> Int +size (DeclarationSet declarations' _) = M.size declarations' + +null :: Declaration a => DeclarationSet a -> Bool +null = null' + +null' :: Declaration a => DeclarationSet a -> Bool +null' (DeclarationSet declarations' _) = M.null declarations' + +lookup :: Declaration a => Identifier -> DeclarationSet a -> Maybe a +lookup = lookup' + +lookup' :: Declaration a => Identifier -> DeclarationSet a -> Maybe a +lookup' facialName' (DeclarationSet declarations' _) = + M.lookup facialName' declarations' + +(!) :: Declaration a => DeclarationSet a -> Identifier -> a +declarationSet ! facialName' = fromJust $ lookup' facialName' declarationSet + +union :: Declaration a + => DeclarationSet a + -> DeclarationSet a + -> Either NameDuplication (DeclarationSet a) +union a b = fromList $ toList a ++ toList b + +instance (Declaration a) => L.IsList (DeclarationSet a) where + type Item (DeclarationSet a) = a + fromList declarations' = + case fromList declarations' of + Right set -> set + Left (FacialNameDuplication (Name fname _)) -> + error ("identifiers must be unique; " ++ show fname ++ + " is defined more than once") + Left (BehindNameDuplication (Name _ bname)) -> + error ("behind names must be unique; " ++ show bname ++ + " is defined more than once") + toList = toList diff --git a/src/Nirum/Constructs/Identifier.hs b/src/Nirum/Constructs/Identifier.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Identifier.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.Constructs.Identifier ( Identifier + , fromString + , fromText + , identifierRule + , normalize + , reservedKeywords + , show + , toCode + , tokens + , toCamelCaseText + , toNormalizedString + , toNormalizedText + , toString + , toSnakeCaseText + , toText + , toPascalCaseText + , toLispCaseText + , (==) + ) where + +import Data.Char (toLower, toUpper) +import Data.Maybe (fromMaybe) +import Data.String (IsString(fromString)) + +import qualified Data.Text as T +import qualified Data.Set as S +import qualified Text.Megaparsec as P +import Text.Megaparsec.Char (oneOf, satisfy) +import Text.Megaparsec.Text (Parser) + +import Nirum.Constructs (Construct(toCode)) + +-- | Case-insensitive identifier. It also doesn't distinguish hyphens +-- from underscores. +-- +-- It has more restrict rules than the most of programming languages: +-- +-- * It can't start with digits or hyphens/underscores. +-- * Hyphens/underscores can't continuously appear more than once. +-- * Only roman alphabets, Arabic numerals, hyphens and underscores +-- are allowed. +-- +-- These rules are for portability between various programming languages. +-- For example, @BOOK_CATEGORY@ and @Book-Category@ are all normalized +-- to @book-category@, and it can be translated to: +-- +-- [snake_case] @book_category@ +-- [camelCase] @bookCategory@ +-- [PascalCase] @BookCategory@ +-- [lisp-case] @book-category@ +data Identifier = Identifier T.Text deriving (Show) + +reservedKeywords :: S.Set Identifier +reservedKeywords = [ "boxed" + , "enum" + , "record" + , "service" + , "throws" + , "type" + , "union" + ] + +identifierRule :: Parser Identifier +identifierRule = do + firstChar <- satisfy isAlpha + restChars <- P.many $ satisfy isAlnum + restWords <- P.many $ do + sep <- oneOf ("-_" :: String) + chars <- P.some $ satisfy isAlnum + return $ T.pack $ sep:chars + return $ Identifier $ T.concat $ T.pack (firstChar : restChars) : restWords + where + isAlpha :: Char -> Bool + isAlpha c = 'a' <= c && c <= 'z' || 'A' <= c && c <= 'Z' + isDigit :: Char -> Bool + isDigit c = '0' <= c && c <= '9' + isAlnum :: Char -> Bool + isAlnum c = isAlpha c || isDigit c + +-- | Constructs a 'Identifier' value from the given identifier string. +-- It could return 'Nothing' if the given identifier is invalid. +fromText :: T.Text -> Maybe Identifier +fromText text = + case P.parse rule "" text of + Right ident -> Just ident + Left _ -> Nothing + where + rule :: Parser Identifier + rule = do + identifier' <- identifierRule + _ <- P.eof + return identifier' + +normalize :: Identifier -> Identifier +normalize (Identifier i) = + Identifier $ T.map (\c -> if c == '_' then '-' else toLower c) i + +toText :: Identifier -> T.Text +toText (Identifier text) = text + +toNormalizedText :: Identifier -> T.Text +toNormalizedText = toText . normalize + +tokens :: Identifier -> [T.Text] +tokens ident = T.split (== '-') $ toText $ normalize ident + +instance Eq Identifier where + a@(Identifier _) == b@(Identifier _) = + toNormalizedText a == toNormalizedText b + +instance Ord Identifier where + compare a@(Identifier _) b@(Identifier _) = + compare (toNormalizedText a) (toNormalizedText b) + +instance Construct Identifier where + toCode ident + | ident `S.member` reservedKeywords = '`' `T.cons` text `T.snoc` '`' + | otherwise = text + where + text = toText ident + +instance IsString Identifier where + fromString string = fromMaybe (error $ "invalid identifier: " ++ string) $ + fromText (T.pack string) + +toString :: Identifier -> String +toString = T.unpack . toText + +toNormalizedString :: Identifier -> String +toNormalizedString = T.unpack . toNormalizedText + +toPascalCaseText :: Identifier -> T.Text +toPascalCaseText identifier = + T.concat $ fmap makeFirstUpper (tokens identifier) + where + makeFirstUpper :: T.Text -> T.Text + makeFirstUpper t = toUpper (T.head t) `T.cons` T.tail t + +toCamelCaseText :: Identifier -> T.Text +toCamelCaseText identifier = + toLower (T.head pascalCased) `T.cons` T.tail pascalCased + where + pascalCased :: T.Text + pascalCased = toPascalCaseText identifier + +toSnakeCaseText :: Identifier -> T.Text +toSnakeCaseText identifier = T.intercalate "_" $ tokens identifier + +toLispCaseText :: Identifier -> T.Text +toLispCaseText = toNormalizedText diff --git a/src/Nirum/Constructs/Module.hs b/src/Nirum/Constructs/Module.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Module.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes #-} +module Nirum.Constructs.Module ( Module(Module, docs, types) + , coreModule + , coreModulePath + , coreTypes + , imports + ) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import Text.InterpolatedString.Perl6 (q) + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Annotation (empty) +import Nirum.Constructs.Declaration (Docs) +import qualified Nirum.Constructs.DeclarationSet as DS +import Nirum.Constructs.Identifier (Identifier) +import Nirum.Constructs.ModulePath (ModulePath) +import Nirum.Constructs.TypeDeclaration ( JsonType(..) + , PrimitiveTypeIdentifier(..) + , Type(..) + , TypeDeclaration(..) + ) + +data Module = Module { types :: DS.DeclarationSet TypeDeclaration + , docs :: Maybe Docs + } deriving (Eq, Ord, Show) + +instance Construct Module where + toCode m@(Module types' docs') = + T.concat [ maybe "" ((`T.snoc` '\n') . toCode) docs' + , T.intercalate "\n" importCodes + , if null importCodes then "\n" else "\n\n" + , T.intercalate "\n\n" typeCodes + , "\n" + ] + where + typeList :: [TypeDeclaration] + typeList = DS.toList types' + importCodes :: [T.Text] + importCodes = + [ T.concat [ "import ", toCode p, " (" + , T.intercalate ", " $ map toCode $ S.toAscList i + , ");" + ] + | (p, i) <- M.toAscList (imports m) + ] + typeCodes :: [T.Text] + typeCodes = [ toCode t + | t <- typeList + , case t of + Import {} -> False + _ -> True + ] + +imports :: Module -> M.Map ModulePath (S.Set Identifier) +imports (Module decls _) = + M.fromListWith S.union [(p, [i]) | Import p i <- DS.toList decls] + +coreModulePath :: ModulePath +coreModulePath = ["core"] + +coreModule :: Module +coreModule = Module coreTypes $ Just coreDocs + +coreTypes :: DS.DeclarationSet TypeDeclaration +coreTypes = + -- number types + [ TypeDeclaration "bigint" (PrimitiveType Bigint String) Nothing empty + , TypeDeclaration "decimal" (PrimitiveType Decimal String) Nothing empty + , TypeDeclaration "int32" (PrimitiveType Int32 Number) Nothing empty + , TypeDeclaration "int64" (PrimitiveType Int64 Number) Nothing empty + , TypeDeclaration "float32" (PrimitiveType Float32 Number) Nothing empty + , TypeDeclaration "float64" (PrimitiveType Float64 Number) Nothing empty + -- string types + , TypeDeclaration "text" (PrimitiveType Text String) Nothing empty + , TypeDeclaration "binary" (PrimitiveType Binary String) Nothing empty + -- time types + , TypeDeclaration + "date" (PrimitiveType Date String) Nothing empty + , TypeDeclaration + "datetime" (PrimitiveType Datetime String) Nothing empty + -- et cetera + , TypeDeclaration "bool" (PrimitiveType Bool Boolean) Nothing empty + , TypeDeclaration "uuid" (PrimitiveType Uuid String) Nothing empty + , TypeDeclaration "uri" (PrimitiveType Uri String) Nothing empty + ] + +coreDocs :: Docs +coreDocs = [q| +Built-in types +============== + +The core module is implicitly imported by every module so that built-in types +are available everywhere. + +TBD. + +|] diff --git a/src/Nirum/Constructs/ModulePath.hs b/src/Nirum/Constructs/ModulePath.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/ModulePath.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +module Nirum.Constructs.ModulePath ( ModulePath( ModuleName + , ModulePath + , moduleName + , path + ) + , ancestors + , fromFilePath + , fromIdentifiers + ) where + +import Data.Char (toLower) +import Data.Maybe (fromMaybe, mapMaybe) +import GHC.Exts (IsList(Item, fromList, toList)) + +import Data.Set (Set, insert, singleton) +import Data.Text (intercalate, pack) +import System.FilePath (splitDirectories, stripExtension) + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Identifier (Identifier, fromText) + +data ModulePath = ModulePath { path :: ModulePath + , moduleName :: Identifier } + | ModuleName { moduleName :: Identifier } + deriving (Eq, Ord, Show) + +instance Construct ModulePath where + toCode = intercalate "." . map toCode . toList + +fromIdentifiers :: [Identifier] -> Maybe ModulePath +fromIdentifiers [] = Nothing +fromIdentifiers [identifier] = Just $ ModuleName identifier +fromIdentifiers identifiers = fmap (`ModulePath` last identifiers) init' + where + init' :: Maybe ModulePath + init' = fromIdentifiers $ init identifiers + +fromFilePath :: FilePath -> Maybe ModulePath +fromFilePath filePath = + if length fileIdentifiers == length paths + then fromIdentifiers fileIdentifiers + else Nothing + where + replaceLast :: (a -> a) -> [a] -> [a] + replaceLast _ [] = [] + replaceLast f l = init l ++ [f $ last l] + paths :: [FilePath] + paths = replaceLast (fromMaybe "" . stripExtension "nrm" . map toLower) + (splitDirectories filePath) + fileIdentifiers :: [Identifier] + fileIdentifiers = mapMaybe (fromText . pack) paths + +ancestors :: ModulePath -> Set ModulePath +ancestors m@ModuleName {} = singleton m +ancestors m@(ModulePath parent _) = m `insert` ancestors parent + +instance IsList ModulePath where + type Item ModulePath = Identifier + fromList identifiers = + fromMaybe (error "ModulePath cannot be empty") + (fromIdentifiers identifiers) + toList (ModuleName identifier) = [identifier] + toList (ModulePath path' identifier) = toList path' ++ [identifier] diff --git a/src/Nirum/Constructs/Name.hs b/src/Nirum/Constructs/Name.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Name.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.Name ( Name(Name) + , behindName + , facialName + , isComplex + , isSimple + , toCode + ) where + +import Data.String (IsString(fromString)) + +import Data.Text (append, snoc) + +import Nirum.Constructs (Construct) +import Nirum.Constructs.Identifier (Identifier, toCode) + +-- | Name consists of a 'facialName' and a 'behindName'. +-- The 'behindName' is for internal coding, while the 'facialName' is for +-- human-readable identifier of programming language bindings. +-- +-- If 'behind_Name' is omitted, 'facialName' is used also for +-- 'behindName'. Explicit 'behindName' is useful to maintain +-- old name for backward compatibility with new 'facialName'. +data Name = Name { facialName :: Identifier + , behindName :: Identifier + } deriving (Eq, Ord, Show) + +isSimple :: Name -> Bool +isSimple (Name f b) = f == b + +isComplex :: Name -> Bool +isComplex = not . isSimple + +instance Construct Name where + toCode name@(Name facial behind) + | isSimple name = toCode facial + | otherwise = (toCode facial `snoc` '/') `append` toCode behind + +instance IsString Name where + fromString s = + Name { facialName = identifier, behindName = identifier } + where + identifier :: Identifier + identifier = fromString s diff --git a/src/Nirum/Constructs/Service.hs b/src/Nirum/Constructs/Service.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/Service.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.Service ( Method ( Method + , methodAnnotations + , methodDocs + , methodName + , parameters + , returnType + ) + , Parameter(Parameter) + , Service(Service, methods) + ) where + +import qualified Data.Text as T + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Annotation (AnnotationSet) +import Nirum.Constructs.Declaration ( Declaration(name, docs) + , Docs + , toCodeWithPrefix + ) +import Nirum.Constructs.DeclarationSet (DeclarationSet, toList) +import Nirum.Constructs.Name (Name) +import Nirum.Constructs.TypeExpression (TypeExpression) + +-- | 'Method' parameter. +data Parameter = Parameter Name TypeExpression (Maybe Docs) + deriving (Eq, Ord, Show) + +instance Construct Parameter where + toCode (Parameter name' typeExpr docs') = + T.concat [ toCode typeExpr + , " " + , toCode name' + , "," + , toCodeWithPrefix "\n" docs' + ] + +instance Declaration Parameter where + name (Parameter name' _ _) = name' + docs (Parameter _ _ docs') = docs' + +-- | 'Service' method. +data Method = Method { methodName :: Name + , parameters :: DeclarationSet Parameter + , returnType :: TypeExpression + , errorType :: Maybe TypeExpression + , methodDocs :: Maybe Docs + , methodAnnotations :: AnnotationSet + } deriving (Eq, Ord, Show) + +instance Construct Method where + toCode method@Method { parameters = params + , errorType = error' + , methodDocs = docs' + , methodAnnotations = annotationSet' + } = + T.concat $ [ toCode annotationSet' + , toCode $ returnType method + , " " + , toCode $ methodName method + , " (" + , toCodeWithPrefix "\n " docs' + ] ++ case (docs', params') of + (Nothing, []) -> [] + (Just _, []) -> ["\n"] + (Nothing, [p@(Parameter _ _ Nothing)]) -> + [T.dropWhileEnd (== ',') $ toCode p] + _ -> [ "\n" + , T.intercalate "\n" $ map indentedCode params' + , "\n" + ] + ++ [")"] + ++ case error' of + Nothing -> [] + Just e -> [" throws ", toCode e] + ++ [","] + where + params' :: [Parameter] + params' = toList params + indentedCode :: Construct a => a -> T.Text + indentedCode c = T.concat [ " " + , T.intercalate "\n " $ T.lines (toCode c) + ] + +instance Declaration Method where + name = methodName + docs = methodDocs + +-- | RPC service. +data Service = + Service { methods :: DeclarationSet Method } deriving (Eq, Ord, Show) diff --git a/src/Nirum/Constructs/TypeDeclaration.hs b/src/Nirum/Constructs/TypeDeclaration.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/TypeDeclaration.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember) + , Field(Field) + , JsonType(..) + , PrimitiveTypeIdentifier(..) + , Tag(Tag) + , Type(..) + , TypeDeclaration( Import + , ServiceDeclaration + , TypeDeclaration + , importName + , modulePath + , service + , serviceAnnotations + , serviceDocs + , serviceName + , type' + , typeAnnotations + , typeDocs + , typename + ) + ) where + +import Data.Maybe (isJust) +import Data.String (IsString(fromString)) + +import qualified Data.Text as T + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Annotation (AnnotationSet) +import Nirum.Constructs.Declaration ( Declaration (..) + , Docs (..) + , toCodeWithPrefix + ) +import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList) +import Nirum.Constructs.Identifier (Identifier) +import Nirum.Constructs.ModulePath (ModulePath) +import Nirum.Constructs.Name (Name(Name)) +import Nirum.Constructs.Service ( Method (Method, methodDocs) + , Service (Service) + ) +import Nirum.Constructs.TypeExpression (TypeExpression) + +data Type + = Alias { canonicalType :: TypeExpression } + | BoxedType { innerType :: TypeExpression } + | EnumType { members :: DeclarationSet EnumMember } + | RecordType { fields :: DeclarationSet Field } + | UnionType { tags :: DeclarationSet Tag } + | PrimitiveType { primitiveTypeIdentifier :: PrimitiveTypeIdentifier + , jsonType :: JsonType + } + deriving (Eq, Ord, Show) + +-- | Member of 'EnumType'. +data EnumMember = EnumMember Name (Maybe Docs) deriving (Eq, Ord, Show) + +instance Construct EnumMember where + toCode (EnumMember name' docs') = T.concat [ toCode name' + , toCodeWithPrefix "\n" docs' + ] + +instance Declaration EnumMember where + name (EnumMember name' _) = name' + docs (EnumMember _ docs') = docs' + +instance IsString EnumMember where + fromString s = EnumMember (fromString s) Nothing + +-- | Field of 'RecordType' and 'Tag'. +data Field = Field Name TypeExpression (Maybe Docs) deriving (Eq, Ord, Show) + +instance Construct Field where + toCode (Field name' typeExpr docs') = T.concat [ toCode typeExpr + , " " + , toCode name' + , "," + , toCodeWithPrefix "\n" docs' + ] + +instance Declaration Field where + name (Field name' _ _) = name' + docs (Field _ _ docs') = docs' + +-- | Tag of 'UnionType'. +data Tag = Tag Name (DeclarationSet Field) (Maybe Docs) deriving (Eq, Ord, Show) + +instance Construct Tag where + toCode (Tag name' fields' docs') = + if null' fields' + then T.concat [toCode name', toCodeWithPrefix "\n" docs'] + else T.concat [ toCode name' + , " (", fieldsCode, ")" + , toCodeWithPrefix "\n" docs' + ] + where + fieldsCode = T.intercalate " " $ map toCode $ toList fields' + +instance Declaration Tag where + name (Tag name' _ _) = name' + docs (Tag _ _ docs') = docs' + +-- | Primitive type identifiers. +data PrimitiveTypeIdentifier + = Bigint | Decimal | Int32 | Int64 | Float32 | Float64 | Text | Binary + | Date | Datetime | Bool | Uuid | Uri + deriving (Eq, Ord, Show) + +-- | Possible coded types of 'PrimitiveType' in JSON representation. +data JsonType = Boolean | Number | String deriving (Eq, Ord, Show) + +-- Top-level 'Declaration' of type. +data TypeDeclaration + = TypeDeclaration { typename :: Name + , type' :: Type + , typeDocs :: Maybe Docs + , typeAnnotations :: AnnotationSet + } + | ServiceDeclaration { serviceName :: Name + , service :: Service + , serviceDocs :: Maybe Docs + , serviceAnnotations :: AnnotationSet + } + | Import { modulePath :: ModulePath + , importName :: Identifier + } + deriving (Eq, Ord, Show) + +instance Construct TypeDeclaration where + toCode (TypeDeclaration name' (Alias cname) docs' annotationSet') = + T.concat [ toCode annotationSet' + , "type ", toCode name' + , " = ", toCode cname, ";" + , toCodeWithPrefix "\n" docs' + ] + toCode (TypeDeclaration name' (BoxedType itype) docs' annotationSet') = + T.concat [ toCode annotationSet' + , "boxed ", toCode name' + , " (", toCode itype, ");" + , toCodeWithPrefix "\n" docs'] + toCode (TypeDeclaration name' (EnumType members') docs' annotationSet') = + T.concat [ toCode annotationSet' + , "enum ", toCode name' + , toCodeWithPrefix "\n " docs' + , "\n = ", T.replace "\n" "\n " membersCode, "\n ;" + ] + where + membersCode = T.intercalate "\n| " $ map toCode $ toList members' + toCode (TypeDeclaration name' (RecordType fields') docs' annotationSet') = + T.concat [ toCode annotationSet' + , "record ", toCode name', " (" + , toCodeWithPrefix "\n " docs' + , if isJust docs' then "\n" else "" + , T.replace "\n" "\n " $ T.cons '\n' fieldsCode + , "\n);" + ] + where + fieldsCode = T.intercalate "\n" $ map toCode $ toList fields' + toCode (TypeDeclaration name' (UnionType tags') docs' annotationSet') = + T.concat [ toCode annotationSet' + , "union ", nameCode + , toCodeWithPrefix "\n " docs' + , "\n = " , tagsCode + , "\n ;" + ] + where + nameCode :: T.Text + nameCode = toCode name' + tagsCode :: T.Text + tagsCode = T.intercalate "\n | " + [ T.replace "\n" "\n " (toCode t) + | t <- toList tags' + ] + toCode (TypeDeclaration name' + (PrimitiveType typename' jsonType') + docs' + annotationSet') = + T.concat [ toCode annotationSet' + , "// primitive type `", toCode name', "`\n" + , "// internal type identifier: ", showT typename', "\n" + , "// coded to json ", showT jsonType', " type\n" + , docString docs' + ] + where + showT :: Show a => a -> T.Text + showT = T.pack . show + docString :: Maybe Docs -> T.Text + docString Nothing = "" + docString (Just (Docs d)) = + T.concat ["\n// ", T.replace "\n" "\n// " $ T.stripEnd d, "\n"] + toCode (ServiceDeclaration name' (Service methods) docs' annotations') = + T.concat [ toCode annotations' + , "service " + , toCode name' + , " (" + , toCodeWithPrefix "\n " docs' + , case (docs', methods') of + (_, []) -> "" + (Nothing, [Method { methodDocs = Nothing }]) -> "" + _ -> "\n " + , if length methods' > 1 + then methodsText + else T.dropWhileEnd (== ',') (T.strip methodsText) + , case docs' of + Nothing -> "" + Just _ -> "\n" + , ");" + ] + where + methods' :: [Method] + methods' = toList methods + methodsText :: T.Text + methodsText = T.intercalate "\n" $ map toCode methods' + toCode (Import path ident) = T.concat [ "import " + , toCode path + , " (" + , toCode ident + , ");\n" + ] + +instance Declaration TypeDeclaration where + name (TypeDeclaration name' _ _ _) = name' + name (ServiceDeclaration name' _ _ _) = name' + name (Import _ identifier) = Name identifier identifier + docs (TypeDeclaration _ _ docs' _) = docs' + docs (ServiceDeclaration _ _ docs' _) = docs' + docs (Import _ _) = Nothing diff --git a/src/Nirum/Constructs/TypeExpression.hs b/src/Nirum/Constructs/TypeExpression.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Constructs/TypeExpression.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.TypeExpression (TypeExpression(..), toCode) where + +import Data.String (IsString(fromString)) + +import qualified Data.Text as T + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Identifier (Identifier) + +-- | Refers a type. +data TypeExpression + = TypeIdentifier { identifier :: Identifier } + | OptionModifier { type' :: TypeExpression } + | SetModifier { elementType :: TypeExpression } + | ListModifier { elementType :: TypeExpression } + | MapModifier { keyType :: TypeExpression + , valueType :: TypeExpression + } + deriving (Eq, Ord, Show) + +instance Construct TypeExpression where + toCode (TypeIdentifier id') = toCode id' + toCode (OptionModifier type_) = toCode type_ `T.snoc` '?' + toCode (SetModifier element) = + '{' `T.cons` toCode element `T.snoc` '}' + toCode (ListModifier element) = + '[' `T.cons` toCode element `T.snoc` ']' + toCode (MapModifier key value) = + T.concat ["{", toCode key, ": ", toCode value, "}"] + +instance IsString TypeExpression where + fromString string = TypeIdentifier (fromString string :: Identifier) diff --git a/src/Nirum/Package.hs b/src/Nirum/Package.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Package.hs @@ -0,0 +1,209 @@ +module Nirum.Package ( BoundModule(boundPackage, modulePath) + , ImportError ( CircularImportError + , MissingImportError + , MissingModulePathError + ) + , Package(modules) + , PackageError(ImportError, ParseError, ScanError) + , TypeLookup(Imported, Local, Missing) + , docs + , findInBoundModule + , lookupType + , makePackage + , resolveBoundModule + , resolveModule + , scanModules + , scanPackage + , types + ) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import System.Directory (doesDirectoryExist, listDirectory) +import System.FilePath (()) + +import Nirum.Constructs.Declaration (Docs) +import qualified Nirum.Constructs.DeclarationSet as DS +import Nirum.Constructs.Identifier (Identifier) +import qualified Nirum.Constructs.Module as Mod +import Nirum.Constructs.ModulePath (ModulePath, fromFilePath) +import Nirum.Constructs.TypeDeclaration ( Type + , TypeDeclaration ( Import + , ServiceDeclaration + , TypeDeclaration + , type' + ) + ) +import Nirum.Parser (ParseError, parseFile) + +-- | Represents a package which consists of modules. +data Package = Package { modules :: M.Map ModulePath Mod.Module + } deriving (Eq, Ord, Show) +-- TODO: uri, version, dependencies + +data ImportError = CircularImportError [ModulePath] + | MissingModulePathError ModulePath ModulePath + | MissingImportError ModulePath ModulePath Identifier + deriving (Eq, Ord, Show) + +makePackage :: M.Map ModulePath Mod.Module -> Either (S.Set ImportError) Package +makePackage modules' + | S.null importErrors = Right package + | otherwise = Left importErrors + where + package :: Package + package = Package modules' + importErrors :: S.Set ImportError + importErrors = detectImportErrors package + +resolveModule :: ModulePath -> Package -> Maybe Mod.Module +resolveModule path Package { modules = ms } = M.lookup path ms + +resolveBoundModule :: ModulePath -> Package -> Maybe BoundModule +resolveBoundModule path package = + case resolveModule path package of + Just _ -> Just $ BoundModule package path + Nothing -> Nothing + +detectImportErrors :: Package -> S.Set ImportError +detectImportErrors package = detectMissingImports package `S.union` + detectCircularImports package + +detectMissingImports :: Package -> S.Set ImportError +detectMissingImports package@Package { modules = ms } = + S.fromList [e | (path, module') <- M.toList ms, e <- detect path module'] + where + detect :: ModulePath -> Mod.Module -> [ImportError] + detect path module' = + [ e + | (path', idents) <- M.toList (Mod.imports module') + , e <- case resolveModule path' package of + Nothing -> [MissingModulePathError path path'] + Just (Mod.Module decls _) -> + [ e + | i <- S.toList idents + , e <- case DS.lookup i decls of + Just TypeDeclaration {} -> [] + Just ServiceDeclaration {} -> [] + Just Import {} -> [MissingImportError path path' i] + Nothing -> [MissingImportError path path' i] + ] + ] + +detectCircularImports :: Package -> S.Set ImportError +detectCircularImports Package { modules = ms } = + S.fromList [e | path <- M.keys ms, e <- detect path []] + where + moduleImports :: M.Map ModulePath (S.Set ModulePath) + moduleImports = + M.fromList [ (path, M.keysSet $ Mod.imports module') + | (path, module') <- M.toList ms + ] + detect :: ModulePath -> [ModulePath] -> [ImportError] + detect path reversedCycle + | path `elem` reversedCycle = + [CircularImportError $ reverse reversedCycle'] + | otherwise = + case M.lookup path moduleImports of + Just paths -> [ e + | path' <- S.toList paths + , e <- detect path' reversedCycle' + ] + Nothing -> [] + where + reversedCycle' :: [ModulePath] + reversedCycle' = path : reversedCycle + +data PackageError = ScanError FilePath IOError + | ParseError ModulePath ParseError + | ImportError (S.Set ImportError) + deriving (Eq, Show) + +-- | Scan the given package path, and then return the read package. +scanPackage :: FilePath -> IO (Either PackageError Package) +scanPackage packagePath = do + modulePaths <- scanModules packagePath + -- FIXME: catch IO errors + modules' <- mapM parseFile modulePaths + return $ case M.foldrWithKey excludeFailedParse (Right M.empty) modules' of + Right parsedModules -> case makePackage parsedModules of + Right p -> Right p + Left errors -> Left $ ImportError errors + Left error' -> Left error' + where + excludeFailedParse :: ModulePath + -> Either ParseError Mod.Module + -> Either PackageError (M.Map ModulePath Mod.Module) + -> Either PackageError (M.Map ModulePath Mod.Module) + excludeFailedParse _ _ (Left error') = Left error' + excludeFailedParse path (Left error') _ = Left $ ParseError path error' + excludeFailedParse path (Right module') (Right map') = + Right (M.insert path module' map') + +-- | Scan the given path recursively, and then return the map of +-- detected module paths. +scanModules :: FilePath -> IO (M.Map ModulePath FilePath) +scanModules packagePath = do + files <- scanFiles "" + return $ M.fromList files + where + isNotHidden :: FilePath -> Bool + isNotHidden ('.':_) = False + isNotHidden _ = True + scanFiles :: FilePath -> IO [(ModulePath, FilePath)] + scanFiles path = do + dir <- doesDirectoryExist realPath + if dir + then do + subpaths <- listDirectory realPath + scans <- mapM (scanFiles . (path )) $ filter isNotHidden subpaths + return $ concat scans + else return $ case fromFilePath path of + Just modulePath' -> [(modulePath', realPath)] + Nothing -> [] + where + realPath :: FilePath + realPath = case path of + [] -> packagePath + p -> packagePath p + +data BoundModule = BoundModule { boundPackage :: Package + , modulePath :: ModulePath + } deriving (Eq, Ord, Show) + +findInBoundModule :: (Mod.Module -> a) -> a -> BoundModule -> a +findInBoundModule valueWhenExist valueWhenNotExist + BoundModule { boundPackage = Package { modules = ms } + , modulePath = path + } = + case M.lookup path ms of + Nothing -> valueWhenNotExist + Just mod' -> valueWhenExist mod' + +types :: BoundModule -> DS.DeclarationSet TypeDeclaration +types = findInBoundModule Mod.types DS.empty + +docs :: BoundModule -> Maybe Docs +docs = findInBoundModule Mod.docs Nothing + +data TypeLookup = Missing + | Local Type + | Imported ModulePath Type + deriving (Eq, Ord, Show) + +lookupType :: Identifier -> BoundModule -> TypeLookup +lookupType identifier boundModule = + case DS.lookup identifier (types boundModule) of + Nothing -> toType Mod.coreModulePath + (DS.lookup identifier $ Mod.types Mod.coreModule) + Just TypeDeclaration { type' = t } -> Local t + Just (Import path _) -> + case resolveModule path (boundPackage boundModule) of + Nothing -> Missing + Just (Mod.Module decls _) -> + toType path (DS.lookup identifier decls) + Just ServiceDeclaration {} -> Missing + where + toType :: ModulePath -> Maybe TypeDeclaration -> TypeLookup + toType mp (Just TypeDeclaration { type' = t }) = Imported mp t + toType _ _ = Missing diff --git a/src/Nirum/Parser.hs b/src/Nirum/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Parser.hs @@ -0,0 +1,567 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Nirum.Parser ( Parser + , ParseError + , aliasTypeDeclaration + , annotation + , annotationSet + , boxedTypeDeclaration + , docs + , enumTypeDeclaration + , file + , handleNameDuplication + , identifier + , imports + , listModifier + , mapModifier + , method + , module' + , modulePath + , name + , optionModifier + , parse + , parseFile + , recordTypeDeclaration + , serviceDeclaration + , setModifier + , typeDeclaration + , typeExpression + , typeExpressionWithoutOptionModifier + , typeIdentifier + , unionTypeDeclaration + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (join, void) +import Data.List (foldl1') +import Prelude hiding (readFile) + +import Data.Set (elems) +import qualified Data.Text as T +import Data.Text.IO (readFile) +import Text.Megaparsec ( Token + , eof + , many + , manyTill + , notFollowedBy + , option + , optional + , runParser + , sepBy1 + , sepEndBy + , sepEndBy1 + , skipMany + , skipSome + , try + , (<|>) + , () + ) +import Text.Megaparsec.Char ( char + , eol + , noneOf + , spaceChar + , string + , string' + ) +import qualified Text.Megaparsec.Error as E +import Text.Megaparsec.Text (Parser) +import Text.Megaparsec.Lexer (charLiteral) + +import qualified Nirum.Constructs.Annotation as A +import Nirum.Constructs.Declaration (Declaration, Docs(Docs)) +import Nirum.Constructs.DeclarationSet ( DeclarationSet + , NameDuplication( BehindNameDuplication + , FacialNameDuplication + ) + , empty + , fromList + ) +import Nirum.Constructs.Identifier ( Identifier + , identifierRule + , reservedKeywords + , toString + ) +import Nirum.Constructs.Module (Module(Module)) +import Nirum.Constructs.ModulePath (ModulePath(ModulePath, ModuleName)) +import Nirum.Constructs.Name (Name(Name)) +import Nirum.Constructs.Service ( Method(Method) + , Parameter(Parameter) + , Service(Service) + ) +import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember) + , Field(Field) + , Tag(Tag) + , Type( Alias + , BoxedType + , EnumType + , RecordType + , UnionType + ) + , TypeDeclaration( Import + , ServiceDeclaration + , TypeDeclaration + ) + ) +import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier + , MapModifier + , OptionModifier + , SetModifier + , TypeIdentifier + ) + ) + +type ParseError = E.ParseError (Token T.Text) E.Dec + +comment :: Parser () +comment = string "//" >> void (many $ noneOf ("\n" :: String)) "comment" + +spaces :: Parser () +spaces = skipMany $ void spaceChar <|> comment + +spaces1 :: Parser () +spaces1 = skipSome $ void spaceChar <|> comment + +identifier :: Parser Identifier +identifier = + quotedIdentifier <|> bareIdentifier "identifier" + where + keywords :: Parser String + keywords = foldl1' (<|>) $ map (string' . toString) $ elems reservedKeywords + bareIdentifier :: Parser Identifier + bareIdentifier = do + notFollowedBy keywords + identifierRule + quotedIdentifier :: Parser Identifier + quotedIdentifier = do + char '`' + identifier' <- identifierRule + char '`' + return identifier' + +name :: Parser Name +name = do + facialName <- identifier "facial name" + behindName <- option facialName $ try $ do + spaces + char '/' + spaces + identifier "behind name" + return $ Name facialName behindName + +annotation :: Parser A.Annotation +annotation = do + char '@' + spaces + name' <- identifier + spaces + metadata <- optional $ do + char '(' + spaces + m <- optional ((char '"' >> manyTill charLiteral (char '"')) + "annotation metadata") + spaces + char ')' + return m + let metadata' = T.pack <$> join metadata + return $ A.Annotation name' metadata' + +annotationSet :: Parser A.AnnotationSet +annotationSet = do + annotations <- many $ do + spaces + a <- annotation + spaces + return a + case A.fromList annotations of + Right annotations' -> return annotations' + Left (A.AnnotationNameDuplication _) -> fail "annotation name duplicate" + +typeExpression :: Parser TypeExpression +typeExpression = + try optionModifier <|> typeExpressionWithoutOptionModifier + "type expression" + +typeExpressionWithoutOptionModifier :: Parser TypeExpression +typeExpressionWithoutOptionModifier = + try setModifier <|> listModifier <|> mapModifier <|> typeIdentifier + +typeIdentifier :: Parser TypeExpression +typeIdentifier = do + typeIdentifier' <- identifier "type identifier" + return $ TypeIdentifier typeIdentifier' + +optionModifier :: Parser TypeExpression +optionModifier = do + expr <- typeExpressionWithoutOptionModifier + spaces + char '?' + return $ OptionModifier expr + +setModifier :: Parser TypeExpression +setModifier = do + char '{' + spaces + expr <- typeExpression "element type of set type" + spaces + char '}' + return $ SetModifier expr + +listModifier :: Parser TypeExpression +listModifier = do + char '[' + spaces + expr <- typeExpression "element type of list type" + spaces + char ']' + return $ ListModifier expr + +mapModifier :: Parser TypeExpression +mapModifier = do + char '{' + spaces + key <- typeExpression "key type of map type" + spaces + char ':' + spaces + value <- typeExpression "value type of map type" + spaces + char '}' + return $ MapModifier key value + +docs :: Parser Docs +docs = do + comments <- sepEndBy1 (do { char '#' + ; void $ optional $ char ' ' + ; line <- many $ noneOf ("\r\n" :: String) + ; return $ T.pack line + }) (eol >> spaces) "comments" + return $ Docs $ T.unlines comments + +aliasTypeDeclaration :: Parser TypeDeclaration +aliasTypeDeclaration = do + annotationSet' <- annotationSet "type alias annotations" + string' "type" "type alias keyword" + spaces + typename <- identifier "alias type name" + let name' = Name typename typename + spaces + char '=' + spaces + canonicalType <- typeExpression "canonical type of alias" + spaces + char ';' + docs' <- optional $ try $ spaces >> (docs "type alias docs") + return $ TypeDeclaration name' (Alias canonicalType) docs' annotationSet' + + +boxedTypeDeclaration :: Parser TypeDeclaration +boxedTypeDeclaration = do + annotationSet' <- annotationSet "boxed type annotations" + string' "boxed" "boxed type keyword" + spaces + typename <- identifier "boxed type name" + let name' = Name typename typename + spaces + char '(' + spaces + innerType <- typeExpression "inner type of boxed type" + spaces + char ')' + spaces + char ';' + docs' <- optional $ try $ spaces >> (docs "boxed type docs") + return $ TypeDeclaration name' (BoxedType innerType) docs' annotationSet' + +enumMember :: Parser EnumMember +enumMember = do + memberName <- name "enum member name" + spaces + docs' <- optional $ do + d <- docs "enum member docs" + spaces + return d + return $ EnumMember memberName docs' + +handleNameDuplication :: Declaration a + => String -> [a] + -> (DeclarationSet a -> Parser b) + -> Parser b +handleNameDuplication label declarations cont = + case fromList declarations of + Left (BehindNameDuplication (Name _ bname)) -> + fail ("the behind " ++ label ++ " name `" ++ toString bname ++ + "` is duplicated") + Left (FacialNameDuplication (Name fname _)) -> + fail ("the facial " ++ label ++ " name `" ++ toString fname ++ + "` is duplicated") + Right set -> cont set + +enumTypeDeclaration :: Parser TypeDeclaration +enumTypeDeclaration = do + annotationSet' <- annotationSet "enum type annotations" + string "enum" "enum keyword" + spaces + typename <- name "enum type name" + spaces + frontDocs <- optional $ do + d <- docs "enum type docs" + spaces + return d + char '=' + spaces + docs' <- case frontDocs of + d@(Just _) -> return d + Nothing -> optional $ do + d <- docs "enum type docs" + spaces + return d + members <- (enumMember `sepBy1` (spaces >> char '|' >> spaces)) + "enum members" + case fromList members of + Left (BehindNameDuplication (Name _ bname)) -> + fail ("the behind member name `" ++ toString bname ++ + "` is duplicated") + Left (FacialNameDuplication (Name fname _)) -> + fail ("the facial member name `" ++ toString fname ++ + "` is duplicated") + Right memberSet -> do + spaces + char ';' + return $ TypeDeclaration typename (EnumType memberSet) + docs' annotationSet' + +fieldsOrParameters :: forall a. (String, String) + -> (Name -> TypeExpression -> Maybe Docs -> a) + -> Parser [a] +fieldsOrParameters (label, pluralLabel) make = do + type' <- typeExpression (label ++ " type") + spaces1 + name' <- name (label ++ " name") + spaces + let makeWithDocs = make name' type' + followedByComma makeWithDocs <|> do + d <- optional docs' (label ++ " docs") + return [makeWithDocs d] + where + recur :: Parser [a] + recur = fieldsOrParameters (label, pluralLabel) make + followedByComma :: (Maybe Docs -> a) -> Parser [a] + followedByComma makeWithDocs = do + char ',' + spaces + d <- optional docs' (label ++ " docs") + rest <- option [] recur ("rest of " ++ pluralLabel) + return $ makeWithDocs d : rest + docs' :: Parser Docs + docs' = do + d <- docs (label ++ " docs") + spaces + return d + +fields :: Parser [Field] +fields = fieldsOrParameters ("label", "labels") Field + +fieldSet :: Parser (DeclarationSet Field) +fieldSet = do + fields' <- fields "fields" + handleNameDuplication "field" fields' return + +recordTypeDeclaration :: Parser TypeDeclaration +recordTypeDeclaration = do + annotationSet' <- annotationSet "record type annotations" + string "record" "record keyword" + spaces + typename <- name "record type name" + spaces + char '(' + spaces + docs' <- optional $ do + d <- docs "record type docs" + spaces + return d + fields' <- fieldSet "record fields" + spaces + char ')' + spaces + char ';' + return $ TypeDeclaration typename (RecordType fields') docs' annotationSet' + +tag :: Parser Tag +tag = do + tagName <- name "union tag name" + spaces + paren <- optional $ char '(' + fields' <- case paren of + Just _ -> do { f <- fieldSet "union tag fields" + ; char ')' + ; return f + } + Nothing -> return empty + docs' <- optional $ do + d <- docs "union tag docs" + spaces + return d + return $ Tag tagName fields' docs' + +unionTypeDeclaration :: Parser TypeDeclaration +unionTypeDeclaration = do + annotationSet' <- annotationSet "union type annotations" + string "union" "union keyword" + spaces + typename <- name "union type name" + spaces + docs' <- optional $ do + d <- docs "union type docs" + spaces + return d + char '=' + spaces + tags' <- (tag `sepBy1` try (spaces >> char '|' >> spaces)) + "union tags" + spaces + char ';' + handleNameDuplication "tag" tags' $ \tagSet -> + return $ TypeDeclaration typename (UnionType tagSet) docs' annotationSet' + +typeDeclaration :: Parser TypeDeclaration +typeDeclaration = + ( try aliasTypeDeclaration <|> + try boxedTypeDeclaration <|> + try enumTypeDeclaration <|> + try recordTypeDeclaration <|> + unionTypeDeclaration + ) "type declaration (e.g. boxed, enum, record, union)" + +parameters :: Parser [Parameter] +parameters = fieldsOrParameters ("parameter", "parameters") Parameter + +parameterSet :: Parser (DeclarationSet Parameter) +parameterSet = option empty $ try $ do + params <- parameters "method parameters" + handleNameDuplication "parameter" params return + +method :: Parser Method +method = do + annotationSet' <- annotationSet "service method annotation" + returnType <- typeExpression "method return type" + spaces1 + methodName <- name "method name" + spaces + char '(' + spaces + docs' <- optional $ do + d <- docs "method docs" + spaces + return d + params <- parameterSet + spaces + char ')' + spaces + errorType <- optional $ do + string "throws" "throws keyword" + spaces + e <- typeExpression "method error type" + spaces + return e + return $ Method methodName params returnType errorType docs' annotationSet' + +methods :: Parser [Method] +methods = method `sepEndBy` try (spaces >> char ',' >> spaces) + +methodSet :: Parser (DeclarationSet Method) +methodSet = do + methods' <- methods "service methods" + handleNameDuplication "method" methods' return + +serviceDeclaration :: Parser TypeDeclaration +serviceDeclaration = do + annotationSet' <- annotationSet "service annotation" + string "service" "service keyword" + spaces + serviceName <- name "service name" + spaces + char '(' + spaces + docs' <- optional $ do + d <- docs "service docs" + spaces + return d + methods' <- methodSet "service methods" + spaces + char ')' + spaces + char ';' + return $ ServiceDeclaration serviceName (Service methods') + docs' annotationSet' + +modulePath :: Parser ModulePath +modulePath = do + idents <- sepBy1 (identifier "module identifier") + (try (spaces >> char '.' >> spaces)) + "module path" + case makePath idents of + Nothing -> fail "module path cannot be empty" + Just path -> return path + where + makePath :: [Identifier] -> Maybe ModulePath + makePath = foldl f Nothing + f :: Maybe ModulePath -> Identifier -> Maybe ModulePath + f Nothing i = Just $ ModuleName i + f (Just p) i = Just $ ModulePath p i + +imports :: Parser [TypeDeclaration] +imports = do + string' "import" "import keyword" + spaces + path <- modulePath "module path" + spaces + char '(' + spaces + idents <- sepBy1 (identifier "name to import") + (spaces >> char ',' >> spaces) + "names to import" + spaces + char ')' + spaces + char ';' + return [Import path ident | ident <- idents] + + +module' :: Parser Module +module' = do + spaces + docs' <- optional $ do + d <- docs "module docs" + spaces + return d + spaces + importLists <- many $ do + importList <- imports + spaces + return importList + types <- many $ do + typeDecl <- try typeDeclaration <|> + (serviceDeclaration "service declaration") + spaces + return typeDecl + handleNameDuplication "type" (types ++ [i | l <- importLists, i <- l]) $ + \typeSet -> return $ Module typeSet docs' + +file :: Parser Module +file = do + mod' <- module' + eof + return mod' + +parse :: FilePath -- | Source path (although it's only used for error message) + -> T.Text -- | Input source code + -> Either ParseError Module +parse = runParser file + +parseFile :: FilePath -- | Source path + -> IO (Either ParseError Module) +parseFile path = do + code <- readFile path + return $ runParser file path code + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/src/Nirum/Targets/Python.hs b/src/Nirum/Targets/Python.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Targets/Python.hs @@ -0,0 +1,751 @@ +{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, OverloadedStrings, + QuasiQuotes #-} +module Nirum.Targets.Python ( Code + , CodeGen( code + , localImports + , standardImports + , thirdPartyImports + ) + , CompileError + , InstallRequires ( InstallRequires + , dependencies + , optionalDependencies + ) + , Source( Source + , sourceModule + , sourcePackage + ) + , addDependency + , addOptionalDependency + , compileError + , compileModule + , compilePackage + , compilePrimitiveType + , compileTypeDeclaration + , compileTypeExpression + , hasError + , toAttributeName + , toClassName + , toImportPath + , toNamePair + , unionInstallRequires + , withLocalImport + , withStandardImport + , withThirdPartyImports + ) where + +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import GHC.Exts (IsList(toList)) + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import System.FilePath (joinPath) +import Text.InterpolatedString.Perl6 (qq) + +import qualified Nirum.Constructs.DeclarationSet as DS +import Nirum.Constructs.Identifier ( Identifier + , toPascalCaseText + , toSnakeCaseText + , toString + ) +import Nirum.Constructs.ModulePath (ModulePath, ancestors) +import Nirum.Constructs.Name (Name(Name)) +import qualified Nirum.Constructs.Name as N +import Nirum.Constructs.Service ( Method(Method, methodName) + , Parameter(Parameter) + , Service(Service) + ) +import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember) + , Field(Field) + , PrimitiveTypeIdentifier(..) + , Tag(Tag) + , Type( Alias + , BoxedType + , EnumType + , PrimitiveType + , RecordType + , UnionType + ) + , TypeDeclaration( Import + , ServiceDeclaration + , TypeDeclaration + ) + ) +import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier + , MapModifier + , OptionModifier + , SetModifier + , TypeIdentifier + ) + ) +import Nirum.Package ( BoundModule + , Package(modules) + , TypeLookup(Imported, Local, Missing) + , lookupType + , resolveBoundModule + , types + ) + +data Source = Source { sourcePackage :: Package + , sourceModule :: BoundModule + } deriving (Eq, Ord, Show) + +type Code = T.Text +type CompileError = T.Text + +data CodeGen a = CodeGen { standardImports :: S.Set T.Text + , thirdPartyImports :: M.Map T.Text (S.Set T.Text) + , localImports :: M.Map T.Text (S.Set T.Text) + , code :: a + } + | CodeGenError CompileError + deriving (Eq, Ord, Show) + +instance Functor CodeGen where + fmap f codeGen = pure f <*> codeGen + +instance Applicative CodeGen where + pure = return + c@CodeGen { code = f } <*> codeGen = codeGen >>= \x -> c { code = f x } + (CodeGenError m) <*> _ = CodeGenError m + +instance Monad CodeGen where + return code' = CodeGen { standardImports = [] + , thirdPartyImports = [] + , localImports = [] + , code = code' + } + (CodeGen si ti li c) >>= f = case f c of + (CodeGen si' ti' li' code') -> + let stdImports = S.union si si' + thirdPartyImports' = M.unionWith S.union ti ti' + localImports' = M.unionWith S.union li li' + in + CodeGen stdImports thirdPartyImports' localImports' code' + (CodeGenError m) -> CodeGenError m + (CodeGenError m) >>= _ = CodeGenError m + + fail = CodeGenError . T.pack + +hasError :: CodeGen a -> Bool +hasError (CodeGenError _) = True +hasError _ = False + +compileError :: CodeGen a -> Maybe CompileError +compileError CodeGen {} = Nothing +compileError (CodeGenError m) = Just m + +withStandardImport :: T.Text -> CodeGen a -> CodeGen a +withStandardImport module' c@CodeGen { standardImports = si } = + c { standardImports = S.insert module' si } +withStandardImport _ c@(CodeGenError _) = c + +withThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen a -> CodeGen a +withThirdPartyImports imports c@CodeGen { thirdPartyImports = ti } = + c { thirdPartyImports = L.foldl (M.unionWith S.union) ti importList } + where + importList :: [M.Map T.Text (S.Set T.Text)] + importList = map (uncurry M.singleton) imports +withThirdPartyImports _ c@(CodeGenError _) = c + +withLocalImport :: T.Text -> T.Text -> CodeGen a -> CodeGen a +withLocalImport module' object c@CodeGen { localImports = li } = + c { localImports = M.insertWith S.union module' [object] li } +withLocalImport _ _ c@(CodeGenError _) = c + +-- | The set of Python reserved keywords. +-- See also: https://docs.python.org/3/reference/lexical_analysis.html#keywords +keywords :: S.Set T.Text +keywords = [ "False", "None", "True" + , "and", "as", "assert", "break", "class", "continue" + , "def", "del" , "elif", "else", "except", "finally" + , "for", "from", "global", "if", "import", "in", "is" + , "lambda", "nonlocal", "not", "or", "pass", "raise" + , "return", "try", "while", "with", "yield" + ] + +toClassName :: Identifier -> T.Text +toClassName identifier = + if className `S.member` keywords then className `T.snoc` '_' else className + where + className :: T.Text + className = toPascalCaseText identifier + +toClassName' :: Name -> T.Text +toClassName' = toClassName . N.facialName + +toAttributeName :: Identifier -> T.Text +toAttributeName identifier = + if attrName `S.member` keywords then attrName `T.snoc` '_' else attrName + where + attrName :: T.Text + attrName = toSnakeCaseText identifier + +toAttributeName' :: Name -> T.Text +toAttributeName' = toAttributeName . N.facialName + +toImportPath :: ModulePath -> T.Text +toImportPath = T.intercalate "." . map toAttributeName . toList + +toNamePair :: Name -> T.Text +toNamePair (Name f b) = [qq|('{toAttributeName f}', '{toSnakeCaseText b}')|] + +toIndentedCodes :: (a -> T.Text) -> [a] -> T.Text -> T.Text +toIndentedCodes f traversable concatenator = + T.intercalate concatenator $ map f traversable + + +compileUnionTag :: Source + -> Name + -> Name + -> DS.DeclarationSet Field + -> CodeGen Code +compileUnionTag source parentname typename fields = do + typeExprCodes <- mapM (compileTypeExpression source) + [typeExpr | (Field _ typeExpr _) <- toList fields] + let className = toClassName' typename + tagNames = map toAttributeName' [ name + | (Field name _ _) <- toList fields + ] + nameNTypes = zip tagNames typeExprCodes + slotTypes = toIndentedCodes + (\(n, t) -> [qq|'{n}': {t}|]) nameNTypes ",\n " + slots = toIndentedCodes (\n -> [qq|'{n}'|]) tagNames ",\n " + initialArgs = toIndentedCodes + (\(n, t) -> [qq|{n}: {t}|]) nameNTypes ", " + initialValues = + toIndentedCodes (\n -> [qq|self.{n} = {n}|]) tagNames "\n " + nameMaps = toIndentedCodes + toNamePair + [name | Field name _ _ <- toList fields] + ",\n " + parentClass = toClassName' parentname + withStandardImport "typing" $ + withThirdPartyImports [ ("nirum.validate", ["validate_union_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] $ + return [qq| +class $className($parentClass): + # TODO: docstring + + __slots__ = ( + $slots, + ) + __nirum_tag__ = $parentClass.Tag.{toAttributeName' typename} + __nirum_tag_types__ = \{ + $slotTypes + \} + __nirum_tag_names__ = name_dict_type([ + $nameMaps + ]) + + def __init__(self, $initialArgs) -> None: + $initialValues + validate_union_type(self) + + def __repr__(self) -> str: + return '\{0.__module__\}.\{0.__qualname__\}(\{1\})'.format( + type(self), + ', '.join('\{\}=\{\}'.format(attr, getattr(self, attr)) + for attr in self.__slots__) + ) + + def __eq__(self, other) -> bool: + return isinstance(other, $className) and all( + getattr(self, attr) == getattr(other, attr) + for attr in self.__slots__ + ) + |] + +compilePrimitiveType :: PrimitiveTypeIdentifier -> CodeGen Code +compilePrimitiveType primitiveTypeIdentifier = + case primitiveTypeIdentifier of + Bool -> return "bool" + Bigint -> return "int" + Decimal -> withStandardImport "decimal" $ return "decimal.Decimal" + Int32 -> return "int" + Int64 -> return "int" + Float32 -> return "float" + Float64 -> return "float" + Text -> return "str" + Binary -> return "bytes" + Date -> withStandardImport "datetime" $ return "datetime.date" + Datetime -> withStandardImport "datetime" $ return "datetime.datetime" + Uuid -> withStandardImport "uuid" $ return"uuid.UUID" + Uri -> return "str" + +compileTypeExpression :: Source -> TypeExpression -> CodeGen Code +compileTypeExpression Source { sourceModule = boundModule } (TypeIdentifier i) = + case lookupType i boundModule of + Missing -> fail $ "undefined identifier: " ++ toString i + Imported _ (PrimitiveType p _) -> compilePrimitiveType p + Imported m _ -> + withThirdPartyImports [(toImportPath m, [toClassName i])] $ + return $ toClassName i + Local _ -> return $ toClassName i +compileTypeExpression source (MapModifier k v) = do + kExpr <- compileTypeExpression source k + vExpr <- compileTypeExpression source v + withStandardImport "typing" $ return [qq|typing.Mapping[$kExpr, $vExpr]|] +compileTypeExpression source modifier = do + expr <- compileTypeExpression source typeExpr + withStandardImport "typing" $ return [qq|typing.$className[$expr]|] + where + typeExpr :: TypeExpression + className :: T.Text + (typeExpr, className) = case modifier of + OptionModifier t' -> (t', "Optional") + SetModifier t' -> (t', "AbstractSet") + ListModifier t' -> (t', "Sequence") + TypeIdentifier _ -> undefined -- never happen! + MapModifier _ _ -> undefined -- never happen! + +compileTypeDeclaration :: Source -> TypeDeclaration -> CodeGen Code +compileTypeDeclaration _ (TypeDeclaration _ (PrimitiveType _ _) _ _) = + return "" -- never used +compileTypeDeclaration src (TypeDeclaration typename (Alias ctype) _ _) = do + ctypeExpr <- compileTypeExpression src ctype + return [qq| +# TODO: docstring +{toClassName' typename} = $ctypeExpr + |] +compileTypeDeclaration src (TypeDeclaration typename (BoxedType itype) _ _) = do + let className = toClassName' typename + itypeExpr <- compileTypeExpression src itype + withStandardImport "typing" $ + withThirdPartyImports [ ("nirum.validate", ["validate_boxed_type"]) + , ("nirum.serialize", ["serialize_boxed_type"]) + , ( "nirum.deserialize" + , ["deserialize_boxed_type"] + ) + ] $ + return [qq| +class $className: + # TODO: docstring + + __nirum_boxed_type__ = $itypeExpr + + def __init__(self, value: $itypeExpr) -> None: + validate_boxed_type(value, $itypeExpr) + self.value = value # type: $itypeExpr + + def __eq__(self, other) -> bool: + return (isinstance(other, $className) and + self.value == other.value) + + def __hash__(self) -> int: + return hash(self.value) + + def __nirum_serialize__(self) -> typing.Any: + return serialize_boxed_type(self) + + @classmethod + def __nirum_deserialize__(cls: type, value: typing.Any) -> '{className}': + return deserialize_boxed_type(cls, value) + + def __repr__(self) -> str: + return '\{0.__module__\}.\{0.__qualname__\}(\{1!r\})'.format( + type(self), self.value + ) + |] +compileTypeDeclaration _ (TypeDeclaration typename (EnumType members) _ _) = do + let className = toClassName' typename + memberNames = T.intercalate + "\n " + [ [qq|{toAttributeName' memberName} = '{toSnakeCaseText bn}'|] + | EnumMember memberName@(Name _ bn) _ <- toList members + ] + withStandardImport "enum" $ return [qq| +class $className(enum.Enum): + # TODO: docstring + + $memberNames + + def __nirum_serialize__(self) -> str: + return self.value + + @classmethod + def __nirum_deserialize__(cls: type, value: str) -> '{className}': + return cls(value.replace('-', '_')) # FIXME: validate input + |] +compileTypeDeclaration src (TypeDeclaration typename (RecordType fields) _ _) = do + typeExprCodes <- mapM (compileTypeExpression src) + [typeExpr | (Field _ typeExpr _) <- toList fields] + let className = toClassName' typename + fieldNames = map toAttributeName' [ name + | (Field name _ _) <- toList fields + ] + nameNTypes = zip fieldNames typeExprCodes + slotTypes = toIndentedCodes + (\(n, t) -> [qq|'{n}': {t}|]) nameNTypes ",\n " + slots = toIndentedCodes (\n -> [qq|'{n}'|]) fieldNames ",\n " + initialArgs = toIndentedCodes + (\(n, t) -> [qq|{n}: {t}|]) nameNTypes ", " + initialValues = toIndentedCodes + (\n -> [qq|self.{n} = {n}|]) fieldNames "\n " + nameMaps = toIndentedCodes + toNamePair + [name | Field name _ _ <- toList fields] + ",\n " + withStandardImport "typing" $ + withThirdPartyImports [ ( "nirum.validate" + , ["validate_record_type"] + ) + , ("nirum.serialize", ["serialize_record_type"]) + , ( "nirum.deserialize" + , ["deserialize_record_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] $ + return [qq| +class $className: + # TODO: docstring + + __slots__ = ( + $slots, + ) + __nirum_record_behind_name__ = '{toSnakeCaseText $ N.behindName typename}' + __nirum_field_types__ = \{ + $slotTypes + \} + __nirum_field_names__ = name_dict_type([ + $nameMaps + ]) + + def __init__(self, $initialArgs) -> None: + $initialValues + validate_record_type(self) + + def __repr__(self) -> str: + return '\{0.__module__\}.\{0.__qualname__\}(\{1\})'.format( + type(self), + ', '.join('\{\}=\{\}'.format(attr, getattr(self, attr)) + for attr in self.__slots__) + ) + + def __eq__(self, other) -> bool: + return isinstance(other, $className) and all( + getattr(self, attr) == getattr(other, attr) + for attr in self.__slots__ + ) + + def __nirum_serialize__(self) -> typing.Mapping[str, typing.Any]: + return serialize_record_type(self) + + @classmethod + def __nirum_deserialize__(cls: type, value) -> '{className}': + return deserialize_record_type(cls, value) + |] +compileTypeDeclaration src (TypeDeclaration typename (UnionType tags) _ _) = do + fieldCodes <- mapM (uncurry (compileUnionTag src typename)) tagNameNFields + let className = toClassName' typename + fieldCodes' = T.intercalate "\n\n" fieldCodes + enumMembers = toIndentedCodes + (\(t, b) -> [qq|$t = '{b}'|]) enumMembers' "\n " + withStandardImport "typing" $ + withStandardImport "enum" $ + withThirdPartyImports [ ( "nirum.serialize" + , ["serialize_union_type"]) + , ( "nirum.deserialize" + , ["deserialize_union_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] $ + return [qq| +class $className: + + __nirum_union_behind_name__ = '{toSnakeCaseText $ N.behindName typename}' + __nirum_field_names__ = name_dict_type([ + $nameMaps + ]) + + class Tag(enum.Enum): + $enumMembers + + def __init__(self, *args, **kwargs): + raise NotImplementedError( + "\{0.__module__\}.\{0.__qualname__\} cannot be instantiated " + "since it is an abstract class. Instantiate a concrete subtype " + "of it instead.".format( + type(self) + ) + ) + + def __nirum_serialize__(self) -> typing.Mapping[str, typing.Any]: + return serialize_union_type(self) + + @classmethod + def __nirum_deserialize__(cls: type, value) -> '{className}': + return deserialize_union_type(cls, value) + + +$fieldCodes' + |] + where + tagNameNFields :: [(Name, DS.DeclarationSet Field)] + tagNameNFields = [ (tagName, fields) + | (Tag tagName fields _) <- toList tags + ] + enumMembers' :: [(T.Text, T.Text)] + enumMembers' = [ ( toAttributeName' tagName + , toSnakeCaseText $ N.behindName tagName + ) + | (Tag tagName _ _) <- toList tags + ] + nameMaps :: T.Text + nameMaps = toIndentedCodes + toNamePair + [name | (name, _) <- tagNameNFields] + ",\n " +compileTypeDeclaration src (ServiceDeclaration name (Service methods) _ _) = do + let methods' = toList methods + methodMetadata <- mapM compileMethodMetadata methods' + let methodMetadata' = commaNl methodMetadata + dummyMethods <- mapM compileMethod methods' + let dummyMethods' = T.intercalate "\n\n" dummyMethods + withThirdPartyImports [ ("nirum.constructs", ["name_dict_type"]) + , ("nirum.rpc", ["service_type"]) + ] $ + return [qq| +class $className(service_type): + + __nirum_service_methods__ = \{ + {methodMetadata'} + \} + __nirum_method_names__ = name_dict_type([ + $methodNameMap + ]) + + {dummyMethods'} +|] + where + className :: T.Text + className = toClassName' name + commaNl :: [T.Text] -> T.Text + commaNl = T.intercalate ",\n" + compileMethod :: Method -> CodeGen Code + compileMethod (Method mName params rtype _etype _docs _anno) = do + let mName' = toAttributeName' mName + params' <- mapM compileParameter $ toList params + rtypeExpr <- compileTypeExpression src rtype + return [qq| + def {mName'}(self, {commaNl params'}) -> $rtypeExpr: + raise NotImplementedError('$className has to implement {mName'}()') +|] + compileParameter :: Parameter -> CodeGen Code + compileParameter (Parameter pName pType _) = do + pTypeExpr <- compileTypeExpression src pType + return [qq|{toAttributeName' pName}: $pTypeExpr|] + compileMethodMetadata :: Method -> CodeGen Code + compileMethodMetadata (Method mName params rtype _etype _docs _anno) = do + let params' = toList params :: [Parameter] + rtypeExpr <- compileTypeExpression src rtype + paramMetadata <- mapM compileParameterMetadata params' + let paramMetadata' = commaNl paramMetadata + withThirdPartyImports [("nirum.constructs", ["name_dict_type"])] $ + return [qq|'{toAttributeName' mName}': \{ + '_return': $rtypeExpr, + '_names': name_dict_type([{paramNameMap params'}]), + {paramMetadata'} + \}|] + compileParameterMetadata :: Parameter -> CodeGen Code + compileParameterMetadata (Parameter pName pType _) = do + let pName' = toAttributeName' pName + pTypeExpr <- compileTypeExpression src pType + return [qq|'{pName'}': $pTypeExpr|] + methodNameMap :: T.Text + methodNameMap = toIndentedCodes + toNamePair + [mName | Method { methodName = mName } <- toList methods] + ",\n " + paramNameMap :: [Parameter] -> T.Text + paramNameMap params = toIndentedCodes + toNamePair [pName | Parameter pName _ _ <- params] ",\n " +compileTypeDeclaration _ (Import _ _) = + return "" -- Nothing to compile + +compileModuleBody :: Source -> CodeGen Code +compileModuleBody src@Source { sourceModule = boundModule } = do + let types' = types boundModule + typeCodes <- mapM (compileTypeDeclaration src) $ toList types' + let moduleCode = T.intercalate "\n\n" typeCodes + return [qq| +# TODO: docs +$moduleCode + |] + +data InstallRequires = + InstallRequires { dependencies :: S.Set T.Text + , optionalDependencies :: M.Map (Int, Int) (S.Set T.Text) + } deriving (Eq, Ord, Show) + +addDependency :: InstallRequires -> T.Text -> InstallRequires +addDependency requires package = + requires { dependencies = S.insert package $ dependencies requires } + +addOptionalDependency :: InstallRequires + -> (Int, Int) -- | Python version already stasified + -> T.Text -- | PyPI package name + -> InstallRequires +addOptionalDependency requires pyVer package = + requires { optionalDependencies = newOptDeps } + where + oldOptDeps :: M.Map (Int, Int) (S.Set T.Text) + oldOptDeps = optionalDependencies requires + newOptDeps :: M.Map (Int, Int) (S.Set T.Text) + newOptDeps = M.alter (Just . S.insert package . fromMaybe S.empty) + pyVer oldOptDeps + +unionInstallRequires :: InstallRequires -> InstallRequires -> InstallRequires +unionInstallRequires a b = + a { dependencies = S.union (dependencies a) (dependencies b) + , optionalDependencies = M.unionWith S.union (optionalDependencies a) + (optionalDependencies b) + } + +compileModule :: Source -> Either CompileError (InstallRequires, Code) +compileModule source = + case code' of + CodeGenError errMsg -> Left errMsg + CodeGen {} -> codeWithDeps $ [qq| +{imports $ standardImports code'} + +{fromImports $ localImports code'} + +{fromImports $ thirdPartyImports code'} + +{code code'} + |] + where + code' :: CodeGen T.Text + code' = compileModuleBody source + imports :: S.Set T.Text -> T.Text + imports importSet = + if S.null importSet + then "" + else "import " `T.append` T.intercalate "," (S.elems importSet) + fromImports :: M.Map T.Text (S.Set T.Text) -> T.Text + fromImports importMap = + T.intercalate "\n" + [ [qq|from $from import {T.intercalate ", " $ S.elems vars}|] + | (from, vars) <- M.assocs importMap + ] + has :: S.Set T.Text -> T.Text -> Bool + has set module' = module' `S.member` set || + any (T.isPrefixOf $ module' `T.snoc` '.') set + require :: T.Text -> T.Text -> S.Set T.Text -> S.Set T.Text + require pkg module' set = + if set `has` module' then S.singleton pkg else S.empty + deps :: S.Set T.Text + deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports code' + optDeps :: M.Map (Int, Int) (S.Set T.Text) + optDeps = [ ((3, 4), require "enum34" "enum" $ standardImports code') + , ((3, 5), require "typing" "typing" $ standardImports code') + ] + codeWithDeps :: Code -> Either CompileError (InstallRequires, Code) + codeWithDeps c = Right (InstallRequires deps optDeps, c) + +compilePackageMetadata :: Package -> InstallRequires -> Code +compilePackageMetadata package (InstallRequires deps optDeps) = [qq| +import sys + +from setuptools import setup, __version__ as setuptools_version + +install_requires = [$pInstallRequires] +polyfill_requires = \{$pPolyfillRequires} + +if polyfill_requires: + # '<' operator for environment markers are supported since setuptools 17.1. + # Read PEP 496 for details of environment markers. + setup_requires = ['setuptools >= 17.1'] + if tuple(map(int, setuptools_version.split('.'))) < (17, 1): + extras_require = \{} + if 'bdist_wheel' not in sys.argv: + for (major, minor), deps in polyfill_requires.items(): + if sys.version_info < (major, minor): + install_requires.extend(deps) + envmarker = ":python_version=='\{0}.\{1}'" + python_versions = [(2, 6), (2, 7), + (3, 3), (3, 4), (3, 5), (3, 6)] # FIXME + for pyver in python_versions: + extras_require[envmarker.format(*pyver)] = list(\{ + d + for v, vdeps in polyfill_requires.items() + if pyver < v + for d in vdeps + }) + else: + extras_require = \{ + ":python_version<'\{0}.\{1}'".format(*pyver): deps + for pyver, deps in polyfill_requires.items() + } +else: + setup_requires = [] + extras_require = \{} + +# TODO: description, long_description, url, author, author_email, license, +# keywords, classifiers +setup( + name='{pName}', + version='{pVersion}', + packages=[$pPackages], + provides=[$pPackages], + requires=[$pInstallRequires], + setup_requires=setup_requires, + install_requires=install_requires, + extras_require=extras_require, +) +|] + where + pName :: Code + pName = "TestPackage" -- FIXME + pVersion :: Code + pVersion = "0.1.0" -- FIXME + strings :: [Code] -> Code + strings values = T.intercalate ", " . L.sort $ [[qq|'{v}'|] | v <- values] + pPackages :: Code + pPackages = strings $ map toImportPath $ M.keys $ modules package + pInstallRequires :: Code + pInstallRequires = strings $ S.toList deps + pPolyfillRequires :: Code + pPolyfillRequires = T.intercalate ", " + [ [qq|($major, $minor): [{strings $ S.toList deps'}]|] + | ((major, minor), deps') <- M.toList optDeps + ] + +compilePackage :: Package + -> M.Map FilePath (Either CompileError Code) +compilePackage package = + M.fromList $ + initFiles ++ + [ ( f + , case cd of + Left e -> Left e + Right (_, cd') -> Right cd' + ) + | (f, cd) <- modules' + ] ++ + [("setup.py", Right $ compilePackageMetadata package installRequires)] + where + toFilename :: ModulePath -> FilePath + toFilename mp = + joinPath $ [ T.unpack (toAttributeName i) + | i <- toList mp + ] ++ ["__init__.py"] + initFiles :: [(FilePath, Either CompileError Code)] + initFiles = [ (toFilename mp', Right "") + | mp <- M.keys (modules package) + , mp' <- S.elems (ancestors mp) + ] + modules' :: [(FilePath, Either CompileError (InstallRequires, Code))] + modules' = + [ ( toFilename modulePath' + , compileModule $ Source package boundModule + ) + | (modulePath', _) <- M.assocs (modules package) + , Just boundModule <- [resolveBoundModule modulePath' package] + ] + installRequires :: InstallRequires + installRequires = foldl unionInstallRequires + (InstallRequires [] []) + [deps | (_, Right (deps, _)) <- modules'] diff --git a/src/Nirum/Version.hs b/src/Nirum/Version.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Version.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +-- | Inquiry to Nirum version. +module Nirum.Version (version, versionString, versionText) where + +import Data.Maybe (mapMaybe) +import Data.Version (versionBranch, versionTags) + +import qualified Data.SemVer as SV +import Data.Text (Text, pack) + +import qualified Paths_nirum as P +-- Special module provided by Cabal +-- See also: http://stackoverflow.com/a/2892624/383405 + +-- | The semantic version of the running Nirum. +version :: SV.Version +version = case branch of + [major, minor, patch] -> + if length relTags == length tags + then SV.version major minor patch relTags [] + else error ("invalid release identifiers: " ++ show relTags) + [_, _] -> error ("patch version is missing: " ++ show branch) + [_] -> error ("minor version is missing: " ++ show branch) + [] -> error "major version is missing" + _ -> error ("too precise version for semver: " ++ show branch) + where + branch :: [Int] + branch = versionBranch P.version + tags :: [String] + tags = versionTags P.version + relTags :: [SV.Identifier] + relTags = mapMaybe (SV.textual . pack) tags + +-- | The string representation of 'version'. +versionString :: String +versionString = SV.toString version + +-- | The text representation of 'version'. +versionText :: Text +versionText = SV.toText version diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -0,0 +1,12 @@ +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +arguments :: [String] +arguments = ["src", "test"] + +main :: IO () +main = do + hlints <- hlint arguments + case hlints of + [] -> exitSuccess + _ -> exitFailure diff --git a/test/Nirum/CliSpec.hs b/test/Nirum/CliSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/CliSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.CliSpec where + +import Control.Monad (forM_) + +import qualified Data.Map.Strict as M +import Data.List (sort) +import Data.Text (Text) +import qualified Data.Text.IO as TI +import System.Directory (listDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec.Meta + +import Nirum.Cli (writeFiles) + +expectWriteFiles :: FilePath -> [(FilePath, Text)] -> IO [FilePath] +expectWriteFiles tmpDir files = do + writeFiles tmpDir $ M.fromList [(f, Right c) | (f, c) <- files] + forM_ files $ \(f, expectedContent) -> do + content <- TI.readFile (tmpDir f) + content `shouldBe` expectedContent + fileList <- listDirectory tmpDir + return $ sort fileList + +spec :: Spec +spec = + describe "writeFiles" $ do + it "writes root files" $ + withSystemTempDirectory "writeFiles-rootFiles" $ \tmpDir -> do + let files = [ ("a.txt", "content A") + , ("b.txt", "content B") + ] + fileList <- expectWriteFiles tmpDir files + fileList `shouldBe` sort [f | (f, _) <- files] + it "makes directories if necessary" $ + withSystemTempDirectory "writeFiles-directories" $ \tmpDir -> do + let files = [ ("a.txt", "content A") + , ("b.txt", "content B") + , ("d/a.txt", "content d/a") + , ("d/b/c.txt", "content d/b/c") + , ("d2/a.txt", "content d2/a") + ] + fileList <- expectWriteFiles tmpDir files + fileList `shouldBe` ["a.txt", "b.txt", "d", "d2"] + dFileList <- listDirectory $ tmpDir "d" + sort dFileList `shouldBe` ["a.txt", "b"] + dBFileList <- listDirectory $ tmpDir "d" "b" + dBFileList `shouldBe` ["c.txt"] + d2FileList <- listDirectory $ tmpDir "d2" + d2FileList `shouldBe` ["a.txt"] diff --git a/test/Nirum/Constructs/AnnotationSpec.hs b/test/Nirum/Constructs/AnnotationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/AnnotationSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.AnnotationSpec where + +import Test.Hspec.Meta +import qualified Data.Map.Strict as M + +import Nirum.Constructs.Annotation + ( Annotation (Annotation) + , AnnotationSet (AnnotationSet) + , NameDuplication (AnnotationNameDuplication) + , empty + , fromList + , toCode + , toList + ) + +spec :: Spec +spec = do + let annotation = Annotation "foo" Nothing + loremAnno = Annotation "lorem" (Just "ipsum") + withEscapeChar = Annotation "quote" (Just "\"") + describe "Annotation" $ + describe "toCode Annotation" $ + it "prints annotation properly" $ do + toCode annotation `shouldBe` "@foo" + toCode loremAnno `shouldBe` "@lorem(\"ipsum\")" + toCode withEscapeChar `shouldBe` "@quote(\"\\\"\")" + describe "AnnotationSet" $ do + it "empty" $ empty `shouldBe` AnnotationSet M.empty + describe "fromList" $ do + it "success" $ do + fromList [] `shouldBe` Right (AnnotationSet M.empty) + fromList [annotation] `shouldBe` Right + (AnnotationSet $ M.fromList [("foo", annotation)]) + it "name duplication" $ do + let duplicationAnnotations = fromList [ annotation + , loremAnno + , annotation + ] + duplicationAnnotations `shouldBe` + Left (AnnotationNameDuplication "foo") + let annotationSet = case fromList [annotation, loremAnno] of + Right set -> set + Left _ -> empty + it "toList" $ + fromList (toList annotationSet) `shouldBe` Right annotationSet diff --git a/test/Nirum/Constructs/DeclarationSetSpec.hs b/test/Nirum/Constructs/DeclarationSetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/DeclarationSetSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.Constructs.DeclarationSetSpec (SampleDecl(..), spec) where + +import Control.Exception.Base (evaluate) +import Data.String (IsString(..)) + +import Test.Hspec.Meta + +import Nirum.Constructs (Construct(..)) +import Nirum.Constructs.Declaration (Declaration(..), Docs) +import Nirum.Constructs.DeclarationSet ( DeclarationSet + , NameDuplication(..) + , empty + , fromList + , lookup' + , null' + , size + , toList + , union + , (!) + ) +import Nirum.Constructs.Name (Name(Name)) + +data SampleDecl = SampleDecl Name (Maybe Docs) deriving (Eq, Ord, Show) + +instance Construct SampleDecl where + toCode _ = "(do not impl)" + +instance Declaration SampleDecl where + name (SampleDecl name' _) = name' + docs (SampleDecl _ docs') = docs' + +instance IsString SampleDecl where + fromString s = SampleDecl (fromString s) Nothing + +type SampleDeclSet = DeclarationSet SampleDecl + +spec :: Spec +spec = + describe "DeclarationSet" $ do + let sd fname bname = SampleDecl (Name fname bname) Nothing + context "fromList" $ do + let fl = fromList :: [SampleDecl] + -> Either NameDuplication SampleDeclSet + it ("returns Left FacialNameDuplication " + ++ "if duplicated facial name exists") $ do + fl ["foo", "bar", "foo"] `shouldBe` + Left (FacialNameDuplication "foo") + fl ["foo", "bar", "bar"] `shouldBe` + Left (FacialNameDuplication "bar") + fl ["foo", "bar", sd "foo" "baz"] `shouldBe` + Left (FacialNameDuplication $ Name "foo" "baz") + it ("returns Left BehindNameDuplication " + ++ "if duplicated behind name exists") $ do + fl ["foo", "bar", sd "baz" "foo"] `shouldBe` + Left (BehindNameDuplication $ Name "baz" "foo") + fl [sd "foo" "bar", "bar", "baz"] `shouldBe` + Left (BehindNameDuplication "bar") + it "returns Right DeclarationSet if there are no duplications" $ do + let Right dset = fl ["foo", "bar", "baz"] + toList dset `shouldBe` ["foo", "bar", "baz"] + let dset = ["foo", "bar", sd "baz" "asdf"] :: SampleDeclSet + context "toList" $ + it "returns [Declaration]" $ do + toList dset `shouldBe` ["foo", "bar", sd "baz" "asdf"] + toList (empty :: SampleDeclSet) `shouldBe` [] + context "size" $ + it "returns its cardinality" $ do + size dset `shouldBe` 3 + size (empty :: SampleDeclSet) `shouldBe` 0 + context "null" $ do + it "returns True if the set is empty" $ do + ([] :: SampleDeclSet) `shouldSatisfy` null' + (empty :: SampleDeclSet) `shouldSatisfy` null' + it "returns False if the set is not empty" $ + dset `shouldNotSatisfy` null' + context "lookup" $ do + it "returns Nothing if there is no such facial name" $ + lookup' "not-exists" dset `shouldBe` Nothing + it "returns Just Declaration if the name exists" $ do + lookup' "foo" dset `shouldBe` Just "foo" + lookup' "bar" dset `shouldBe` Just "bar" + lookup' "baz" dset `shouldBe` Just (sd "baz" "asdf") + context "DeclarationSet ! Identifier" $ do + it "returns Declaration if the name exists" $ do + dset ! "foo" `shouldBe` "foo" + dset ! "bar" `shouldBe` "bar" + dset ! "baz" `shouldBe` sd "baz" "asdf" + it "fails if there is no such facial name" $ + evaluate (dset ! "not-exists") `shouldThrow` anyException + context "union" $ do + it "returns Right DeclarationSet if there aren't no duplications" $ + union dset ["apple", "banana"] `shouldBe` + Right ["foo" , "bar" , sd "baz" "asdf", "apple", "banana"] + it "returns Left FacialNameDuplication if facial names are dup" $ + union dset [sd "foo" "xyz"] `shouldBe` + Left (FacialNameDuplication $ Name "foo" "xyz") + it "returns Left BehindNameDuplication if behind names are dup" $ + union dset [sd "xyz" "foo"] `shouldBe` + Left (BehindNameDuplication $ Name "xyz" "foo") diff --git a/test/Nirum/Constructs/DeclarationSpec.hs b/test/Nirum/Constructs/DeclarationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/DeclarationSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.DeclarationSpec where + +import Test.Hspec.Meta + +import Nirum.Constructs (Construct(..)) +import Nirum.Constructs.Declaration (Docs(Docs), toCodeWithPrefix) + +spec :: Spec +spec = + describe "Docs" $ do + context "toCode" $ do + it "has leading sharps every line" $ do + toCode (Docs "test") `shouldBe` "# test" + toCode (Docs "test\ntest2") `shouldBe` "# test\n# test2" + specify "... except of the last EOL" $ do + toCode (Docs "test\n") `shouldBe` "# test" + toCode (Docs "test\ntest2\n") `shouldBe` "# test\n# test2" + context "toCodeWithPrefix" $ do + it "simply returns an empty string if input is Nothing" $ do + toCodeWithPrefix "\n" Nothing `shouldBe` "" + toCodeWithPrefix "(prefix)" Nothing `shouldBe` "" + it "prepends the given prefix if input is Just Docs" $ do + toCodeWithPrefix "\n" (Just "docs") `shouldBe` "\n# docs" + toCodeWithPrefix "(prefix)" (Just "doc\ndoc") + `shouldBe` "(prefix)# doc\n# doc" + context "fromString" $ do + it "is equivalent to Docs data constructor" $ do + ("test\n" :: Docs) `shouldBe` Docs "test\n" + ("test\ntest2\n" :: Docs) `shouldBe` Docs "test\ntest2\n" + specify "... except it automatically appends EOL if omitted" $ do + ("test" :: Docs) `shouldBe` Docs "test\n" + ("test\ntest2" :: Docs) `shouldBe` Docs "test\ntest2\n" diff --git a/test/Nirum/Constructs/IdentifierSpec.hs b/test/Nirum/Constructs/IdentifierSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/IdentifierSpec.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.IdentifierSpec where + +import Control.Exception (evaluate) +import Control.Monad (forM_) +import Data.Maybe (fromJust) + +import Data.Text (Text) +import Test.Hspec.Meta + +import Nirum.Constructs.Identifier ( Identifier + , fromText + , normalize + , toCamelCaseText + , toCode + , toLispCaseText + , toNormalizedString + , toNormalizedText + , toPascalCaseText + , toSnakeCaseText + , toString + , toText + , tokens + ) + +fromText' :: Text -> Identifier +fromText' = fromJust . fromText + +getIdentifier :: Text -> Text +getIdentifier = toText . fromText' + +getCode :: Text -> Text +getCode = toCode . fromText' + +getNormalizedIdentifier :: Text -> Text +getNormalizedIdentifier = toText . normalize . fromText' + +spec :: Spec +spec = do + describe "fromText" $ do + it "returns Nothing if identifier text is invalid" $ do + fromText "" `shouldBe` Nothing + fromText "-" `shouldBe` Nothing + fromText "1dentifier-cannot-start-with-digits" `shouldBe` Nothing + fromText "-identifier-cannot-start-with-hyphen" `shouldBe` Nothing + fromText "_identifier_cannot_start_with_underscore" + `shouldBe` Nothing + fromText "identifier-cannot-end-with-hyphen-" `shouldBe` Nothing + fromText "identifier_cannot_end_with_underscore_" + `shouldBe` Nothing + fromText "identifier-cannot-have-two--or---more---continued-hyphens" + `shouldBe` Nothing + fromText "identifier_cannot_have_two__or_more_continued_underscores" + `shouldBe` Nothing + fromText "무효한-식별자" `shouldBe` Nothing + fromText "invalid-식별자" `shouldBe` Nothing + fromText "identifier cannot contain whitepsaces" `shouldBe` Nothing + it "returns Just Identifier if nothing goes wrong" $ do + toText "datetime" `shouldBe` "datetime" + toText "person-name" `shouldBe` "person-name" + describe "tokens" $ do + it "returns tokens behind" $ do + tokens (fromText' "name") `shouldBe` ["name"] + tokens (fromText' "a-name") `shouldBe` ["a", "name"] + it "returns normalized tokens" $ do + tokens (fromText' "Name") `shouldBe` ["name"] + tokens (fromText' "A-Name") `shouldBe` ["a", "name"] + describe "normalize" $ + it "returns normalized Identifier" $ do + getNormalizedIdentifier "name" `shouldBe` "name" + getNormalizedIdentifier "Name" `shouldBe` "name" + getNormalizedIdentifier "normalize_test" `shouldBe` "normalize-test" + describe "Identifier == Identifier" $ do + it "returns True if words are all the same" $ do + fromText "name" `shouldBe` fromText "name" + fromText "valid-name" `shouldBe` fromText "valid-name" + it "returns False if any word does not match" $ do + fromText "name" `shouldNotBe` fromText "nam" + fromText "a-name" `shouldNotBe` fromText "an-ame" + it "is case-insensitive" $ do + fromText "name" `shouldBe` fromText "Name" + fromText "Valid-Name" `shouldBe` fromText "valid-name" + fromText "valid_name" `shouldBe` fromText "valid-name" + describe "compare Identifier Identifier" $ do + it "returns Ordering in lexicographical order" $ do + compare ("aaaab" :: Identifier) "aaaac" `shouldBe` LT + compare ("aaaab" :: Identifier) "aaaaa" `shouldBe` GT + it "is case-insensitive" $ do + compare ("AAAAB" :: Identifier) "aaaac" `shouldBe` LT + compare ("aaaab" :: Identifier) "AAAAC" `shouldBe` LT + compare ("AAAAB" :: Identifier) "aaaaa" `shouldBe` GT + compare ("aaaab" :: Identifier) "AAAAA" `shouldBe` GT + describe "toCode Identifier" $ do + it "returns its code representation" $ do + getCode "name" `shouldBe` "name" + getCode "person-name" `shouldBe` "person-name" + it "quotes identifier if the identifier is a reserved keyword" $ + getCode "enum" `shouldBe` "`enum`" + describe "fromString" $ do + it "overrides strings if it's a valid identifier" $ do + "name" `shouldBe` fromText' "name" + "valid-name" `shouldBe` fromText' "valid-name" + it "errors if it's a invalid identifier" $ + evaluate ("-" :: Identifier) `shouldThrow` + errorCall "invalid identifier: -" + describe "toString" $ + it "behaves same as toText except its return type is [Char]" $ + toString (fromText' "asdf") `shouldBe` ("asdf" :: String) + describe "toNormalizedText Identifier" $ do + let normalizers = [ toNormalizedText + , toLispCaseText + ] :: [Identifier -> Text] + forM_ normalizers $ \normalizer -> do + it "returns lowercased identifier text" $ do + normalizer "IDENTIFIER" `shouldBe` "identifier" + normalizer "Identifier" `shouldBe` "identifier" + it "replaces underscores with hyphens" $ do + normalizer "valid_identifier" `shouldBe` "valid-identifier" + normalizer "Valid_Identifier" `shouldBe` "valid-identifier" + describe "toNormalizedString Identifier" $ do + it "returns lowercased identifier string" $ do + toNormalizedString "IDENTIFIER" `shouldBe` "identifier" + toNormalizedString "Identifier" `shouldBe` "identifier" + it "replaces underscores with hyphens" $ do + toNormalizedString "valid_identifier" `shouldBe` "valid-identifier" + toNormalizedString "Valid_Identifier" `shouldBe` "valid-identifier" + describe "toPascalCaseText Identifier" $ + it "returns PascalCase-ed identifier string" $ do + toPascalCaseText (fromText' "pascal-case") `shouldBe` "PascalCase" + toPascalCaseText (fromText' "PASCAL-CASE") `shouldBe` "PascalCase" + toPascalCaseText (fromText' "pascal_case") `shouldBe` "PascalCase" + toPascalCaseText (fromText' "PASCAL_CASE") `shouldBe` "PascalCase" + describe "toCamelCaseText Identifier" $ + it "returns camelCase-ed identifier string" $ do + toCamelCaseText (fromText' "camel-case") `shouldBe` "camelCase" + toCamelCaseText (fromText' "CAMEL-CASE") `shouldBe` "camelCase" + toCamelCaseText (fromText' "camel_case") `shouldBe` "camelCase" + toCamelCaseText (fromText' "CAMEL_CASE") `shouldBe` "camelCase" + describe "toSnakeCaseText Identifier" $ + it "returns snake_case-ed identifier string" $ do + toSnakeCaseText (fromText' "snake-case") `shouldBe` "snake_case" + toSnakeCaseText (fromText' "SNAKE-CASE") `shouldBe` "snake_case" + toSnakeCaseText (fromText' "snake_case") `shouldBe` "snake_case" + toSnakeCaseText (fromText' "SNAKE_CASE") `shouldBe` "snake_case" diff --git a/test/Nirum/Constructs/ModulePathSpec.hs b/test/Nirum/Constructs/ModulePathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/ModulePathSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.Constructs.ModulePathSpec where + +import Control.Exception (evaluate) +import GHC.Exts (IsList(fromList, toList)) + +import System.FilePath (()) +import Test.Hspec.Meta + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.ModulePath ( ModulePath(ModuleName, ModulePath) + , ancestors + , fromFilePath + , fromIdentifiers + ) + +spec :: Spec +spec = + describe "ModulePath" $ do + let foo = ModuleName "foo" + fooBar = ModulePath (ModuleName "foo") "bar" + fooBarBaz = ModulePath (ModulePath (ModuleName "foo") "bar") "baz" + fooBarBaz2 = ModulePath (ModuleName "foo") "bar-baz2" + specify "fromIdentifiers" $ do + fromIdentifiers [] `shouldBe` Nothing + fromIdentifiers ["foo"] `shouldBe` Just foo + fromIdentifiers ["Foo"] `shouldBe` Just foo + fromIdentifiers ["FOO"] `shouldBe` Just foo + fromIdentifiers ["foo", "bar"] `shouldBe` Just fooBar + fromIdentifiers ["foo", "bar", "baz"] `shouldBe` Just fooBarBaz + fromIdentifiers ["Foo", "BAR", "baZ"] `shouldBe` Just fooBarBaz + fromIdentifiers ["foo", "bar-baz2"] `shouldBe` Just fooBarBaz2 + fromIdentifiers ["FOO", "bar_baz2"] `shouldBe` Just fooBarBaz2 + specify "fromFilePath" $ do + fromFilePath "" `shouldBe` Nothing + fromFilePath "foo.nrm" `shouldBe` Just foo + fromFilePath "FOO.NRM" `shouldBe` Just foo + fromFilePath "Foo.Nrm" `shouldBe` Just foo + fromFilePath ("foo" "bar.nrm") `shouldBe` Just fooBar + fromFilePath ("FOO" "bar.NRM") `shouldBe` Just fooBar + fromFilePath ("foo" "bar" "baz.nrm") `shouldBe` + Just fooBarBaz + fromFilePath ("foo" "BAR" "baz.nrm") `shouldBe` + Just fooBarBaz + fromFilePath ("foo" "bar-baz2.nrm") `shouldBe` Just fooBarBaz2 + fromFilePath ("foo" "bar_baz2.NRM") `shouldBe` Just fooBarBaz2 + specify "ancestors" $ do + ancestors ["foo", "bar", "baz"] `shouldBe` + [ ["foo"] + , ["foo", "bar"] + , ["foo", "bar", "baz"] + ] + ancestors ["foo"] `shouldBe` [["foo"]] + context "Construct" $ + specify "toCode" $ do + toCode foo `shouldBe` "foo" + toCode fooBar `shouldBe` "foo.bar" + toCode fooBarBaz `shouldBe` "foo.bar.baz" + toCode fooBarBaz2 `shouldBe` "foo.bar-baz2" + context "IsList" $ do + specify "fromList" $ do + evaluate (fromList [] :: ModulePath) `shouldThrow` + errorCall "ModulePath cannot be empty" + fromList ["foo"] `shouldBe` foo + fromList ["foo", "bar"] `shouldBe` fooBar + fromList ["foo", "bar", "baz"] `shouldBe` fooBarBaz + fromList ["foo", "bar-baz2"] `shouldBe` fooBarBaz2 + specify "toList" $ do + toList foo `shouldBe` ["foo"] + toList fooBar `shouldBe` ["foo", "bar"] + toList fooBarBaz `shouldBe` ["foo", "bar", "baz"] + toList fooBarBaz2 `shouldBe` ["foo", "bar-baz2"] diff --git a/test/Nirum/Constructs/ModuleSpec.hs b/test/Nirum/Constructs/ModuleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/ModuleSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes #-} +module Nirum.Constructs.ModuleSpec where + +import Test.Hspec.Meta +import Text.InterpolatedString.Perl6 (q) + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Annotation (empty) +import Nirum.Constructs.DeclarationSet (DeclarationSet) +import Nirum.Constructs.Module (Module(..), imports) +import Nirum.Constructs.TypeDeclaration ( Type(..) + , TypeDeclaration( Import + , TypeDeclaration + ) + ) + +spec :: Spec +spec = + describe "Module" $ do + let pathT = TypeDeclaration "path" (Alias "text") + (Just "path string") empty + offsetT = + TypeDeclaration "offset" (BoxedType "float64") Nothing empty + decls = [ Import ["foo", "bar"] "baz" + , Import ["foo", "bar"] "qux" + , Import ["zzz"] "qqq" + , Import ["zzz"] "ppp" + , Import ["xyz"] "asdf" + , pathT + , offsetT + ] :: DeclarationSet TypeDeclaration + mod1 = Module decls Nothing + mod2 = Module decls $ Just "module level docs...\nblahblah" + specify "imports" $ do + imports mod1 `shouldBe` [ (["foo", "bar"], ["baz", "qux"]) + , (["xyz"], ["asdf"]) + , (["zzz"], ["qqq", "ppp"]) + ] + imports mod2 `shouldBe` imports mod1 + specify "toCode" $ do + toCode mod1 `shouldBe` [q|import foo.bar (baz, qux); +import xyz (asdf); +import zzz (ppp, qqq); + +type path = text; +# path string + +boxed offset (float64); +|] + toCode mod2 `shouldBe` [q|# module level docs... +# blahblah +import foo.bar (baz, qux); +import xyz (asdf); +import zzz (ppp, qqq); + +type path = text; +# path string + +boxed offset (float64); +|] diff --git a/test/Nirum/Constructs/NameSpec.hs b/test/Nirum/Constructs/NameSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/NameSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.NameSpec where + +import Test.Hspec.Meta + +import Nirum.Constructs.Name (Name(Name), isComplex, isSimple, toCode) + +spec :: Spec +spec = + describe "Name" $ do + describe "toCode Name" $ do + it "prints only its facialName if its behindName is the same" $ + toCode (Name "a" "a") `shouldBe` "a" + it "prints only facialName with behindName if they are not same" $ + toCode (Name "a" "b") `shouldBe` "a/b" + specify "fromString" $ + ("foo" :: Name) `shouldBe` Name "foo" "foo" + specify "isSimple" $ do + Name "foo" "foo" `shouldSatisfy` isSimple + Name "foo" "bar" `shouldNotSatisfy` isSimple + specify "isComplex" $ do + Name "foo" "bar" `shouldSatisfy` isComplex + Name "foo" "foo" `shouldNotSatisfy` isComplex diff --git a/test/Nirum/Constructs/TypeDeclarationSpec.hs b/test/Nirum/Constructs/TypeDeclarationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/TypeDeclarationSpec.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.Constructs.TypeDeclarationSpec where + +import Data.Either (rights) +import qualified Data.Text as T +import Test.Hspec.Meta + +import Nirum.Constructs (Construct(toCode)) +import Nirum.Constructs.Annotation ( Annotation (Annotation) + , AnnotationSet + , fromList + , empty + ) +import Nirum.Constructs.Declaration (Declaration(name, docs)) +import Nirum.Constructs.DeclarationSet (DeclarationSet) +import Nirum.Constructs.Service (Method(Method), Service(Service)) +import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember) + , Field(Field) + , JsonType(String) + , PrimitiveTypeIdentifier(Text) + , Tag(Tag) + , Type(..) + , TypeDeclaration(..) + ) + +barAnnotationSet :: AnnotationSet +barAnnotationSet = head $ rights [fromList [Annotation "bar" (Just "baz")]] + +spec :: Spec +spec = do + describe "TypeDeclaration" $ do + context "Alias" $ do + let alias = Alias "text" + a = TypeDeclaration { typename = "path" + , type' = alias + , typeDocs = Nothing + , typeAnnotations = empty + } + b = a { typeDocs = Just "docs"} + specify "name" $ do + name a `shouldBe` "path" + name b `shouldBe` "path" + specify "docs" $ do + docs a `shouldBe` Nothing + docs b `shouldBe` Just "docs" + specify "toCode" $ do + toCode a `shouldBe` "type path = text;" + toCode b `shouldBe` "type path = text;\n# docs" + context "BoxedType" $ do + let boxed = BoxedType "float64" + a = TypeDeclaration { typename = "offset" + , type' = boxed + , typeDocs = Nothing + , typeAnnotations = empty + } + b = a { typeDocs = Just "docs" } + specify "name" $ do + name a `shouldBe` "offset" + name b `shouldBe` "offset" + specify "docs" $ do + docs a `shouldBe` Nothing + docs b `shouldBe` Just "docs" + specify "toCode" $ do + toCode a `shouldBe` "boxed offset (float64);" + toCode b `shouldBe` "boxed offset (float64);\n# docs" + context "EnumType" $ do + let enumMembers = [ EnumMember "kr" Nothing + , EnumMember "jp" $ Just "Japan" + , EnumMember "us" $ Just "United States" + ] :: DeclarationSet EnumMember + enum = EnumType enumMembers + a = TypeDeclaration { typename = "country" + , type' = enum + , typeDocs = Nothing + , typeAnnotations = empty + } + b = a { typeDocs = Just "country codes" } + specify "toCode" $ do + toCode a `shouldBe` "enum country\n\ + \ = kr\n\ + \ | jp\n\ + \ # Japan\n\ + \ | us\n\ + \ # United States\n\ + \ ;" + toCode b `shouldBe` "enum country\n\ + \ # country codes\n\ + \ = kr\n\ + \ | jp\n\ + \ # Japan\n\ + \ | us\n\ + \ # United States\n\ + \ ;" + context "RecordType" $ do + let fields' = [ Field "name" "text" Nothing + , Field "dob" "date" $ Just "date of birth" + , Field "gender" "gender" Nothing + ] :: DeclarationSet Field + record = RecordType fields' + a = TypeDeclaration { typename = "person" + , type' = record + , typeDocs = Nothing + , typeAnnotations = empty + } + b = a { typeDocs = Just "person record type" } + specify "toCode" $ do + toCode a `shouldBe` "record person (\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" + toCode b `shouldBe` "record person (\n\ + \ # person record type\n\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" + context "UnionType" $ do + let circleFields = [ Field "origin" "point" Nothing + , Field "radius" "offset" Nothing + ] + rectangleFields = [ Field "upper-left" "point" Nothing + , Field "lower-right" "point" Nothing + ] + tags' = [ Tag "circle" circleFields Nothing + , Tag "rectangle" rectangleFields Nothing + , Tag "none" [] Nothing + ] + union = UnionType tags' + a = TypeDeclaration { typename = "shape" + , type' = union + , typeDocs = Nothing + , typeAnnotations = empty + } + b = a { typeDocs = Just "shape type" } + specify "toCode" $ do + toCode a `shouldBe` "union shape\n\ + \ = circle (point origin, \ + \offset radius,)\n\ + \ | rectangle (point upper-left, \ + \point lower-right,)\n\ + \ | none\n\ + \ ;" + toCode b `shouldBe` "union shape\n\ + \ # shape type\n\ + \ = circle (point origin, \ + \offset radius,)\n\ + \ | rectangle (point upper-left, \ + \point lower-right,)\n\ + \ | none\n\ + \ ;" + context "PrimitiveType" $ do + let primitiveType = PrimitiveType Text String + decl = TypeDeclaration "text" primitiveType Nothing empty + specify "toCode" $ + T.lines (toCode decl) `shouldSatisfy` + all (T.isPrefixOf "//" . T.stripStart) + context "ServiceDeclaration" $ do + let nullService = Service [] + nullDecl = ServiceDeclaration "null-service" nullService Nothing + empty + nullDecl' = + ServiceDeclaration "null-service" nullService + (Just "Null service declaration.") + empty + pingService = Service [ Method "ping" [] "bool" Nothing Nothing empty ] + pingDecl = ServiceDeclaration "ping-service" pingService Nothing + empty + pingDecl' = + ServiceDeclaration "ping-service" pingService + (Just "Ping service declaration.") + empty + annoDecl = ServiceDeclaration "anno-service" pingService + Nothing barAnnotationSet + specify "toCode" $ do + toCode nullDecl `shouldBe` "service null-service ();" + toCode nullDecl' `shouldBe` "service null-service (\n\ + \ # Null service declaration.\n\ + \);" + toCode pingDecl `shouldBe` + "service ping-service (bool ping ());" + toCode pingDecl' `shouldBe` + "service ping-service (\n\ + \ # Ping service declaration.\n\ + \ bool ping ()\n\ + \);" + toCode annoDecl `shouldBe` + "@bar(\"baz\")\n\ + \service anno-service (bool ping ());" + -- TODO: more tests + context "Import" $ do + let import' = Import ["foo", "bar"] "baz" + specify "name" $ + name import' `shouldBe` "baz" + specify "docs" $ + docs import' `shouldBe` Nothing + specify "toCode" $ + toCode import' `shouldBe` "import foo.bar (baz);\n" + describe "EnumMember" $ do + let kr = EnumMember "kr" Nothing + jp = EnumMember "jp" $ Just "Japan" + specify "toCode" $ do + toCode kr `shouldBe` "kr" + toCode jp `shouldBe` "jp\n# Japan" + specify "fromString" $ + "test" `shouldBe` EnumMember "test" Nothing + describe "Field" $ + specify "toCode" $ do + toCode (Field "name" "text" Nothing) `shouldBe` "text name," + toCode (Field "dob" "date" $ Just "date of birth") `shouldBe` + "date dob,\n# date of birth" + describe "Tag" $ + specify "toCode" $ do + let fields' = [ Field "origin" "point" Nothing + , Field "radius" "offset" Nothing + ] + toCode (Tag "circle" fields' Nothing) + `shouldBe` "circle (point origin, offset radius,)" + toCode (Tag "circle" fields' $ Just "docs") + `shouldBe` "circle (point origin, offset radius,)\n# docs" + toCode (Tag "unit" [] Nothing) `shouldBe` "unit" + toCode (Tag "unit" [] $ Just "docs") `shouldBe` "unit\n# docs" diff --git a/test/Nirum/Constructs/TypeExpressionSpec.hs b/test/Nirum/Constructs/TypeExpressionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Constructs/TypeExpressionSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.Constructs.TypeExpressionSpec where + +import Test.Hspec.Meta + +import Nirum.Constructs.TypeExpression (TypeExpression(..), toCode) + +spec :: Spec +spec = + describe "toCode TypeExpression" $ do + context "TypeIdentifier" $ + it "reverses the given tree to the code string" $ do + toCode (TypeIdentifier "text") `shouldBe` "text" + toCode (TypeIdentifier "enum") `shouldBe` "`enum`" + context "OptionModifier" $ + it "reverses the given tree to the code string" $ do + toCode (OptionModifier "text") `shouldBe` "text?" + toCode (OptionModifier $ SetModifier "text") + `shouldBe` "{text}?" + context "SetModifier" $ + it "reverses the given tree to the code string" $ do + toCode (SetModifier "text") `shouldBe` "{text}" + toCode (SetModifier $ OptionModifier "text") + `shouldBe` "{text?}" + context "ListModifier" $ + it "reverses the given tree to the code string" $ + toCode (ListModifier "text") `shouldBe` "[text]" + context "MapModifier" $ + it "reverses the given tree to the code string" $ do + toCode (MapModifier "uuid" "text") `shouldBe` "{uuid: text}" + toCode (MapModifier "uuid" $ ListModifier "text") + `shouldBe` "{uuid: [text]}" diff --git a/test/Nirum/PackageSpec.hs b/test/Nirum/PackageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/PackageSpec.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +module Nirum.PackageSpec where + +import qualified Data.Map.Strict as M +import System.FilePath (()) +import Test.Hspec.Meta + +import Nirum.Constructs.Annotation (empty) +import Nirum.Constructs.Module (Module(Module), coreModulePath) +import Nirum.Constructs.ModulePath (ModulePath) +import Nirum.Constructs.TypeDeclaration ( JsonType(String) + , PrimitiveTypeIdentifier(Text) + , Type(Alias, PrimitiveType) + , TypeDeclaration ( Import + , TypeDeclaration + ) + ) +import Nirum.Package ( BoundModule(boundPackage, modulePath) + , ImportError ( CircularImportError + , MissingImportError + , MissingModulePathError + ) + , Package + , PackageError (ImportError) + , TypeLookup(Imported, Local, Missing) + , docs + , lookupType + , makePackage + , resolveBoundModule + , resolveModule + , scanModules + , scanPackage + , types + ) +import Nirum.Parser (parseFile) + +createPackage :: M.Map ModulePath Module -> Package +createPackage modules' = + case makePackage modules' of + Right pkg -> pkg + Left e -> error $ "errored: " ++ show e + +validPackage :: Package +validPackage = + createPackage [ (["foo", "bar"], Module [] $ Just "foo.bar") + , (["foo", "baz"], Module [] $ Just "foo.baz") + , (["foo"], Module [] $ Just "foo") + , (["qux"], Module [] $ Just "qux") + , ( ["abc"] + , Module [TypeDeclaration "a" (Alias "text") Nothing empty] + Nothing + ) + , ( ["xyz"] + , Module [ Import ["abc"] "a" + , TypeDeclaration "x" (Alias "text") Nothing empty + ] Nothing + ) + ] + +missingImportsModules :: M.Map ModulePath Module +missingImportsModules = + [ (["foo"], Module [ Import ["foo", "bar"] "xyz" -- MissingModulePathError + , Import ["foo", "bar"] "zzz" -- MissingModulePathError + , Import ["baz"] "qux" + ] Nothing) + , ( ["baz"] + , Module [ TypeDeclaration "qux" (Alias "text") Nothing empty ] Nothing + ) + , (["qux"], Module [ Import ["foo"] "abc" -- MissingImportError + , Import ["foo"] "def" -- MissingImportError + ] Nothing) + ] + +circularImportsModules :: M.Map ModulePath Module +circularImportsModules = + [ (["asdf"], Module [ Import ["asdf"] "foo" + , TypeDeclaration "bar" (Alias "text") Nothing empty + ] Nothing) + , (["abc", "def"], Module [ Import ["abc", "ghi"] "bar" + , TypeDeclaration + "foo" (Alias "text") Nothing empty + ] Nothing) + , (["abc", "ghi"], Module [ Import ["abc", "xyz"] "baz" + , TypeDeclaration + "bar" (Alias "text") Nothing empty + ] Nothing) + , (["abc", "xyz"], Module [ Import ["abc", "def"] "foo" + , TypeDeclaration + "baz" (Alias "text") Nothing empty + ] Nothing) + ] + +spec :: Spec +spec = do + describe "Package" $ do + specify "resolveModule" $ do + resolveModule ["foo"] validPackage `shouldBe` + Just (Module [] $ Just "foo") + resolveModule ["foo", "bar"] validPackage `shouldBe` + Just (Module [] $ Just "foo.bar") + resolveModule ["qux"] validPackage `shouldBe` + Just (Module [] $ Just "qux") + resolveModule ["baz"] validPackage `shouldBe` Nothing + specify "resolveBoundModule" $ do + let Just bm = resolveBoundModule ["foo"] validPackage + boundPackage bm `shouldBe` validPackage + modulePath bm `shouldBe` ["foo"] + resolveBoundModule ["baz"] validPackage `shouldBe` Nothing + specify "detectMissingImports" $ + makePackage missingImportsModules `shouldBe` + Left [ MissingModulePathError ["foo"] ["foo", "bar"] + , MissingImportError ["qux"] ["foo"] "abc" + , MissingImportError ["qux"] ["foo"] "def" + ] + specify "detectCircularImports" $ + makePackage circularImportsModules `shouldBe` + Left [ CircularImportError [["asdf"], ["asdf"]] + , MissingImportError ["asdf"] ["asdf"] "foo" + , CircularImportError [ ["abc", "def"] + , ["abc", "ghi"] + , ["abc", "xyz"] + , ["abc", "def"] + ] + , CircularImportError [ ["abc", "ghi"] + , ["abc", "xyz"] + , ["abc", "def"] + , ["abc", "ghi"] + ] + , CircularImportError [ ["abc", "xyz"] + , ["abc", "def"] + , ["abc", "ghi"] + , ["abc", "xyz"] + ] + ] + specify "scanPackage" $ do + let path = "." "examples" + Right package <- scanPackage path + Right builtinsM <- parseFile (path "builtins.nrm") + Right productM <- parseFile (path "product.nrm") + Right shapesM <- parseFile (path "shapes.nrm") + Right countriesM <- parseFile (path "countries.nrm") + Right addressM <- parseFile (path "address.nrm") + Right pdfServiceM <- parseFile (path "pdf-service.nrm") + let modules = [ (["builtins"], builtinsM) + , (["product"], productM) + , (["shapes"], shapesM) + , (["countries"], countriesM) + , (["address"], addressM) + , (["pdf-service"], pdfServiceM) + ] :: M.Map ModulePath Module + package `shouldBe` createPackage modules + Left error' <- scanPackage $ "." "test" "import_error" + error' `shouldBe` + ImportError [MissingModulePathError ["import_error"] ["foo"]] + specify "scanModules" $ do + let path = "." "examples" + mods <- scanModules "." + mods `shouldBe` + [ (["examples", "builtins"], path "builtins.nrm") + , (["examples", "product"], path "product.nrm") + , (["examples", "shapes"], path "shapes.nrm") + , (["examples", "countries"], path "countries.nrm") + , (["examples", "address"], path "address.nrm") + , (["examples", "pdf-service"], path "pdf-service.nrm") + , ( ["test", "import_error", "import_error"] + , "." "test" "import_error" "import_error.nrm" + ) + ] + mods' <- scanModules path + mods' `shouldBe` [ (["builtins"], path "builtins.nrm") + , (["product"], path "product.nrm") + , (["shapes"], path "shapes.nrm") + , (["countries"], path "countries.nrm") + , (["address"], path "address.nrm") + , (["pdf-service"], path "pdf-service.nrm") + ] + describe "BoundModule" $ do + let Just bm = resolveBoundModule ["foo", "bar"] validPackage + Just abc = resolveBoundModule ["abc"] validPackage + Just xyz = resolveBoundModule ["xyz"] validPackage + specify "docs" $ do + docs bm `shouldBe` Just "foo.bar" + let Just bm' = resolveBoundModule ["foo"] validPackage + docs bm' `shouldBe` Just "foo" + specify "types" $ do + types bm `shouldBe` [] + types abc `shouldBe` [TypeDeclaration + "a" (Alias "text") Nothing empty] + types xyz `shouldBe` [ Import ["abc"] "a" + , TypeDeclaration + "x" (Alias "text") Nothing empty + ] + specify "lookupType" $ do + lookupType "a" bm `shouldBe` Missing + lookupType "a" abc `shouldBe` Local (Alias "text") + lookupType "a" xyz `shouldBe` Imported ["abc"] (Alias "text") + lookupType "x" bm `shouldBe` Missing + lookupType "x" abc `shouldBe` Missing + lookupType "x" xyz `shouldBe` Local (Alias "text") + lookupType "text" bm `shouldBe` + Imported coreModulePath (PrimitiveType Text String) + lookupType "text" abc `shouldBe` lookupType "text" bm + lookupType "text" xyz `shouldBe` lookupType "text" bm diff --git a/test/Nirum/ParserSpec.hs b/test/Nirum/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/ParserSpec.hs @@ -0,0 +1,896 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings, TypeFamilies #-} +module Nirum.ParserSpec where + +import Control.Monad (forM_) +import Data.Either (isLeft, isRight, lefts, rights) +import Data.List (isSuffixOf) +import Data.Maybe (fromJust) +import Prelude hiding (readFile) +import System.Directory (getDirectoryContents) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Text.IO (readFile) +import Test.Hspec.Meta +import Text.Megaparsec (eof, runParser) +import Text.Megaparsec.Char (string) +import Text.Megaparsec.Error (errorPos, parseErrorPretty) +import Text.Megaparsec.Pos (Pos, SourcePos(sourceColumn, sourceLine), mkPos) +import Text.Megaparsec.Text (Parser) + +import qualified Nirum.Parser as P +import Nirum.Constructs (Construct (toCode)) +import Nirum.Constructs.Annotation ( Annotation (Annotation) + , AnnotationSet + , empty + , fromList + ) +import Nirum.Constructs.Declaration (Docs (Docs)) +import Nirum.Constructs.DeclarationSet (DeclarationSet) +import Nirum.Constructs.DeclarationSetSpec (SampleDecl(..)) +import Nirum.Constructs.Identifier (fromText) +import Nirum.Constructs.Module (Module (Module)) +import Nirum.Constructs.Name (Name(..)) +import Nirum.Constructs.Service ( Method (Method) + , Parameter (Parameter) + , Service (Service) + ) +import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember) + , Field (Field) + , Tag (Tag) + , Type (..) + , TypeDeclaration (..) + ) +import Nirum.Constructs.TypeExpression (TypeExpression (..)) + +shouldBeRight :: (Eq l, Eq r, Show l, Show r) => Either l r -> r -> Expectation +shouldBeRight actual expected = actual `shouldBe` Right expected + +erroredPos :: Either P.ParseError a -> (Pos, Pos) +erroredPos left = + (sourceLine pos, sourceColumn pos) + where + error' = head $ lefts [left] :: P.ParseError + pos = NE.head (errorPos error') :: SourcePos + +helperFuncs :: (Show a) + => Parser a + -> ( T.Text -> Either P.ParseError a + , T.Text -> Int -> Int -> Expectation + ) +helperFuncs parser = + (parse', expectError) + where + parserAndEof = do + r <- parser + eof + return r + parse' = runParser parserAndEof "" + expectError inputString line col = do + line' <- mkPos line + col' <- mkPos col + let parseResult = parse' inputString + parseResult `shouldSatisfy` isLeft + erroredPos parseResult `shouldBe` (line', col') + + +fooAnnotationSet :: AnnotationSet +fooAnnotationSet = head $ rights [fromList [Annotation "foo" (Just "bar")]] + +bazAnnotationSet :: AnnotationSet +bazAnnotationSet = head $ rights [fromList [Annotation "baz" Nothing]] + + +spec :: Spec +spec = do + describe "identifier" $ do + let (parse', expectError) = helperFuncs P.identifier + it "fails to parse an empty string" $ + expectError "" 1 1 + it "fails to parse an identifier starting with hyphen/underscore" $ do + expectError "-ident" 1 1 + expectError "-ident-ifier" 1 1 + expectError "_ident" 1 1 + expectError "_ident_ifier" 1 1 + expectError "_ident-ifier" 1 1 + expectError "-ident_ifier" 1 1 + it "fails to parse an identifier ending with hyphen/underscore" $ do + expectError "ident-" 1 7 + expectError "ident-ifier-" 1 13 + expectError "ident_" 1 7 + expectError "ident_ifier_" 1 13 + expectError "ident_ifier-" 1 13 + expectError "ident-ifier_" 1 13 + it "fails to parse an identifier with double hyphens/underscores" $ do + expectError "ident--ifier" 1 7 + expectError "ident__ifier" 1 7 + expectError "ident-_ifier" 1 7 + expectError "ident_-ifier" 1 7 + it "fails to parse an identifier containing disallowed chars" $ do + expectError "무효한-식별자" 1 1 + expectError "invalid-식별자" 1 9 + let keywords = [ "boxed", "enum", "record", "type", "union" + , "BOXED", "Enum", "rEcord", "tyPE", "unioN" + ] :: [T.Text] + it "fails to parse bare identifier if it's a reserved keyword" $ + forM_ keywords $ \kwd -> + expectError kwd 1 1 + let identifier' = fromJust . fromText + it "emits Identifier if succeeded to parse" $ do + parse' "identifier" `shouldBeRight` identifier' "identifier" + parse' "valid-identifier" `shouldBeRight` + identifier' "valid-identifier" + parse' "valid_identifier" `shouldBeRight` + identifier' "valid_identifier" + it "can parse reserved keywords iff they are quoted" $ + forM_ keywords $ \kwd -> + parse' ('`' `T.cons` kwd `T.snoc` '`') `shouldBeRight` + identifier' kwd + + describe "name" $ do + let (parse', expectError) = helperFuncs P.name + it "fails to parse an empty string" $ + expectError "" 1 1 + it "fails to parse if the name is not a valid identifier" $ do + expectError "-ident" 1 1 + expectError "-ident-ifier" 1 1 + expectError "ident-" 1 7 + expectError "ident-ifier-" 1 13 + expectError "ident--ifier" 1 7 + expectError "ident__ifier" 1 7 + expectError "무효한-식별자" 1 1 + expectError "invalid-식별자" 1 9 + it "fails to parse if the facial name is not a valid identifier" $ do + expectError "-ident/valid" 1 1 + expectError "-ident-ifier/valid" 1 1 + expectError "ident-/valid" 1 7 + expectError "ident-ifier-/valid" 1 13 + expectError "ident--ifier/valid" 1 7 + expectError "ident__ifier/valid" 1 7 + expectError "무효한-식별자/valid" 1 1 + expectError "invalid-식별자/valid" 1 9 + it "fails to parse if the behind name is not a valid identifier" $ do + expectError "valid/-ident" 1 6 + expectError "valid/-ident-ifier" 1 6 + expectError "valid/ident-" 1 6 + expectError "valid/ident-ifier-" 1 6 + expectError "valid/ident--ifier" 1 6 + expectError "valid/ident__ifier" 1 6 + expectError "valid/무효한-식별자" 1 6 + expectError "valid/invalid-식별자" 1 6 + it "emits Name if succeeded to parse" $ do + parse' "name" `shouldBeRight` Name "name" "name" + parse' "`enum`" `shouldBeRight` Name "enum" "enum" + parse' "facial/behind" `shouldBeRight` Name "facial" "behind" + parse' "facial / behind" `shouldBeRight` Name "facial" "behind" + parse' "`enum`/`boxed`" `shouldBeRight` Name "enum" "boxed" + parse' "`enum` / `boxed`" `shouldBeRight` Name "enum" "boxed" + + describe "annotation" $ do + let (parse', expectError) = helperFuncs P.annotation + context "with single argument" $ do + let rightAnnotaiton = Annotation "name-abc" (Just "wo\"rld") + it "success" $ do + parse' "@name-abc(\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton + parse' "@name-abc( \"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton + parse' "@name-abc(\"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton + parse' "@name-abc( \"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton + parse' "@ name-abc ( \"wo\\\"rld\")" `shouldBeRight` + rightAnnotaiton + parse' "@name-abc ( \"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton + it "fails to parse if annotation name start with hyphen" $ do + expectError "@-abc(\"helloworld\")" 1 2 + expectError "@-abc-d(\"helloworld\")" 1 2 + it "fails to parse without parentheses" $ + expectError "@foobar \"helloworld\"" 1 9 + it "fails to parse without double quotes" $ + expectError "@foobar(helloworld)" 1 9 + context "without arguments" $ do + let rightAnnotaiton = Annotation "name-abc" Nothing + it "success" $ do + parse' "@name-abc" `shouldBeRight` rightAnnotaiton + parse' "@name-abc " `shouldBeRight` rightAnnotaiton + parse' "@ name-abc" `shouldBeRight` rightAnnotaiton + parse' "@name-abc()" `shouldBeRight` rightAnnotaiton + parse' "@name-abc ( )" `shouldBeRight` rightAnnotaiton + parse' "@ name-abc ( )" `shouldBeRight` rightAnnotaiton + it "fails to parse if annotation name start with hyphen" $ do + expectError "@-abc" 1 2 + expectError "@-abc-d" 1 2 + + describe "annotationSet" $ do + let (parse', expectError) = helperFuncs P.annotationSet + annotationSet = head $ rights [fromList [ Annotation "a" (Just "b") + , Annotation "c" Nothing + ] + ] + it "success" $ do + parse' "@a(\"b\")@c" `shouldBeRight` annotationSet + parse' "@a(\"b\") @c" `shouldBeRight` annotationSet + parse' "@a(\"b\") @c() " `shouldBeRight` annotationSet + it "fails to parse if has duplicated name" $ + expectError "@a(\"b\")@a" 1 10 + + describe "typeIdentifier" $ do + let (parse', expectError) = helperFuncs P.typeIdentifier + it "fails to parse if the input is not a valid identifier" $ + expectError "-invalid-type-identifier" 1 1 + it "emits TypeIdentifier if succeeded to parse" $ do + parse' "text" `shouldBeRight` TypeIdentifier "text" + parse' "uuid" `shouldBeRight` TypeIdentifier "uuid" + + describe "optionModifier" $ do + let (_, expectError') = helperFuncs P.optionModifier + it "fails to parse if the input lacks a question mark" $ + expectError' "lacks-qmark" 1 12 + let parsers = [ P.optionModifier + , P.typeExpression + ] :: [Parser TypeExpression] + forM_ parsers $ \parser' -> do + let (parse', expectError) = helperFuncs parser' + it "cannot append two or more option modifiers" $ do + expectError "text??" 1 6 + expectError "text???" 1 6 + expectError "text????" 1 6 + it "emits OptionModifier if succeeded to parse" $ do + parse' "text?" `shouldBeRight` + OptionModifier (TypeIdentifier "text") + parse' "uuid ?" `shouldBeRight` + OptionModifier (TypeIdentifier "uuid") + parse' "{text}?" `shouldBeRight` + OptionModifier (SetModifier $ TypeIdentifier "text") + it "can be appended to set modifier" $ + parse' "{text}?" `shouldBeRight` + OptionModifier (SetModifier $ TypeIdentifier "text") + + describe "setModifier" $ do + let parsers = [ (1, P.setModifier) + , (29, P.typeExpression) + ] :: [(Int, Parser TypeExpression)] + forM_ parsers $ \(beginErrorPos, parser') -> do + let (parse', expectError) = helperFuncs parser' + it "fails to parse if input doesn't start with a curly bracket" $ + expectError "not-start-with-curly-bracket}" 1 beginErrorPos + it "fails to parse if input doesn't end with a curly bracket" $ + expectError "{not-end-with-curly-bracket" 1 28 + it "emits SetModifier if succeeded to parse" $ do + parse' "{text}" `shouldBeRight` + SetModifier (TypeIdentifier "text") + parse' "{ uuid }" `shouldBeRight` + SetModifier (TypeIdentifier "uuid") + it "can be nested to represent 2d set" $ do + parse' "{{text}}" `shouldBeRight` + SetModifier (SetModifier $ TypeIdentifier "text") + parse' "{[text]}" `shouldBeRight` + SetModifier (ListModifier $ TypeIdentifier "text") + it "can consist of optional elements" $ + parse' "{uuid?}" `shouldBeRight` + SetModifier (OptionModifier $ TypeIdentifier "uuid") + + describe "listModifier" $ do + let parsers = [ (1, P.listModifier) + , (30, P.typeExpression) + ] :: [(Int, Parser TypeExpression)] + forM_ parsers $ \(beginErrorPos, parser') -> do + let (parse', expectError) = helperFuncs parser' + it "fails to parse if input doesn't start with a square bracket" $ + expectError "not-start-with-square-bracket]" 1 beginErrorPos + it "fails to parse if input doesn't end with a square bracket" $ + expectError "[not-end-with-square-bracket" 1 29 + it "emits ListModifier if succeeded to parse" $ do + parse' "[text]" `shouldBeRight` + ListModifier (TypeIdentifier "text") + parse' "[ uuid ]" `shouldBeRight` + ListModifier (TypeIdentifier "uuid") + it "can be nested to represent 2d list" $ do + parse' "[[text]]" `shouldBeRight` + ListModifier (ListModifier $ TypeIdentifier "text") + parse' "[{text}]" `shouldBeRight` + ListModifier (SetModifier $ TypeIdentifier "text") + it "can consist of optional elements" $ + parse' "[uuid?]" `shouldBeRight` + ListModifier (OptionModifier $ TypeIdentifier "uuid") + + describe "mapModifier" $ do + let parsers = [ (1, P.mapModifier) + , (15, P.typeExpression) + ] :: [(Int, Parser TypeExpression)] + forM_ parsers $ \(beginErrorPos, parser') -> do + let (parse', expectError) = helperFuncs parser' + it "fails to parse if input doesn't start with a curly bracket" $ + expectError "not-start-with: curly-bracket}" 1 beginErrorPos + it "fails to parse if input doesn't end with a curly bracket" $ + expectError "{not-end-with: curly-bracket" 1 29 + it "emits MapModifier if succeeded to parse" $ do + parse' "{uuid: text}" `shouldBeRight` + MapModifier (TypeIdentifier "uuid") (TypeIdentifier "text") + parse' "{ text : uuid }" `shouldBeRight` + MapModifier (TypeIdentifier "text") (TypeIdentifier "uuid") + it "can be nested to represent 2d map" $ do + parse' "{uuid: {uuid: text}}" `shouldBeRight` + MapModifier (TypeIdentifier "uuid") + (MapModifier (TypeIdentifier "uuid") + (TypeIdentifier "text")) + parse' "{uuid: [text]}" `shouldBeRight` + MapModifier (TypeIdentifier "uuid") + (ListModifier $ TypeIdentifier "text") + + describe "typeExpression" $ do + let (_, expectError) = helperFuncs P.typeExpression + it "cannot append two or more option modifiers" $ do + expectError "text??" 1 6 + expectError "text???" 1 6 + expectError "text????" 1 6 + + describe "docs" $ do + let (parse', expectError) = helperFuncs P.docs + it "emits Docs if succeeded to parse" $ do + parse' "#docs" `shouldBeRight` Docs "docs\n" + parse' "#docs\n#docs..." `shouldBeRight` Docs "docs\ndocs...\n" + it "may ignore a leading space" $ do + parse' "# docs" `shouldBeRight` Docs "docs\n" + parse' "# docs\n# docs..." `shouldBeRight` Docs "docs\ndocs...\n" + parse' "# docs" `shouldBeRight` Docs " docs\n" + parse' "# docs\n# docs..." `shouldBeRight` + Docs " docs\n docs...\n" + it "may be mixed with whitespaces" $ do + parse' "# docs\n\n# docs..." `shouldBeRight` Docs "docs\ndocs...\n" + parse' "# docs\n # docs..." `shouldBeRight` + Docs "docs\ndocs...\n" + it "differs from comment" $ + expectError "// comment" 1 1 + + let descTypeDecl label parser spec' = + let parsers = [ (label, parser) + , (label ++ " (typeDescription)", P.typeDeclaration) + ] :: [(String, Parser TypeDeclaration)] + in forM_ parsers $ \(label', parser') -> + describe label' $ + spec' $ helperFuncs parser' + + describe "handleNameDuplication" $ do + let cont dset = do _ <- string "a" + return dset :: Parser (DeclarationSet SampleDecl) + it "fails if there are any duplication on facial names" $ do + let ds = [ "a" + , "b" + , SampleDecl (Name "b" "c") Nothing + ] :: [SampleDecl] + p = P.handleNameDuplication "LABEL" ds cont + (parse', expectError) = helperFuncs p + expectError "a" 1 1 + let (Left e) = parse' "a" + parseErrorPretty e `shouldBe` + "1:1:\nthe facial LABEL name `b` is duplicated\n" + it "fails if there are any duplication on behind names" $ do + let ds = [ "a" + , "b" + , SampleDecl (Name "c" "b") Nothing + ] :: [SampleDecl] + p = P.handleNameDuplication "LABEL" ds cont + (parse', expectError) = helperFuncs p + expectError "a" 1 1 + let (Left e) = parse' "a" + parseErrorPretty e `shouldBe` + "1:1:\nthe behind LABEL name `b` is duplicated\n" + it "continues using the given DeclarationSet if there are no dups" $ do + let ds = ["a", "b", "c"] :: [SampleDecl] + p = P.handleNameDuplication "LABEL" ds cont + (parse', _) = helperFuncs p + parse' "a" `shouldBeRight` + (["a", "b", "c"] :: DeclarationSet SampleDecl) + + descTypeDecl "aliasTypeDeclaration" P.aliasTypeDeclaration $ \helpers -> do + let (parse', expectError) = helpers + it "emits (TypeDeclaration (Alias ...)) if succeeded to parse" $ do + parse' "type path = text;" `shouldBeRight` + TypeDeclaration "path" (Alias "text") Nothing empty + parse' "type path = text;\n# docs" `shouldBeRight` + TypeDeclaration "path" (Alias "text") + (Just $ Docs "docs\n") empty + parse' "type path = text;\n# docs\n# docs..." `shouldBeRight` + TypeDeclaration "path" (Alias "text") + (Just $ Docs "docs\ndocs...\n") + empty + parse' "@foo ( \"bar\" ) type path = text;\n# docs\n# docs..." + `shouldBeRight` + TypeDeclaration "path" (Alias "text") + (Just $ Docs "docs\ndocs...\n") + fooAnnotationSet + parse' "@baz type path = text;\n# docs\n# docs..." + `shouldBeRight` + TypeDeclaration "path" (Alias "text") + (Just $ Docs "docs\ndocs...\n") + bazAnnotationSet + specify "its name can't have behind name since \ + \its canonical type's behind name would be used instead" $ + expectError "type path/error = text;" 1 10 + + descTypeDecl "boxedTypeDeclaration" P.boxedTypeDeclaration $ \helpers -> do + let (parse', expectError) = helpers + it "emits (TypeDeclaration (BoxedType ...)) if succeeded to parse" $ do + parse' "boxed offset (float64);" `shouldBeRight` + TypeDeclaration "offset" (BoxedType "float64") Nothing empty + parse' "boxed offset (float64);\n# docs" `shouldBeRight` + TypeDeclaration "offset" (BoxedType "float64") + (Just $ Docs "docs\n") + empty + parse' "boxed offset (float64);\n# docs\n# docs..." `shouldBeRight` + TypeDeclaration "offset" (BoxedType "float64") + (Just $ Docs "docs\ndocs...\n") + empty + parse' "@foo(\"bar\")\nboxed offset (float64);\n# docs\n# docs..." + `shouldBeRight` + TypeDeclaration "offset" (BoxedType "float64") + (Just $ Docs "docs\ndocs...\n") + fooAnnotationSet + parse' "@baz\nboxed offset (float64);\n# docs\n# docs..." + `shouldBeRight` + TypeDeclaration "offset" (BoxedType "float64") + (Just $ Docs "docs\ndocs...\n") + bazAnnotationSet + expectError "boxed offset/behind (float64);" 1 13 + + descTypeDecl "enumTypeDeclaration" P.enumTypeDeclaration $ \helpers -> do + let (parse', expectError) = helpers + it "emits (TypeDeclaration (EnumType ...)) if succeeded to parse" $ do + let members' = [ "male" + , "female" + , "unknown" + ] :: DeclarationSet EnumMember + membersWithDocs = [ EnumMember "male" (Just "docs\n") + , "female" + , EnumMember "unknown" (Just "docs2\n") + ] :: DeclarationSet EnumMember + expected = TypeDeclaration "gender" (EnumType members') Nothing + empty + parse' "enum gender = male | female | unknown;" + `shouldBeRight` expected + parse' "enum gender=male|female|unknown;" `shouldBeRight` expected + -- forward docs of enum type + parse' "enum gender\n# gender type\n= male | female | unknown;" + `shouldBeRight` expected { typeDocs = Just "gender type\n" } + -- backward docs of enum type + parse' "enum gender =\n# gender type\nmale | female | unknown;" + `shouldBeRight` expected { typeDocs = Just "gender type\n" } + parse' "enum gender = male # docs\n| female | unknown # docs2\n;" + `shouldBeRight` TypeDeclaration "gender" + (EnumType membersWithDocs) + Nothing + empty + parse' "@foo (\"bar\")\nenum gender=male|female|unknown;" + `shouldBeRight` + TypeDeclaration "gender" (EnumType members') + Nothing fooAnnotationSet + parse' "@baz\nenum gender=male|female|unknown;" + `shouldBeRight` + TypeDeclaration "gender" (EnumType members') + Nothing bazAnnotationSet + it "fails to parse if there are duplicated facial names" $ + expectError "enum dup = a/b\n\ + \ | b/c\n\ + \ | a/d\n\ + \ ;" 4 10 + it "fails to parse if there are duplicated behind names" $ + expectError "enum dup = a/b\n\ + \ | b/c\n\ + \ | c/b\n\ + \ ;" 4 10 + + descTypeDecl "recordTypeDeclaration" P.recordTypeDeclaration $ \helpers -> do + let (parse', expectError) = helpers + it "emits (TypeDeclaration (RecordType ...)) if succeeded to parse" $ do + let fields' = [ Field "name" "text" Nothing + , Field "dob" "date" $ Just "date of birth" + , Field "gender" "gender" Nothing + ] :: DeclarationSet Field + record = RecordType fields' + a = TypeDeclaration "person" record Nothing empty + b = a { typeDocs = Just "person record type" } + -- without docs, last field with trailing comma + parse' "record person (\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" `shouldBeRight` a + -- without docs, last field without trailing comma + parse' "record person (\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender\n\ + \);" `shouldBeRight` a + -- with docs, last field with trailing comma + parse' "record person (\n\ + \ # person record type\n\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" `shouldBeRight` b + -- with docs, last field without trailing comma + parse' "record person (\n\ + \ # person record type\n\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender\n\ + \);" `shouldBeRight` b + -- without docs, last field with trailing comma, + -- with annotation with single argument + parse' "@foo(\"bar\")\n\ + \record person (\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" + `shouldBeRight` + TypeDeclaration "person" record Nothing fooAnnotationSet + -- without docs, last field with trailing comma, + -- with annotation without arguments + parse' "@baz\n\ + \record person (\n\ + \ text name,\n\ + \ date dob,\n\ + \ # date of birth\n\ + \ gender gender,\n\ + \);" + `shouldBeRight` + TypeDeclaration "person" record Nothing bazAnnotationSet + it "should have one or more fields" $ do + expectError "record unit ();" 1 14 + expectError "record unit (\n# docs\n);" 3 1 + it "fails to parse if there are duplicated facial names" $ + expectError "record dup (\n\ + \ text a/b,\n\ + \ text b/c,\n\ + \ text a/d,\n\ + \);" 5 1 + it "fails to parse if there are duplicated behind names" $ + expectError "record dup (\n\ + \ text a/b,\n\ + \ text b/c,\n\ + \ text c/b,\n\ + \);" 5 1 + it "fails to parse if there's no space between field type and name" $ do + expectError "record a (typename);" 1 11 + expectError "record a (typename\n#docs\n);" 1 11 + + descTypeDecl "unionTypeDeclaration" P.unionTypeDeclaration $ \helpers -> do + let (parse', expectError) = helpers + it "emits (TypeDeclaration (UnionType ...)) if succeeded to parse" $ do + let circleFields = [ Field "origin" "point" Nothing + , Field "radius" "offset" Nothing + ] + rectangleFields = [ Field "upper-left" "point" Nothing + , Field "lower-right" "point" Nothing + ] + tags' = [ Tag "circle" circleFields Nothing + , Tag "rectangle" rectangleFields Nothing + , Tag "none" [] Nothing + ] + union = UnionType tags' + a = TypeDeclaration "shape" union Nothing empty + b = a { typeDocs = Just "shape type" } + parse' "union shape\n\ + \ = circle (point origin, \ + \offset radius,)\n\ + \ | rectangle (point upper-left, \ + \point lower-right,)\n\ + \ | none\n\ + \ ;" `shouldBeRight` a + parse' "union shape\n\ + \ # shape type\n\ + \ = circle (point origin, \ + \offset radius,)\n\ + \ | rectangle (point upper-left, \ + \point lower-right,)\n\ + \ | none\n\ + \ ;" `shouldBeRight` b + it "fails to parse if there are duplicated facial names" $ do + expectError "union dup\n\ + \ = a/b\n\ + \ | b/c\n\ + \ | a/d\n\ + \ ;" 5 6 + expectError "union dup\n\ + \ = a (text a/b, text b/c, text a/d)\n\ + \ | b\n\ + \ ;" 2 38 + it "fails to parse if there are duplicated behind names" $ do + expectError "union dup\n\ + \ = a/b\n\ + \ | b/c\n\ + \ | c/b\n\ + \ ;" 5 6 + expectError "union dup\n\ + \ = a (text a/b, text b/c, text c/b)\n\ + \ | b\n\ + \ ;" 2 38 + + describe "method" $ do + let (parse', expectError) = helperFuncs P.method + httpGetAnnotation = + head $ rights [fromList [Annotation "http-get" (Just "/get-name/")]] + it "emits Method if succeeded to parse" $ do + parse' "text get-name()" `shouldBeRight` + Method "get-name" [] "text" Nothing Nothing empty + parse' "text get-name (person user)" `shouldBeRight` + Method "get-name" [Parameter "user" "person" Nothing] + "text" Nothing Nothing empty + parse' "text get-name ( person user,text default )" `shouldBeRight` + Method "get-name" + [ Parameter "user" "person" Nothing + , Parameter "default" "text" Nothing + ] + "text" Nothing Nothing empty + parse' "@http-get(\"/get-name/\") text get-name ( person user,text default )" `shouldBeRight` + Method "get-name" + [ Parameter "user" "person" Nothing + , Parameter "default" "text" Nothing + ] + "text" Nothing Nothing httpGetAnnotation + parse' "text get-name() throws name-error" `shouldBeRight` + Method "get-name" [] "text" (Just "name-error") Nothing empty + parse' "text get-name ( person user,text default )\n\ + \ throws get-name-error" `shouldBeRight` + Method "get-name" + [ Parameter "user" "person" Nothing + , Parameter "default" "text" Nothing + ] + "text" (Just "get-name-error") Nothing empty + parse' "@http-get(\"/get-name/\")\n\ + \text get-name ( person user,text default )\n\ + \ throws get-name-error" `shouldBeRight` + Method "get-name" + [ Parameter "user" "person" Nothing + , Parameter "default" "text" Nothing + ] + "text" (Just "get-name-error") + Nothing + httpGetAnnotation + it "can have docs" $ do + parse' "text get-name (\n\ + \ # Gets the name.\n\ + \)" `shouldBeRight` + Method "get-name" [] "text" + Nothing (Just "Gets the name.") empty + parse' "text get-name (\n\ + \ # Gets the name.\n\ + \)throws name-error " `shouldBeRight` + Method "get-name" [] "text" + (Just "name-error") + (Just "Gets the name.") + empty + parse' "text get-name (\n\ + \ # Gets the name of the user.\n\ + \ person user,\n\ + \)" `shouldBeRight` + Method "get-name" + [Parameter "user" "person" Nothing] + "text" + Nothing + (Just "Gets the name of the user.") + empty + parse' "text get-name (\n\ + \ # Gets the name of the user.\n\ + \ person user,\n\ + \) throws get-name-error" `shouldBeRight` + Method "get-name" + [Parameter "user" "person" Nothing] + "text" + (Just "get-name-error") + (Just "Gets the name of the user.") + empty + parse' "text get-name (\n\ + \ # Gets the name of the user.\n\ + \ person user,\n\ + \ # The person to find their name.\n\ + \ text default\n\ + \ # The default name used when the user has no name.\n\ + \)" `shouldBeRight` + Method "get-name" + [ Parameter "user" "person" $ + Just "The person to find their name." + , Parameter "default" "text" $ + Just "The default name used when \ + \the user has no name." + ] + "text" + Nothing + (Just "Gets the name of the user.") + empty + it "fails to parse if there are parameters of the same facial name" $ do + expectError "bool pred(text a, text a/b)" 1 11 + expectError "bool pred(text a/b, text a)" 1 11 + expectError "bool pred(text c/a, text c/b)" 1 11 + it "fails to parse if there are parameters of the same behind name" $ do + expectError "bool pred(text a, text b/a)" 1 11 + expectError "bool pred(text a/b, text b)" 1 11 + expectError "bool pred(text a/c, text b/c)" 1 11 + + describe "serviceDeclaration" $ do + let (parse', expectError) = helperFuncs P.serviceDeclaration + it "emits ServiceDeclaration if succeeded to parse" $ do + parse' "service null-service();" `shouldBeRight` + ServiceDeclaration "null-service" (Service []) Nothing empty + parse' "service null-service (\n\ + \ # Service having no methods.\n\ + \);" `shouldBeRight` + ServiceDeclaration "null-service" + (Service []) + (Just "Service having no methods.") + empty + parse' "service one-method-service(\n\ + \ user get-user(uuid user-id)\n\ + \);" `shouldBeRight` + ServiceDeclaration + "one-method-service" + (Service [ Method "get-user" + [Parameter "user-id" "uuid" Nothing] + "user" + Nothing + Nothing + empty + ]) + Nothing + empty + parse' "service one-method-service (\n\ + \ # Service having only one method.\n\ + \ user get-user (\n\ + \ # Gets an user by its id.\n\ + \ uuid user-id\n\ + \ ) throws get-user-error,\n\ + \);" `shouldBeRight` + ServiceDeclaration + "one-method-service" + (Service [ Method "get-user" + [Parameter "user-id" "uuid" Nothing] + "user" + (Just "get-user-error") + (Just "Gets an user by its id.") + empty + ]) + (Just "Service having only one method.") + empty + parse' "service user-service (\n\ + \ # Service having multiple methods.\n\ + \ user create-user (\n\ + \ # Creates a new user\n\ + \ user user\n\ + \ ),\n\ + \ user get-user (\n\ + \ # Gets an user by its id.\n\ + \ uuid user-id\n\ + \ ),\n\ + \);" `shouldBeRight` + ServiceDeclaration + "user-service" + (Service [ Method "create-user" + [Parameter "user" "user" Nothing] + "user" + Nothing + (Just "Creates a new user") + empty + , Method "get-user" + [Parameter "user-id" "uuid" Nothing] + "user" + Nothing + (Just "Gets an user by its id.") + empty + ]) + (Just "Service having multiple methods.") + empty + parse' "@foo(\"bar\")\n\ + \service null-service (\n\ + \ # Service having no methods.\n\ + \);" `shouldBeRight` + ServiceDeclaration "null-service" + (Service []) + (Just "Service having no methods.") + fooAnnotationSet + parse' "@baz\n\ + \service null-service (\n\ + \ # Service having no methods.\n\ + \);" `shouldBeRight` + ServiceDeclaration "null-service" + (Service []) + (Just "Service having no methods.") + bazAnnotationSet + it "fails to parse if there are methods of the same facial name" $ do + expectError "service method-dups (\n\ + \ bool same-name ()\n\ + \ text same-name (uuid id)\n\ + \);" 3 3 + expectError "service method-dups (\n\ + \ bool same-name ()\n\ + \ text same-name/different-behind-name (uuid id)\n\ + \);" 3 3 + expectError "service method-dups (\n\ + \ bool same-name/unique-behind-name ()\n\ + \ text same-name/different-behind-name (uuid id)\n\ + \);" 3 3 + it "fails to parse if there are methods of the same behind name" $ do + expectError "service method-dups (\n\ + \ bool same-name ()\n\ + \ text same-name (uuid id)\n\ + \);" 3 3 + expectError "service method-dups (\n\ + \ bool same-name ()\n\ + \ text unique-name/same-name (uuid id)\n\ + \);" 3 3 + expectError "service method-dups (\n\ + \ bool unique-name/same-name ()\n\ + \ text different-facial-name/same-name (uuid id)\n\ + \);" 3 3 + let moduleParsers = [ ("module'", P.module') + , ("file", P.file) + ] :: [(String, Parser Module)] + forM_ moduleParsers $ \(label, parser') -> + describe label $ do + let (parse', expectError) = helperFuncs parser' + it "emits Module if succeeded to parse" $ do + let decls = [ TypeDeclaration "path" (Alias "text") Nothing + empty + , TypeDeclaration "offset" + (BoxedType "float64") Nothing + empty + ] + parse' "type path = text; boxed offset (float64);" + `shouldBeRight` Module decls Nothing + parse' "#docs\n#...\ntype path = text; boxed offset (float64);" + `shouldBeRight` Module decls (Just "docs\n...") + it "may have no type declarations" $ do + parse' "" `shouldBeRight` Module [] Nothing + parse' "# docs" `shouldBeRight` Module [] (Just "docs") + it "errors if there are any duplicated facial names" $ + expectError "type a = text;\ntype a/b = text;" 2 1 + it "errors if there are any duplicated behind names" $ + expectError "type b = text;\ntype a/b = text;" 2 1 + + describe "modulePath" $ do + let (parse', expectError) = helperFuncs P.modulePath + it "emits ModulePath if succeeded to parse" $ do + parse' "foo" `shouldBeRight` ["foo"] + parse' "foo.bar" `shouldBeRight` ["foo", "bar"] + parse' "foo.bar.baz" `shouldBeRight` ["foo", "bar", "baz"] + it "errors if it's empty" $ + expectError "" 1 1 + it "errors if it starts with period" $ do + expectError "." 1 1 + expectError ".foo" 1 1 + expectError ".foo.bar" 1 1 + expectError ".foo.bar.baz" 1 1 + it "errors if it ends with period" $ do + expectError "." 1 1 + expectError "foo." 1 5 + expectError "foo.bar." 1 9 + expectError "foo.bar.baz." 1 13 + + describe "imports" $ do + let (parse', expectError) = helperFuncs P.imports + it "emits Import values if succeeded to parse" $ + parse' "import foo.bar (a, b);" `shouldBeRight` + [ Import ["foo", "bar"] "a" + , Import ["foo", "bar"] "b" + ] + it "errors if parentheses have nothing" $ + expectError "import foo.bar ();" 1 17 + + specify "parse & parseFile" $ do + files <- getDirectoryContents "examples" + let examples = map ("examples/" ++) $ filter (isSuffixOf ".nrm") files + forM_ examples $ \filePath -> do + sourceCode <- readFile filePath + let parseResult = P.parse (filePath ++ " (text)") sourceCode + parseResult `shouldSatisfy` isRight + let Right module' = parseResult + P.parse (filePath ++ " (text inverse)") (toCode module') + `shouldBeRight` module' + parseFileResult <- P.parseFile filePath + parseFileResult `shouldSatisfy` isRight + parseFileResult `shouldBe` parseResult + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/test/Nirum/Targets/PythonSpec.hs b/test/Nirum/Targets/PythonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Targets/PythonSpec.hs @@ -0,0 +1,905 @@ +{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes, + ScopedTypeVariables #-} +{-| +This unit test module optionally depends on Python interpreter. +It internally tries to popen python3 executable, and import nirum Python +package. If any of these prerequisites are not satisfied, tests depending +on Python interpreter are skipped instead of marked failed. + +To make Python interpreter possible to import nirum package, you need to +install the nirum package to your Python site-packages using pip command. +We recommend to install the package inside a virtualenv (pyvenv) and +run this unit test in the virtualenv (pyvenv). E.g.: + +> $ pyvenv env +> $ . env/bin/activate +> (env)$ pip install git+git://github.com/spoqa/nirum-python.git +> (env)$ cabal test # or: stack test +-} +module Nirum.Targets.PythonSpec where + +import Control.Monad (forM_, void, unless) +import Data.Char (isSpace) +import Data.Maybe (fromJust, isJust) +import System.IO.Error (catchIOError) + +import Data.List (dropWhileEnd) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Data.Text.IO as TI +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath (isValid, takeDirectory, ()) +import System.Info (os) +import System.IO.Temp (withSystemTempDirectory) +import System.Process ( CreateProcess(cwd) + , proc + , readCreateProcess + , readCreateProcessWithExitCode + ) +import Test.Hspec.Meta +import Text.InterpolatedString.Perl6 (q, qq) +import Text.Megaparsec (char, digitChar, runParser, some, space, string') +import Text.Megaparsec.String (Parser) + +import Nirum.Constructs.Annotation (empty) +import Nirum.Constructs.DeclarationSet (DeclarationSet) +import Nirum.Constructs.Identifier (Identifier) +import Nirum.Constructs.Module (Module(Module)) +import Nirum.Constructs.ModulePath (ModulePath, fromIdentifiers) +import Nirum.Constructs.Name (Name(Name)) +import Nirum.Constructs.Service ( Method (Method) + , Parameter (Parameter) + , Service (Service) + ) +import Nirum.Constructs.TypeDeclaration ( Field(Field) + , EnumMember(EnumMember) + , PrimitiveTypeIdentifier(..) + , Tag(Tag) + , Type( Alias + , BoxedType + , EnumType + , RecordType + , UnionType + ) + , TypeDeclaration ( Import + , ServiceDeclaration + , TypeDeclaration + ) + ) +import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier + , MapModifier + , OptionModifier + , SetModifier + , TypeIdentifier + ) + ) +import Nirum.Package (BoundModule(modulePath), Package, resolveBoundModule) +import Nirum.PackageSpec (createPackage) +import Nirum.Targets.Python ( Source (Source) + , Code + , CodeGen( code + , localImports + , standardImports + , thirdPartyImports + ) + , CompileError + , InstallRequires ( InstallRequires + , dependencies + , optionalDependencies + ) + , addDependency + , addOptionalDependency + , compileError + , compilePackage + , compilePrimitiveType + , compileTypeExpression + , hasError + , toAttributeName + , toClassName + , toImportPath + , toNamePair + , unionInstallRequires + , withLocalImport + , withStandardImport + , withThirdPartyImports + ) + +codeGen :: a -> CodeGen a +codeGen = return + +windows :: Bool +windows = os `elem` (["mingw32", "cygwin32", "win32"] :: [String]) + +data PyVersion = PyVersion Int Int Int deriving (Eq, Ord, Show) + +installedPythonPaths :: Maybe FilePath -> IO [FilePath] +installedPythonPaths cwd' = do + (exitCode, stdOut, _) <- readCreateProcessWithExitCode proc' "" + return $ case exitCode of + ExitSuccess -> filter isValid $ lines' stdOut + _ -> [] + where + proc' :: CreateProcess + proc' = (if windows then proc "where.exe" ["python"] else proc "which" ["python3"]) { cwd = cwd' } + lines' :: String -> [String] + lines' = map T.unpack . filter (not . T.null) . map T.strip . T.lines . T.pack + +getPythonVersion :: Maybe FilePath -> FilePath -> IO (Maybe PyVersion) +getPythonVersion cwd' path' = do + let proc' = (proc path' ["-V"]) { cwd = cwd' } + pyVersionStr <- readCreateProcess proc' "" + return $ case runParser pyVersionParser "" pyVersionStr of + Left _ -> Nothing + Right v -> Just v + where + pyVersionParser :: Parser PyVersion + pyVersionParser = do + void $ string' "python" + space + major <- integer + void $ char '.' + minor <- integer + void $ char '.' + micro <- integer + return $ PyVersion major minor micro + integer :: Parser Int + integer = do + digits <- some digitChar + return (read digits :: Int) + +findPython :: Maybe FilePath -> IO (Maybe FilePath) +findPython cwd' = installedPythonPaths cwd' >>= findPython' + where + findPython' :: [FilePath] -> IO (Maybe FilePath) + findPython' (x:xs) = do + pyVerM <- getPythonVersion cwd' x + case pyVerM of + Nothing -> findPython' xs + Just version -> if version >= PyVersion 3 3 0 + then return $ Just x + else findPython' xs + findPython' [] = return Nothing + +runPython' :: Maybe FilePath -> [String] -> String -> IO (Maybe String) +runPython' cwd' args stdinStr = do + pyPathM <- findPython cwd' + case pyPathM of + Nothing -> do + putStrLn "Python 3 seems not installed; skipping..." + return Nothing + Just path -> execute cwd' path args stdinStr + where + execute :: Maybe FilePath + -> FilePath + -> [String] + -> String + -> IO (Maybe String) + execute cwdPath pyPath args' stdinStr' = do + let proc' = (proc pyPath args') { cwd = cwdPath } + result <- readCreateProcess proc' stdinStr' + return $ Just result + +runPython :: Maybe FilePath -> String -> IO (Maybe String) +runPython cwd' code' = + catchIOError (runPython' cwd' [] code') $ \e -> do + putStrLn "\nThe following IO error was raised:\n" + putStrLn $ indent " " $ show e + putStrLn "\n... while the following code was executed:\n" + putStrLn $ indent " " code' + ioError e + where + indent :: String -> String -> String + indent spaces content = unlines [spaces ++ l | l <- lines content] + +testPythonSuit :: Maybe FilePath -> String -> T.Text -> IO () +testPythonSuit cwd' suitCode testCode = do + nirumPackageInstalledM <- + runPython cwd' [q| +try: import nirum +except ImportError: print('F') +else: print('T') + |] + case nirumPackageInstalledM of + Just nirumPackageInstalled -> + case strip nirumPackageInstalled of + "T" -> do + resultM <- runPython cwd' suitCode + case resultM of + Just result -> + unless (strip result == "True") $ + expectationFailure $ + T.unpack ("Test failed: " `T.append` testCode) + Nothing -> return () + _ -> putStrLn "The nirum Python package cannot be imported; \ + \skipped..." + Nothing -> return () + where + strip :: String -> String + strip = dropWhile isSpace . dropWhileEnd isSpace + +testPython :: Maybe FilePath -> T.Text -> T.Text -> IO () +testPython cwd' defCode testCode = testPythonSuit cwd' code' testCode' + where + -- to workaround hlint's "Eta reduce" warning + -- hlint seems unable to look inside qq string literal... + testCode' :: T.Text + testCode' = testCode + code' :: String + code' = [qq|$defCode + +if __name__ == '__main__': + print(bool($testCode')) +|] + +testRaisePython :: Maybe FilePath -> T.Text -> T.Text -> T.Text -> IO () +testRaisePython cwd' errorClassName defCode testCode = + testPythonSuit cwd' code' testCode'' + where + -- to workaround hlint's "Eta reduce" warning + -- hlint seems unable to look inside qq string literal... + testCode'' :: T.Text + testCode'' = testCode + code' :: String + code' = [qq|$defCode + +if __name__ == '__main__': + try: + $testCode'' + except $errorClassName: + print(True) + else: + print(False) +|] + +makeDummySource' :: [Identifier] -> Module -> Source +makeDummySource' pathPrefix m = + Source pkg $ fromJust $ resolveBoundModule ["foo"] pkg + where + mp :: [Identifier] -> ModulePath + mp identifiers = fromJust $ fromIdentifiers (pathPrefix ++ identifiers) + pkg :: Package + pkg = createPackage + [ (mp ["foo"], m) + , ( mp ["foo", "bar"] + , Module [ Import (mp ["qux"]) "path" + , TypeDeclaration "path-box" (BoxedType "path") Nothing + empty + , TypeDeclaration "int-box" (BoxedType "bigint") + Nothing empty + , TypeDeclaration "point" + (RecordType [ Field "x" "int64" Nothing + , Field "y" "int64" Nothing + ]) + Nothing + empty + ] Nothing + ) + , ( mp ["qux"] + , Module + [ TypeDeclaration "path" (Alias "text") Nothing empty + , TypeDeclaration "name" (BoxedType "text") Nothing empty + ] + Nothing + ) + ] + +makeDummySource :: Module -> Source +makeDummySource = makeDummySource' [] + +spec :: Spec +spec = parallel $ do + describe "CodeGen" $ do + let v = 123 :: Int + cg = return v :: CodeGen Int + f = return . g :: Int -> CodeGen Int + f' = return . h :: Int -> CodeGen Int + g = (+ 5) :: Int -> Int + h = (* 2) :: Int -> Int + g' = pure g :: CodeGen (Int -> Int) + h' = pure h :: CodeGen (Int -> Int) + id' x = x + context "Functor" $ do + specify "identity morphisms" $ + fmap id' (return 123 :: CodeGen Int) `shouldBe` id' (return 123) + specify "composition of morphisms" $ do + fmap (g . h) cg `shouldBe` (fmap g . fmap h) cg + fmap (h . g) cg `shouldBe` (fmap h . fmap g) cg + context "Applicative" $ do + specify "identity law" $ + (pure id' <*> cg) `shouldBe` cg + specify "homomorphism" $ do + let pure' = pure :: a -> CodeGen a + (pure g <*> pure v) `shouldBe` pure' (g v) + (pure h <*> pure v) `shouldBe` pure' (h v) + specify "interchange" $ do + (g' <*> pure v) `shouldBe` (pure ($ v) <*> g') + (h' <*> pure v) `shouldBe` (pure ($ v) <*> h') + specify "composition" $ do + (g' <*> (h' <*> cg)) `shouldBe` (pure (.) <*> g' <*> h' <*> cg) + (h' <*> (g' <*> cg)) `shouldBe` (pure (.) <*> h' <*> g' <*> cg) + context "Monad" $ do + specify "left identity" $ do + (return v >>= f) `shouldBe` f v + (return v >>= f') `shouldBe` f' v + specify "right identity" $ + (cg >>= return) `shouldBe` cg + specify "associativity" $ do + ((cg >>= f) >>= f') `shouldBe` (cg >>= (\x -> f x >>= f')) + ((cg >>= f') >>= f) `shouldBe` (cg >>= (\x -> f' x >>= f)) + specify "packages and imports" $ do + let (c :: CodeGen Int) = do + a <- withStandardImport "sys" cg + b <- withThirdPartyImports + [("nirum", ["serialize_boxed_type"])] + cg + c' <- withLocalImport ".." "Gender" cg + d <- withStandardImport "os" cg + e <- withThirdPartyImports + [("nirum", ["serialize_enum_type"])] + cg + f'' <- withLocalImport ".." "Path" cg + return $ sum ([a, b, c', d, e, f''] :: [Int]) + c `shouldSatisfy` (not . hasError) + standardImports c `shouldBe` ["os", "sys"] + thirdPartyImports c `shouldBe` + [("nirum", ["serialize_boxed_type", "serialize_enum_type"])] + localImports c `shouldBe` [("..", ["Gender", "Path"])] + code c `shouldBe` (123 * 6) + specify "withStandardImport" $ do + let codeGen1 = withStandardImport "sys" (pure True) + codeGen1 `shouldSatisfy` (not . hasError) + standardImports codeGen1 `shouldBe` ["sys"] + thirdPartyImports codeGen1 `shouldBe` [] + localImports codeGen1 `shouldBe` [] + code codeGen1 `shouldBe` True + compileError codeGen1 `shouldBe` Nothing + let codeGen2 = withStandardImport "os" codeGen1 + codeGen2 `shouldSatisfy` (not . hasError) + standardImports codeGen2 `shouldBe` ["os", "sys"] + thirdPartyImports codeGen2 `shouldBe` [] + localImports codeGen2 `shouldBe` [] + code codeGen2 `shouldBe` True + compileError codeGen2 `shouldBe` Nothing + specify "fail" $ do + let codeGen' = do + val <- withStandardImport "sys" (pure True) + _ <- fail "test" + withStandardImport "sys" (pure val) + compileError codeGen' `shouldBe` Just "test" + + specify "compilePrimitiveType" $ do + code (compilePrimitiveType Bool) `shouldBe` "bool" + code (compilePrimitiveType Bigint) `shouldBe` "int" + let decimal = compilePrimitiveType Decimal + code decimal `shouldBe` "decimal.Decimal" + standardImports decimal `shouldBe` ["decimal"] + code (compilePrimitiveType Int32) `shouldBe` "int" + code (compilePrimitiveType Int64) `shouldBe` "int" + code (compilePrimitiveType Float32) `shouldBe` "float" + code (compilePrimitiveType Float64) `shouldBe` "float" + code (compilePrimitiveType Text) `shouldBe` "str" + code (compilePrimitiveType Binary) `shouldBe` "bytes" + let date = compilePrimitiveType Date + code date `shouldBe` "datetime.date" + standardImports date `shouldBe` ["datetime"] + let datetime = compilePrimitiveType Datetime + code datetime `shouldBe` "datetime.datetime" + standardImports datetime `shouldBe` ["datetime"] + let uuid = compilePrimitiveType Uuid + code uuid `shouldBe` "uuid.UUID" + standardImports uuid `shouldBe` ["uuid"] + code (compilePrimitiveType Uri) `shouldBe` "str" + + describe "compileTypeExpression" $ do + let s = makeDummySource $ Module [] Nothing + specify "TypeIdentifier" $ do + let c = compileTypeExpression s (TypeIdentifier "bigint") + c `shouldSatisfy` (not . hasError) + standardImports c `shouldBe` [] + localImports c `shouldBe` [] + code c `shouldBe` "int" + specify "OptionModifier" $ do + let c' = compileTypeExpression s (OptionModifier "text") + c' `shouldSatisfy` (not . hasError) + standardImports c' `shouldBe` ["typing"] + localImports c' `shouldBe` [] + code c' `shouldBe` "typing.Optional[str]" + specify "SetModifier" $ do + let c'' = compileTypeExpression s (SetModifier "text") + c'' `shouldSatisfy` (not . hasError) + standardImports c'' `shouldBe` ["typing"] + localImports c'' `shouldBe` [] + code c'' `shouldBe` "typing.AbstractSet[str]" + specify "ListModifier" $ do + let c''' = compileTypeExpression s (ListModifier "text") + c''' `shouldSatisfy` (not . hasError) + standardImports c''' `shouldBe` ["typing"] + localImports c''' `shouldBe` [] + code c''' `shouldBe` "typing.Sequence[str]" + specify "MapModifier" $ do + let c'''' = compileTypeExpression s (MapModifier "uuid" "text") + c'''' `shouldSatisfy` (not . hasError) + standardImports c'''' `shouldBe` ["uuid", "typing"] + localImports c'''' `shouldBe` [] + code c'''' `shouldBe` "typing.Mapping[uuid.UUID, str]" + + describe "toClassName" $ do + it "transform the facial name of the argument into PascalCase" $ do + toClassName "test" `shouldBe` "Test" + toClassName "hello-world" `shouldBe` "HelloWorld" + it "appends an underscore to the result if it's a reserved keyword" $ do + toClassName "true" `shouldBe` "True_" + toClassName "false" `shouldBe` "False_" + toClassName "none" `shouldBe` "None_" + + describe "toAttributeName" $ do + it "transform the facial name of the argument into snake_case" $ do + toAttributeName "test" `shouldBe` "test" + toAttributeName "hello-world" `shouldBe` "hello_world" + it "appends an underscore to the result if it's a reserved keyword" $ do + toAttributeName "def" `shouldBe` "def_" + toAttributeName "lambda" `shouldBe` "lambda_" + toAttributeName "nonlocal" `shouldBe` "nonlocal_" + + describe "toNamePair" $ do + it "transforms the name to a Python code string of facial/behind pair" $ + do toNamePair "text" `shouldBe` "('text', 'text')" + toNamePair (Name "test" "hello") `shouldBe` "('test', 'hello')" + it "replaces hyphens to underscores" $ do + toNamePair "hello-world" `shouldBe` "('hello_world', 'hello_world')" + toNamePair (Name "hello-world" "annyeong-sesang") `shouldBe` + "('hello_world', 'annyeong_sesang')" + it "appends an underscore if the facial name is a Python keyword" $ do + toNamePair "def" `shouldBe` "('def_', 'def')" + toNamePair "lambda" `shouldBe` "('lambda_', 'lambda')" + toNamePair (Name "abc" "lambda") `shouldBe` "('abc', 'lambda')" + toNamePair (Name "lambda" "abc") `shouldBe` "('lambda_', 'abc')" + + let test testRunner (Source pkg boundM) testCode = + case errors of + error':_ -> fail $ T.unpack error' + [] -> withSystemTempDirectory "nirumpy." $ \dir -> do + forM_ codes $ \(filePath, code') -> do + let filePath' = dir filePath + dirName = takeDirectory filePath' + createDirectoryIfMissing True dirName + TI.writeFile filePath' code' + testRunner (Just dir) defCode testCode + where + files :: M.Map FilePath (Either CompileError Code) + files = compilePackage pkg + errors :: [CompileError] + errors = [error' | (_, Left error') <- M.toList files] + codes :: [(FilePath, Code)] + codes = [(path, code') | (path, Right code') <- M.toList files] + pyImportPath :: T.Text + pyImportPath = toImportPath $ modulePath boundM + defCode :: Code + defCode = [qq|from $pyImportPath import *|] + tM = test testPython + tT' typeDecls = tM $ makeDummySource $ Module typeDecls Nothing + tT typeDecl = tT' [typeDecl] + tR source excType = test (`testRaisePython` excType) source + tR'' typeDecls = tR $ makeDummySource $ Module typeDecls Nothing + tR' typeDecl = tR'' [typeDecl] + + describe "compilePackage" $ do + it "returns a Map of file paths and their contents to generate" $ do + let (Source pkg _) = makeDummySource $ Module [] Nothing + files = compilePackage pkg + M.keysSet files `shouldBe` + [ "foo" "__init__.py" + , "foo" "bar" "__init__.py" + , "qux" "__init__.py" + , "setup.py" + ] + it "creates an emtpy Python package directory if necessary" $ do + let (Source pkg _) = makeDummySource' ["test"] $ Module [] Nothing + files = compilePackage pkg + M.keysSet files `shouldBe` + [ "test" "__init__.py" + , "test" "foo" "__init__.py" + , "test" "foo" "bar" "__init__.py" + , "test" "qux" "__init__.py" + , "setup.py" + ] + specify "setup.py" $ do + let setupPyFields = [ ("--name", "TestPackage") + , ("--version", "0.1.0") + , ("--version", "0.1.0") + , ("--provides", "foo\nfoo.bar\nqux") + , ("--requires", "nirum") + ] :: [(String, T.Text)] + source = makeDummySource $ Module [] Nothing + testRunner cwd' _ _ = + {-- <- remove '{' to print debug log + do + let spath = case cwd' of + Just c -> c "setup.py" + Nothing -> "setup.py" + contents <- TI.readFile spath + TI.putStrLn "=========== setup.py ===========" + TI.putStrLn contents + TI.putStrLn "=========== /setup.py ==========" + -- --} + forM_ setupPyFields $ \(option, expected) -> do + out <- runPython' cwd' ["setup.py", option] "" + out `shouldSatisfy` isJust + let Just result = out + T.strip (T.pack result) `shouldBe` expected + test testRunner source T.empty + specify "boxed type" $ do + let decl = TypeDeclaration "float-box" (BoxedType "float64") + Nothing empty + tT decl "isinstance(FloatBox, type)" + tT decl "FloatBox(3.14).value == 3.14" + tT decl "FloatBox(3.14) == FloatBox(3.14)" + tT decl "FloatBox(3.14) != FloatBox(1.0)" + tT decl [q|{FloatBox(3.14), FloatBox(3.14), FloatBox(1.0)} == + {FloatBox(3.14), FloatBox(1.0)}|] + tT decl "FloatBox(3.14).__nirum_serialize__() == 3.14" + tT decl "FloatBox.__nirum_deserialize__(3.14) == FloatBox(3.14)" + tT decl "FloatBox.__nirum_deserialize__(3.14) == FloatBox(3.14)" + tR' decl "TypeError" "FloatBox.__nirum_deserialize__('a')" + tR' decl "TypeError" "FloatBox('a')" + let decls = [ Import ["foo", "bar"] "path-box" + , TypeDeclaration "imported-type-box" + (BoxedType "path-box") Nothing + empty + ] + tT' decls "isinstance(ImportedTypeBox, type)" + tT' decls [q|ImportedTypeBox(PathBox('/path/string')).value.value == + '/path/string'|] + tT' decls [q|ImportedTypeBox(PathBox('/path/string')) == + ImportedTypeBox(PathBox('/path/string'))|] + tT' decls [q|ImportedTypeBox(PathBox('/path/string')) != + ImportedTypeBox(PathBox('/other/path'))|] + tT' decls [q|{ImportedTypeBox(PathBox('/path/string')), + ImportedTypeBox(PathBox('/path/string')), + ImportedTypeBox(PathBox('/other/path')), + ImportedTypeBox(PathBox('/path/string')), + ImportedTypeBox(PathBox('/other/path'))} == + {ImportedTypeBox(PathBox('/path/string')), + ImportedTypeBox(PathBox('/other/path'))}|] + tT' decls [q| + ImportedTypeBox(PathBox('/path/string')).__nirum_serialize__() + == '/path/string' + |] + tT' decls [q| + ImportedTypeBox.__nirum_deserialize__('/path/string') == + ImportedTypeBox(PathBox('/path/string')) + |] + tR'' decls "TypeError" "ImportedTypeBox.__nirum_deserialize__(123)" + tR'' decls "TypeError" "ImportedTypeBox(123)" + let boxedAlias = [ Import ["qux"] "path" + , TypeDeclaration "way" + (BoxedType "path") Nothing + empty + ] + tT' boxedAlias "Way('.').value == '.'" + tT' boxedAlias "Way(Path('.')).value == '.'" + tT' boxedAlias "Way.__nirum_deserialize__('.') == Way('.')" + tT' boxedAlias "Way('.').__nirum_serialize__() == '.'" + let aliasBoxed = [ Import ["qux"] "name" + , TypeDeclaration "irum" (Alias "name") Nothing + empty + ] + tT' aliasBoxed "Name('khj') == Irum('khj')" + tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Irum('khj')" + tT' aliasBoxed "Irum('khj').__nirum_serialize__() == 'khj'" + tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Name('khj')" + tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Irum('khj')" + specify "enum type" $ do + let members = [ "male" + , EnumMember (Name "female" "yeoseong") Nothing + ] :: DeclarationSet EnumMember + decl = TypeDeclaration "gender" (EnumType members) Nothing + empty + tT decl "type(Gender) is enum.EnumMeta" + tT decl "set(Gender) == {Gender.male, Gender.female}" + tT decl "Gender.male.value == 'male'" + tT decl "Gender.female.value == 'yeoseong'" + tT decl "Gender.__nirum_deserialize__('male') == Gender.male" + tT decl "Gender.__nirum_deserialize__('yeoseong') == Gender.female" + tR' decl "ValueError" "Gender.__nirum_deserialize__('namja')" + tT decl "Gender.male.__nirum_serialize__() == 'male'" + tT decl "Gender.female.__nirum_serialize__() == 'yeoseong'" + let members' = [ "soryu-asuka-langley" + , "ayanami-rei" + , "ikari-shinji" + , "katsuragi-misato" + , "nagisa-kaworu" + ] :: DeclarationSet EnumMember + decl' = TypeDeclaration "eva-char" (EnumType members') Nothing + empty + tT decl' "type(EvaChar) is enum.EnumMeta" + tT decl' "set(EvaChar) == {EvaChar.soryu_asuka_langley, \ + \ EvaChar.ayanami_rei, \ + \ EvaChar.ikari_shinji, \ + \ EvaChar.katsuragi_misato, \ + \ EvaChar.nagisa_kaworu}" + tT decl' "EvaChar.soryu_asuka_langley.value=='soryu_asuka_langley'" + tT decl' "EvaChar.soryu_asuka_langley.__nirum_serialize__() == \ + \ 'soryu_asuka_langley'" + tT decl' "EvaChar.__nirum_deserialize__('soryu_asuka_langley') == \ + \ EvaChar.soryu_asuka_langley" + tT decl' "EvaChar.__nirum_deserialize__('soryu-asuka-langley') == \ + \ EvaChar.soryu_asuka_langley" -- to be robust + specify "record type" $ do + let fields = [ Field (Name "left" "x") "bigint" Nothing + , Field "top" "bigint" Nothing + ] + payload = "{'_type': 'point', 'x': 3, 'top': 14}" :: T.Text + decl = TypeDeclaration "point" (RecordType fields) Nothing + empty + tT decl "isinstance(Point, type)" + tT decl "Point(left=3, top=14).left == 3" + tT decl "Point(left=3, top=14).top == 14" + tT decl "Point(left=3, top=14) == Point(left=3, top=14)" + tT decl "Point(left=3, top=14) != Point(left=3, top=15)" + tT decl "Point(left=3, top=14) != Point(left=4, top=14)" + tT decl "Point(left=3, top=14) != Point(left=4, top=15)" + tT decl "Point(left=3, top=14) != 'foo'" + tT decl [q|Point(left=3, top=14).__nirum_serialize__() == + {'_type': 'point', 'x': 3, 'top': 14}|] + tT decl [qq|Point.__nirum_deserialize__($payload) == + Point(left=3, top=14)|] + tR' decl "ValueError" + "Point.__nirum_deserialize__({'x': 3, 'top': 14})" + tR' decl "ValueError" + "Point.__nirum_deserialize__({'_type': 'foo'})" + tR' decl "TypeError" "Point(left=1, top='a')" + tR' decl "TypeError" "Point(left='a', top=1)" + tR' decl "TypeError" "Point(left='a', top='b')" + let fields' = [ Field "left" "int-box" Nothing + , Field "top" "int-box" Nothing + ] + decls = [ Import ["foo", "bar"] "int-box" + , TypeDeclaration "point" (RecordType fields') Nothing + empty + ] + payload' = "{'_type': 'point', 'left': 3, 'top': 14}" :: T.Text + tT' decls "isinstance(Point, type)" + tT' decls "Point(left=IntBox(3), top=IntBox(14)).left == IntBox(3)" + tT' decls "Point(left=IntBox(3), top=IntBox(14)).top == IntBox(14)" + tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) == + Point(left=IntBox(3), top=IntBox(14))|] + tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) != + Point(left=IntBox(3), top=IntBox(15))|] + tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) != + Point(left=IntBox(4), top=IntBox(14))|] + tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) != + Point(left=IntBox(4), top=IntBox(15))|] + tT' decls "Point(left=IntBox(3), top=IntBox(14)) != 'foo'" + tT' decls [q|Point(left=IntBox(3), + top=IntBox(14)).__nirum_serialize__() == + {'_type': 'point', 'left': 3, 'top': 14}|] + tT' decls [qq|Point.__nirum_deserialize__($payload') == + Point(left=IntBox(3), top=IntBox(14))|] + tR'' decls "ValueError" + "Point.__nirum_deserialize__({'left': 3, 'top': 14})" + tR'' decls "ValueError" + "Point.__nirum_deserialize__({'_type': 'foo'})" + tR'' decls "TypeError" "Point(left=IntBox(1), top='a')" + tR'' decls "TypeError" "Point(left=IntBox(1), top=2)" + let fields'' = [ Field "xy" "point" Nothing + , Field "z" "int64" Nothing + ] + decls' = [ Import ["foo", "bar"] "point" + , TypeDeclaration "point3d" + (RecordType fields'') + Nothing + empty + ] + tT' decls' "isinstance(Point3d, type)" + tT' decls' [q|Point3d(xy=Point(x=1, y=2), z=3).xy == + Point(x=1, y=2)|] + tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).xy.x == 1" + tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).xy.y == 2" + tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).z == 3" + tT' decls' [q|Point3d(xy=Point(x=1, y=2), z=3).__nirum_serialize__() + == {'_type': 'point3d', + 'xy': {'_type': 'point', 'x': 1, 'y': 2}, + 'z': 3}|] + tT' decls' [q|Point3d.__nirum_deserialize__({ + '_type': 'point3d', + 'xy': {'_type': 'point', 'x': 1, 'y': 2}, + 'z': 3 + }) == Point3d(xy=Point(x=1, y=2), z=3)|] + specify "record type with one field" $ do + let fields = [ Field "length" "bigint" Nothing ] + payload = "{'_type': 'line', 'length': 3}" :: T.Text + decl = TypeDeclaration "line" (RecordType fields) Nothing empty + tT decl "isinstance(Line, type)" + tT decl "Line(length=10).length == 10" + tT decl "Line.__slots__ == ('length', )" + tT decl [qq|Line(length=3).__nirum_serialize__() == $payload|] + specify "union type" $ do + let wasternNameTag = + Tag "western-name" [ Field "first-name" "text" Nothing + , Field "middle-name" "text" Nothing + , Field "last-name" "text" Nothing + ] Nothing + eastAsianNameTag = + Tag "east-asian-name" [ Field "family-name" "text" Nothing + , Field "given-name" "text" Nothing + ] Nothing + cultureAgnosticNameTag = + Tag "culture-agnostic-name" + [ Field "fullname" "text" Nothing ] + Nothing + tags = [ wasternNameTag + , eastAsianNameTag + , cultureAgnosticNameTag + ] + decl = TypeDeclaration "name" (UnionType tags) Nothing empty + tT decl "isinstance(Name, type)" + tT decl "Name.Tag.western_name.value == 'western_name'" + tT decl "Name.Tag.east_asian_name.value == 'east_asian_name'" + tT decl [q|Name.Tag.culture_agnostic_name.value == + 'culture_agnostic_name'|] + tT decl "isinstance(WesternName, type)" + tT decl "issubclass(WesternName, Name)" + tR' decl "NotImplementedError" "Name()" + tT decl [q|WesternName(first_name='foo', middle_name='bar', + last_name='baz').first_name == 'foo'|] + tT decl [q|WesternName(first_name='foo', middle_name='bar', + last_name='baz').middle_name == 'bar'|] + tT decl [q|WesternName(first_name='foo', middle_name='bar', + last_name='baz').last_name == 'baz'|] + tR' decl "TypeError" [q|WesternName(first_name=1,middle_name='bar', + last_name='baz')|] + tR' decl "TypeError" [q|WesternName(first_name='foo', + middle_name=1, + last_name='baz')|] + tR' decl "TypeError" [q|WesternName(first_name='foo', + middle_name='bar', + last_name=1)|] + tT decl [q|WesternName(first_name='foo', middle_name='bar', + last_name='baz') == + WesternName(first_name='foo', middle_name='bar', + last_name='baz') + |] + tT decl [q|WesternName(first_name='wrong', + middle_name='bar', last_name='baz') != + WesternName(first_name='foo', middle_name='bar', + last_name='baz') + |] + tT decl [q|WesternName(first_name='foo', middle_name='wrong', + last_name='baz') != + WesternName(first_name='foo', middle_name='bar', + last_name='baz') + |] + tT decl [q|WesternName(first_name='foo', middle_name='bar', + last_name='wrong') != + WesternName(first_name='foo', middle_name='bar', + last_name='baz') + |] + tT decl [q|WesternName(first_name='wrong', middle_name='wrong', + last_name='wrong') != + WesternName(first_name='foo', middle_name='bar', + last_name='baz')|] + tT decl "isinstance(EastAsianName, type)" + tT decl "issubclass(EastAsianName, Name)" + tT decl [q|EastAsianName(family_name='foo', + given_name='baz').family_name == 'foo'|] + tT decl [q|EastAsianName(family_name='foo', + given_name='baz').given_name == 'baz'|] + tT decl [q|EastAsianName(family_name='foo', given_name='baz') == + EastAsianName(family_name='foo', given_name='baz')|] + tT decl [q|EastAsianName(family_name='foo', + given_name='wrong') != + EastAsianName(family_name='foo', given_name='baz')|] + tT decl [q|EastAsianName(family_name='wrong', given_name='baz') != + EastAsianName(family_name='foo', given_name='baz')|] + tT decl [q|EastAsianName(family_name='wrong', + given_name='wrong') != + EastAsianName(family_name='foo', given_name='baz')|] + tR' + decl + "TypeError" + "EastAsianName(family_name=1, given_name='baz')" + tR' + decl + "TypeError" + "EastAsianName(family_name='foo', given_name=2)" + tT decl "isinstance(CultureAgnosticName, type)" + tT decl "issubclass(CultureAgnosticName, Name)" + tT + decl + "CultureAgnosticName(fullname='foobar').fullname == 'foobar'" + tT decl [q|CultureAgnosticName(fullname='foobar') == + CultureAgnosticName(fullname='foobar')|] + tT decl [q|CultureAgnosticName(fullname='wrong') != + CultureAgnosticName(fullname='foobar')|] + tR' decl "TypeError" "CultureAgnosticName(fullname=1)" + specify "union type with one tag" $ do + let cultureAgnosticNameTag = + Tag "pop" + [ Field "country" "text" Nothing ] + Nothing + tags = [cultureAgnosticNameTag] + decl = TypeDeclaration "music" (UnionType tags) Nothing empty + tT decl "Pop(country='KR').country == 'KR'" + tT decl "Pop(country='KR') == Pop(country='KR')" + tT decl "Pop(country='US') != Pop(country='KR')" + tR' decl "TypeError" "Pop(country=1)" + tT decl "Pop.__slots__ == ('country', )" + specify "union type with behind names" $ do + let pop = + Tag (Name "pop" "popular_music") + [ Field "country" "text" Nothing ] + Nothing + tags = [pop] + decl = TypeDeclaration "music" (UnionType tags) Nothing empty + tT decl "Pop(country='KR').__nirum_tag__.value == 'popular_music'" + specify "service" $ do + let null' = ServiceDeclaration "null-service" (Service []) + Nothing empty + pingService = Service [Method "ping" + [Parameter "nonce" "text" Nothing] + "bool" + Nothing + Nothing + empty] + ping' = ServiceDeclaration "ping-service" pingService + Nothing empty + tT null' "issubclass(NullService, __import__('nirum').rpc.Service)" + tT ping' "issubclass(PingService, __import__('nirum').rpc.Service)" + tT ping' "set(PingService.ping.__annotations__) == \ + \ {'nonce', 'return'}" + tT ping' "PingService.ping.__annotations__['nonce'] is str" + tT ping' "PingService.ping.__annotations__['return'] is bool" + tR' ping' "NotImplementedError" "PingService().ping('nonce')" + tR' ping' "NotImplementedError" "PingService().ping(nonce='nonce')" + tR' ping' "TypeError" "PingService().ping(wrongkwd='a')" + + describe "InstallRequires" $ do + let req = InstallRequires [] [] + req2 = req { dependencies = ["six"] } + req3 = req { optionalDependencies = [((3, 4), ["enum34"])] } + specify "addDependency" $ do + addDependency req "six" `shouldBe` req2 + addDependency req2 "six" `shouldBe` req2 + addDependency req "nirum" `shouldBe` + req { dependencies = ["nirum"] } + addDependency req2 "nirum" `shouldBe` + req2 { dependencies = ["nirum", "six"] } + specify "addOptionalDependency" $ do + addOptionalDependency req (3, 4) "enum34" `shouldBe` req3 + addOptionalDependency req3 (3, 4) "enum34" `shouldBe` req3 + addOptionalDependency req (3, 4) "ipaddress" `shouldBe` + req { optionalDependencies = [((3, 4), ["ipaddress"])] } + addOptionalDependency req3 (3, 4) "ipaddress" `shouldBe` + req { optionalDependencies = [ ((3, 4), ["enum34", "ipaddress"]) + ] + } + addOptionalDependency req (3, 5) "typing" `shouldBe` + req { optionalDependencies = [((3, 5), ["typing"])] } + addOptionalDependency req3 (3, 5) "typing" `shouldBe` + req3 { optionalDependencies = [ ((3, 4), ["enum34"]) + , ((3, 5), ["typing"]) + ] + } + specify "unionInstallRequires" $ do + (req `unionInstallRequires` req) `shouldBe` req + (req `unionInstallRequires` req2) `shouldBe` req2 + (req2 `unionInstallRequires` req) `shouldBe` req2 + (req `unionInstallRequires` req3) `shouldBe` req3 + (req3 `unionInstallRequires` req) `shouldBe` req3 + let req4 = req3 { dependencies = ["six"] } + (req2 `unionInstallRequires` req3) `shouldBe` req4 + (req3 `unionInstallRequires` req2) `shouldBe` req4 + let req5 = req { dependencies = ["nirum"] + , optionalDependencies = [((3, 4), ["ipaddress"])] + } + req6 = addOptionalDependency (addDependency req4 "nirum") + (3, 4) "ipaddress" + (req4 `unionInstallRequires` req5) `shouldBe` req6 + (req5 `unionInstallRequires` req4) `shouldBe` req6 + +{-# ANN module ("HLint: ignore Functor law" :: String) #-} +{-# ANN module ("HLint: ignore Monad law, left identity" :: String) #-} +{-# ANN module ("HLint: ignore Monad law, right identity" :: String) #-} +{-# ANN module ("HLint: ignore Use >=>" :: String) #-} diff --git a/test/Nirum/VersionSpec.hs b/test/Nirum/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/VersionSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Nirum.VersionSpec where + +import Data.Text (unpack) +import qualified Data.SemVer as SV +import Test.Hspec.Meta + +import Nirum.Version (version, versionString, versionText) + +spec :: Spec +spec = do + describe "version" $ do + it "must not error" $ + SV.toText version `shouldBe` versionText + -- assertion is meaningless; it's just for testing whether + -- `version` is evaluated without error + it "is development version yet" $ + version `shouldSatisfy` SV.isDevelopment + it "is the proper version" $ + -- is it a necessary test? + version `shouldBe` SV.version 0 1 0 [] [] + describe "versionText" $ do + it "is equivalent to version" $ + versionText `shouldBe` SV.toText version + it "is equivalent to versionString" $ + unpack versionText `shouldBe` versionString + describe "versionString" $ + it "is equivalent to version" $ + versionString `shouldBe` SV.toString version diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}