angle (empty) → 0.8.1.0
raw patch · 32 files changed
+7157/−0 lines, 32 filesdep +QuickCheckdep +angledep +basesetup-changed
Dependencies added: QuickCheck, angle, base, containers, criterion, directory, filepath, haskeline, mtl, process, split, tasty, tasty-quickcheck, transformers, transformers-compat
Files
- LICENSE +674/−0
- Setup.hs +2/−0
- angle-commandline/Angle/Interpreter.hs +122/−0
- angle-commandline/Angle/Options.hs +132/−0
- angle-commandline/Angle/REPL.hs +164/−0
- angle-commandline/Main.hs +37/−0
- angle.cabal +138/−0
- benchmarks/operations.hs +53/−0
- benchmarks/parsing.hs +18/−0
- benchmarks/scanning.hs +30/−0
- src/Angle/Exec/Builtins.hs +462/−0
- src/Angle/Exec/Error.hs +740/−0
- src/Angle/Exec/Exec.hs +563/−0
- src/Angle/Exec/Operations.hs +319/−0
- src/Angle/Exec/Scope.hs +247/−0
- src/Angle/Exec/Types.hs +37/−0
- src/Angle/Exec/Types/Internal.hs +272/−0
- src/Angle/Parse/Helpers.hs +175/−0
- src/Angle/Parse/Parser.hs +17/−0
- src/Angle/Parse/Parser/Internal.hs +601/−0
- src/Angle/Parse/Token.hs +331/−0
- src/Angle/Scanner.hs +253/−0
- src/Angle/Types/Lang.hs +599/−0
- src/Angle/Types/Scope.hs +244/−0
- tests/Test/Angle/Exec/Exec.hs +270/−0
- tests/Test/Angle/Exec/Operations.hs +28/−0
- tests/Test/Angle/Exec/Types.hs +31/−0
- tests/Test/Angle/Parse/Parser.hs +131/−0
- tests/Test/Angle/Parse/Token.hs +56/−0
- tests/Test/Angle/Types/Scope.hs +17/−0
- tests/TestHelper.hs +357/−0
- tests/TestSuite.hs +37/−0
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ angle-commandline/Angle/Interpreter.hs view
@@ -0,0 +1,122 @@+{-|+Module : Angle.Interpreter+Description : File runner for the Angle programming language.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines the file runner for use with the Angle programming language.+-}+module Angle.Interpreter (runInterpreter) where++import Control.Monad+import Control.Monad.Reader+import System.Directory (canonicalizePath)+import System.IO.Error+import System.Exit++import Angle.Options+import Angle.Exec.Builtins+import Angle.Exec.Error+import Angle.Exec.Exec+import Angle.Exec.Types+import Angle.Parse.Parser+import Angle.Scanner+import Angle.Types.Lang (Stmt)+++runInterpreter :: Options -> IO ()+runInterpreter opts = do+ let Options { optFiles = files+ , optCode = code+ } = opts++ runWithOptions opts $ runFiles files+ runWithOptions opts $ runCodes code++++runFiles :: [FilePath] -> OptionEnv ()+runFiles = mapM_ runFile+++runFile :: FilePath -> OptionEnv ()+runFile fp = do+ source' <- liftIO $ tryIOError $ readFile fp+ case source' of+ Left e -> handleNoFile fp e+ Right source -> runLex (Just fp) source+ where+ -- runLex source =+ -- case evalParse source program of+ -- Left err -> handleSyntax (Just fp) err abort+ -- Right toExec -> executeProg toExec+ -- executeProg toExec = do+ -- res <- runExecIOEnv initialEnvMain (execStmt toExec)+ -- case res of+ -- Left err -> handleRuntime (Just fp) err abort+ -- Right _ -> return ()+++runLex :: Maybe FilePath -> String -> OptionEnv ()+runLex fp source =+ case evalParse source program of+ Left err -> handleSyntax fp err+ Right toExec -> executeProg fp source toExec+++executeProg :: Maybe FilePath -> String -> Stmt -> OptionEnv ()+executeProg fp source toExec = do+ paths <- liftM optSearchPath ask+ currPath <- case fp of+ Nothing -> return Nothing+ Just pth -> liftM Just $ liftIO $ canonicalizePath pth+ let execEnv = initialEnvMain { sourceText = source+ , angleLibPath = paths+ , currentFile = currPath+ }+ res <- liftIO $ runExecIOEnv execEnv (execStmt toExec)+ case res of+ Left err -> handleRuntime fp err+ Right _ -> return ()+++runCodes :: [String] -> OptionEnv ()+runCodes = mapM_ runCode+++runCode :: String -> OptionEnv ()+runCode = runLex Nothing+++handleSyntax :: Maybe FilePath -> ParseError -> OptionEnv ()+handleSyntax = handleErr "Syntax error" 100+++handleRuntime :: Maybe FilePath -> AngleError -> OptionEnv ()+handleRuntime = handleErr "Runtime error" 101++++fileError :: Maybe FilePath -> String+fileError fp = case fp of+ (Just f) -> " in file " ++ f+ Nothing -> ""+++handleErr :: (Show e) => String -> Int -> Maybe FilePath -> e -> OptionEnv ()+handleErr errMsgStart errCode fp err = do+ abort <- liftM optAbort ask+ liftIO $ putStrLn (errMsgStart ++ fileError fp) >> print err+ liftIO $ when abort $ exitWith $ ExitFailure errCode+++handleNoFile :: FilePath -> IOError -> OptionEnv ()+handleNoFile fp e | isDoesNotExistError e = handleNoFile'+ | otherwise = liftIO $ ioError e+ where+ handleNoFile' = do+ abort <- liftM optAbort ask+ liftIO $ putStrLn $ "No such file: " ++ fp+ liftIO $ when abort $ exitWith $ ExitFailure 102
+ angle-commandline/Angle/Options.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-|+Module : Angle.Options+Description : Options for Angle executable.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines the 'Options' type for use in other modules that+provide for the angle command-line software.+-}+module Angle.Options+ ( Options(..)+ , getOptions+ , OptionEnv+ , runWithOptions+ ) where++import Control.Applicative (Applicative)+import Control.Monad.Reader+import Data.List (foldl')+import Data.List.Split (splitOn)+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit (exitSuccess)+import System.IO (hPutStrLn, stderr)++import Paths_angle (version)+import Data.Version (showVersion)+++data Options = Options+ { optVerbose :: Bool+ , optFiles :: [FilePath]+ , optOutput :: Maybe FilePath+ , optInteractive :: Bool+ , optAbort :: Bool+ , optCode :: [String]+ , optNonOpts :: [String]+ , optSearchPath :: [FilePath]+ }+++newtype OptionEnv a = OptionEnv+ { runOptionEnv :: ReaderT Options IO a+ } deriving ( Functor, Applicative+ , Monad, MonadIO, MonadReader Options)+++runWithOptions :: Options -> OptionEnv a -> IO a+runWithOptions opts optEnv = runReaderT (runOptionEnv optEnv) opts+++defaultOptions :: Options+defaultOptions = Options { optVerbose = False+ , optFiles = []+ , optOutput = Nothing+ , optInteractive = False+ , optAbort = False+ , optCode = []+ , optNonOpts = []+ , optSearchPath = [ "~/.angle/lib"+ , "~/.angle/usr/lib"+ ]+ }+++options :: [ OptDescr (Options -> IO Options) ]+options =+ [ Option "f" ["file"]+ (ReqArg+ (\arg opt -> return opt { optFiles = optFiles opt ++ [arg] })+ "FILE")+ "Input file"+ , Option "c" ["program"]+ (ReqArg+ (\arg opt -> return opt { optCode = optCode opt ++ [arg] })+ "TEXT")+ "Line of code to be executed directly (multiple -c's allowed)"+ , Option "" ["path"]+ (ReqArg+ (\arg opt -> return opt { optSearchPath = splitOn ":" arg })+ "PATH(S)")+ ("Paths to use instead of the defaults."+ ++ " These paths are searched when performing include")+ , Option "i" ["interactive"]+ (NoArg+ (\opt -> return opt { optInteractive = True }))+ "Run Angle in interactive (REPL) mode"+ , Option "h" ["help"]+ (NoArg+ (\_ -> do+ hPutStrLn stderr (usageInfo usage options)+ exitSuccess))+ "Display help"+ , Option "V" ["version"]+ (NoArg+ (\_ -> do+ hPutStrLn stderr $ "angle " ++ showVersion version+ exitSuccess))+ "Display current program version"+ , Option "v" ["verbose"]+ (NoArg+ (\opt -> return opt { optVerbose = True }))+ "Display additional program output"+ , Option "" ["abort"]+ (NoArg+ (\opt -> return opt { optAbort = True }))+ "Abort on first file that fails to run"+ ]+++-- | Program usage header.+usage :: String+usage = "Usage: angle [OPTION...] [file]"+++getOptions :: IO Options+getOptions = do+ args <- getArgs+ (opts, nonOpts) <-+ case getOpt RequireOrder options args of+ (opt,nonOpt,[]) -> return (opt,nonOpt)+ (_,_,errs) -> ioError+ (userError (concat errs ++ usageInfo usage options))+ let (fileN, nOpts) = case nonOpts of+ (x:xs) -> ([x], xs)+ [] -> ([], [])+ foldl' (>>=) (return defaultOptions { optFiles = fileN, optNonOpts = nOpts }) opts+ -- foldl' (>>=) (return defaultOptions { optFiles = nonOpts }) opts+
+ angle-commandline/Angle/REPL.hs view
@@ -0,0 +1,164 @@+{-|+Module : Angle.REPL+Description : REPL for the Angle programming language.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines the REPL for use with the Angle programming language.+-}+module Angle.REPL (runInteractive) where++import Control.Monad+import Control.Monad.Except+import Control.Monad.State (put)+import Data.Either (lefts, rights)+import Data.List (elemIndices, isSuffixOf)+import System.Directory (canonicalizePath)+import System.IO (stdout, hFlush)++import System.Console.Haskeline++import Angle.Exec.Types+import Angle.Types.Lang+import Angle.Parse.Parser+import Angle.Exec.Exec+import Angle.Exec.Builtins++import Angle.Options+++instance MonadException ExecIO where+ controlIO f = join . liftIO $ f (RunIO pure)+++-- | When user is entering input over multiple lines, consolidate this+-- into a single statement.+collectLine :: String -> Int -> InputT ExecIO String+collectLine s multi =+ let newMulti = multi + incMultiBy s+ in if newMulti > 0+ then do+ nxt <- getInputLineWithInitial "> " (concat $ replicate newMulti " ", "")+ case nxt of+ Nothing -> collectLine s multi+ Just n -> liftM (s++) $ collectLine n newMulti+ else return s+ where incMultiBy :: String -> Int+ incMultiBy xs = count '{' xs - count '}' xs+++-- | Parse a line of user input and produce a text response.+runLine :: String -> ExecIO String+runLine s = do+ case evalParse s stmt of+ Left err -> pure $ show err+ Right res -> do+ toPrint <- (fmap Right $ execStmt res) `catchError` (\e -> pure (Left $ show e))+ pure $ case toPrint of+ Left s -> s+ Right r -> case r of+ (LitList xs) -> showList xs r+ (LitStr xs) -> showStr xs r+ _ -> showSyn r+ where showList xs toPrint = let fpart = LitList (take 10 xs)+ spart = LitList (reverse $ take 5 $ reverse xs)+ in if length xs > 100+ then init (showSyn fpart) ++ ", ..., " ++ tail (showSyn spart)+ else showSyn toPrint+ showStr xs toPrint = if length xs > 2000+ then let fpart = LitStr (take 1000 xs)+ spart = LitStr (reverse $ take 1000 $ reverse xs)+ in init (showSyn fpart) ++ "\n<LONG TEXT OMITTED>\n" ++ tail (showSyn spart)+ else showSyn toPrint+++count :: Eq a => a -> [a] -> Int+count x = length . elemIndices x+++printSyn :: (ShowSyn a) => a -> IO ()+printSyn = putStrLn . showSyn+++-- | Run interactive mode using the files as initial input.+interactiveWithFiles :: [FilePath] -> ExecIO ()+interactiveWithFiles fs = mapM_ getInteractiveFile fs >> interactiveMode++-- interactiveWithFiles fs = do+-- fileSources <- liftIO $ mapM readFile fs+-- let asStmts = map (`evalParse` program) fileSources+-- if not . null $ lefts asStmts+-- then liftIO $ mapM_ (putStrLn . ("failed to load file: " ++))+-- [x ++ "\n" ++ show r | (x,Left r) <- zip fs asStmts]+-- else do+-- let overStmt = MultiStmt (rights asStmts)+-- -- execStmt overStmt+-- toPrint <- execStmt overStmt+-- `catchError` (\e -> liftIO (print e) >> throwError e)+-- liftIO $ printSyn toPrint+-- -- runExecIOEnv initialEnvNotMain (execStmt overStmt)+-- interactiveMode+-- return ()+-- return ()++getInteractiveFile :: FilePath -> ExecIO ()+getInteractiveFile fp = do+ canPath <- liftIO $ canonicalizePath fp+ source <- liftIO $ readFile fp+ currEnv <- getEnv+ put currEnv { currentFile = Just canPath }+ let asStmt = evalParse source program+ case asStmt of+ Left err -> liftIO $ print err+ Right s -> do+ toPrint <- execStmt s `catchError` (\e -> liftIO (print e) >> throwError e)+ liftIO $ printSyn toPrint+-- withSource s =+-- case evalParse ('{':s++"}") stmt of+-- Left err -> liftIO (print err) >> interactiveMode+-- Right res -> do+-- toPrint <- execStmt res `catchError` (\e -> liftIO (print e) >> throwError e)+-- liftIO $ printSyn toPrint+-- interactiveMode+++-- | Runs a REPL using the Angle programming language.+interactiveMode :: ExecIO ()+interactiveMode = runInputT defaultSettings loop+ where loop :: InputT ExecIO ()+ loop = do+ userInput <- getInputLine "> "+ case userInput of+ Nothing -> pure ()+ Just "exit" -> pure ()+ Just input -> runInputLine input >> loop+ runInputLine l = do+ r <- collectLine l 0+ let norm = normalizeStmt r+ s <- lift $ runLine norm+ outputStrLn s+ normalizeStmt xs = let hasSemi = isSuffixOf ";" xs+ in if hasSemi then xs else if null xs then xs else xs ++ ";"+++prompt :: String -> IO String+prompt s = do+ putStr s+ hFlush stdout+ getLine+++-- | Run Angle in interactive mode.+runInteractive :: Options -> IO ()+runInteractive opts = do+ let Options { optFiles = files+ } = opts+ when (length files > 1)+ (putStrLn $ "Warning: Running interactive with multiple files, "+ ++ "this may go badly!")+ if not $ null files+ then runExecIOEnv initialEnvNotMain (interactiveWithFiles files)+ else runExecIOEnv initialEnvNotMain interactiveMode+ return ()
+ angle-commandline/Main.hs view
@@ -0,0 +1,37 @@+{-|+Module : Angle.Main+Description : Client executable for running angle.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Module defining main executable for running Angle programs both+interactively and non-interactively.+-}++module Main (main) where++import Control.Monad++import Angle.Options+import Angle.REPL (runInteractive)+import Angle.Interpreter (runInterpreter)+++main :: IO ()+main = do+ opts <- getOptions+ let Options { optVerbose = verbose+ , optFiles = files+ , optInteractive = interactive+ , optCode = code+ } = opts+ when verbose (putStrLn "Verbose not yet implemented")+ if interactive || (null files && null code)+ then runInteractive opts+ else runInterpreter opts+ return ()+++
+ angle.cabal view
@@ -0,0 +1,138 @@+-- Initial Angle.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name: angle+version: 0.8.1.0+synopsis: A small, general-purpose programming language.+license: GPL-3+license-file: LICENSE+author: Ben Moon+maintainer: guiltydolphin@gmail.com+copyright: Ben Moon 2015+category: Compilers/Interpreters+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10+description: An implementation of a small, weak and dynamically typed,+ interpreted, functional programming language.+source-repository head+ type: git+ location: git://github.com/GuiltyDolphin/angle.git+++flag test-properties+ default: True+ manual: True+++library+ exposed-modules: Angle.Parse.Parser+ , Angle.Parse.Parser.Internal+ , Angle.Parse.Helpers+ , Angle.Types.Lang+ , Angle.Types.Scope+ , Angle.Exec.Exec+ , Angle.Exec.Error+ , Angle.Parse.Token+ , Angle.Scanner+ , Angle.Exec.Operations+ , Angle.Exec.Builtins+ , Angle.Exec.Scope+ , Angle.Exec.Types+ , Angle.Exec.Types.Internal+ other-modules:+ other-extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances+ build-depends: base >=4.8 && <4.9+ , containers >=0.5 && <0.6+ , directory >= 1.2.1.0+ , filepath >= 1.3.0.2+ , mtl >=2.2.1 && <2.3+ , transformers >= 0.3.0.0+ , transformers-compat >= 0.3.3.3+ , process >= 1.2.0.0+ hs-source-dirs: src+ default-language: Haskell2010+ buildable: True+ ghc-options: -Wall -fno-warn-unused-do-bind+++executable angle+ main-is: Main.hs+ hs-source-dirs: angle-commandline+ other-modules: Angle.REPL+ , Angle.Options+ , Angle.Interpreter+ , Paths_angle+ default-language: Haskell2010+ build-depends: angle+ , base+ , containers >=0.5 && <0.6+ , directory >= 1.2.1.0+ , haskeline >= 0.7.2.1+ , mtl >=2.2.1 && <2.3+ , split >= 0.2.2+ , transformers >= 0.3.0.0+ , transformers-compat >= 0.3.3.3+ default-language: Haskell2010+ buildable: True+ ghc-options: -Wall -fno-warn-unused-do-bind+++test-suite properties+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ hs-source-dirs: tests+ other-modules: Test.Angle.Parse.Parser+ , Test.Angle.Parse.Token+ , TestHelper+ , Test.Angle.Types.Scope+ , Test.Angle.Exec.Operations+ , Test.Angle.Exec.Exec+ , Test.Angle.Exec.Types+ if !flag(test-properties)+ buildable: False+ else+ build-depends: base+ , angle+ , QuickCheck >= 2.7.6+ , transformers+ , transformers-compat+ , containers >=0.5 && <0.6+ , mtl >= 2.2.1+ , tasty >= 0.10.1.2+ , tasty-quickcheck >= 0.8.3.2+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans+ default-language: Haskell2010+++benchmark parsing+ type: exitcode-stdio-1.0+ main-is: parsing.hs+ hs-source-dirs: benchmarks+ build-depends: base+ , criterion+ , angle+ ghc-options: -O+ default-language: Haskell2010+++benchmark scanning+ type: exitcode-stdio-1.0+ main-is: scanning.hs+ hs-source-dirs: benchmarks+ build-depends: base+ , criterion+ , angle+ ghc-options: -O+ default-language: Haskell2010+++benchmark operations+ type: exitcode-stdio-1.0+ main-is: operations.hs+ hs-source-dirs: benchmarks+ build-depends: base+ , criterion+ , angle+ ghc-options: -O+ default-language: Haskell2010
+ benchmarks/operations.hs view
@@ -0,0 +1,53 @@+import Criterion.Main+import Criterion.Types++import Angle.Types.Lang+import Angle.Exec.Operations+import Angle.Exec.Types.Internal+++main :: IO ()+main = defaultMainWith config+ [ bgroup "addition"+ [ bench "list of 1..10" $! nfIO $! execSum [1..10]+ , bench "list of 1..100" $! nfIO $! execSum [1..100]+ -- , bench "list of 1..1000" $ whnf lexListInt [1..1000]+ ]+ , bgroup "logical and"+ [ bench "list of length 10" $! nfIO $! execAnd 10+ , bench "list of length 100" $! nfIO $! execAnd 100+ , bench "list of length 1000" $! nfIO $! execAnd 1000+ ]+ , bgroup "appending to list"+ [ bench "list of 1..10" $! whnf execAppend [1..10]+ , bench "list of 1..100" $! whnf execAppend [1..100]+ ]+ ]+ where+ config = defaultConfig { timeLimit = 1 }+++execSum xs = fromInt' $! addLit $! map LitInt xs+execAnd n = fromBool $! andLit $! map LitBool $! replicate n True ++ [False]+execAppend xs = fromList $! addLit $! LitList [] : map LitInt xs+++withRes :: ExecIO LangLit -> IO LangLit+withRes s = do+ (Right r) <- runExecIOBasic s+ return r++fromInt' :: ExecIO LangLit -> IO Int+fromInt' s = do+ (LitInt r) <- withRes s+ return r++fromBool :: ExecIO LangLit -> IO Bool+fromBool s = do+ (LitBool r) <- withRes s+ return r++fromList :: ExecIO LangLit -> IO [LangLit]+fromList s = do+ (LitList r) <- withRes s+ return r
+ benchmarks/parsing.hs view
@@ -0,0 +1,18 @@+import Angle.Parse.Parser.Internal++import Criterion.Main+import Criterion.Types++main :: IO ()+main = defaultMainWith config+ [ bgroup "literals"+ [ bench "list of 1..10" $ whnf parseListInt [1..10]+ , bench "list of 1..100" $ whnf parseListInt [1..100]+ --, bench "list of 1..1000" $ whnf parseListInt [1..1000]+ ]+ ]+ where+ config = defaultConfig { timeLimit = 1 }+++parseListInt xs = evalParse (show xs) langLit
+ benchmarks/scanning.hs view
@@ -0,0 +1,30 @@+import Control.Monad++import Criterion.Main+import Criterion.Types++import Angle.Scanner (scanChar, evalParse)+++main :: IO ()+main = defaultMainWith config+ [ bgroup "basic scanning"+ [ bgroup "single character"+ [ bench "stream length 1" $ whnf scanSingleLength 1+ , bench "stream length 100" $ whnf scanSingleLength 100+ , bench "stream length 1000" $ whnf scanSingleLength 1000+ ]+ , bgroup "full stream - single character"+ [ bench "stream length 10" $ whnf scanSingleLengthFull 10+ , bench "stream length 100" $ whnf scanSingleLengthFull 100+ , bench "stream length 1000" $ whnf scanSingleLengthFull 1000+ ]+ ]+ ]+ where+ config = defaultConfig { timeLimit = 1 }+++scanSingleLength n = evalParse (replicate n 'A') scanChar++scanSingleLengthFull n = evalParse (replicate n 'A') (replicateM n scanChar)
+ src/Angle/Exec/Builtins.hs view
@@ -0,0 +1,462 @@+{-|+Module : Angle.Exec.Builtins+Description : Builtin language functions and variables.+Copyright : (c) Ben Moon, 2015+License : GPL-3+Maintainer : guiltydolphin@gmail.com+Stability : experimental+Portability : POSIX++This module defines and exports functions and variables that can be used in Angle.++Minutae:++A function beginning with @builtin@ (e.g., @builtinPrint@) defines a builtin function accessible through the language by the section following @builtin@ (although the casing may differ). Thus @builtinPrint@ defines the builtin @print@ function.++The builtin @someFunction@ function, the @someFunction@ builtin, all refer to @someFunction@ that is callable from the language.+++Typically, builtin functions can act upon either a set amount+of arguments or a list of arguments, wherein the behaviour+is similar to the standard call, but produces a list of+results rather than a singleton.++For example, the @isNull@ builtin produces a single boolean+value when passed one argument, but produces a list of boolean+values when passed multiple arguments - as is common with+predicate functions in Angle.+-}+module Angle.Exec.Builtins+ ( isBuiltin+ , builtinPrint+ , builtinStr+ , builtinIndex+ , builtinLength+ , builtinAsType+ , builtinGetArgs+ , builtinInput+ , builtinIsNull+ , builtinOpen+ , builtinRead+ , builtinRound+ , builtinWrite+ , builtinClose+ , builtinShell+ , argsToString++ -- ** Assignment handling+ , handleBuiltinAssignFun+ , handleBuiltinAssignLit++ -- ** Default environments+ , startEnv+ , initialEnvNotMain+ , initialEnvMain+ ) where+++import Control.Monad+import Control.Monad.State+import System.Environment+import System.IO ( hFlush+ , hGetLine+ , hGetContents+ , hGetChar+ , hPutStr+ , hClose+ , stdout+ , stdin+ , stderr+ , openFile+ , IOMode(..))+import System.IO.Error ( tryIOError+ , isAlreadyExistsError+ , isDoesNotExistError+ , isAlreadyInUseError+ , isFullError+ , isEOFError+ , isIllegalOperation+ , isPermissionError)+import System.Process (readProcess)++import Angle.Exec.Error+import Angle.Exec.Types+import Angle.Types.Lang+import Angle.Types.Scope+++emptyArgs :: ArgSig+emptyArgs = ArgSig { stdArgs=[], catchAllArg=Nothing }+++builtinCallSig :: LangIdent -> Lambda+builtinCallSig name =+ Lambda+ { lambdaArgs = emptyArgs+ { catchAllArg = Just (CatchArg (LangIdent "x") Nothing) }+ , lambdaBody = body+ , lambdaScope = Nothing+ }+ where body = SingleStmt+ ( StmtExpr+ ( ExprFunCall name False+ [ ExprParamExpand+ ( LangIdent "x" )])) startRef+++builtinVar :: LangIdent -> (LangIdent, VarVal Lambda)+builtinVar name = (name, VarVal+ { varDef = Just $ builtinCallSig name+ , varBuiltin = True })+++builtinsVars :: BindEnv LangIdent Lambda+builtinsVars = bindEnvFromList $+ map (builtinVar . LangIdent) builtins+++builtinValue :: LangIdent -> LangLit -> (LangIdent, VarVal LangLit)+builtinValue name val = (name, VarVal+ { varDef = Just val+ , varBuiltin = True })+++builtinsValues :: BindEnv LangIdent LangLit+builtinsValues = bindEnvFromList $+ map (\(x,y) -> builtinValue (LangIdent x) y) builtinValues+++-- | Starting environment with builtin functions defined.+startEnv :: Env+startEnv = basicEnv { currentScope = startScope }+++startScope :: Scope+startScope = emptyScope+ { lambdaBindings = builtinsVars+ , valueBindings = builtinsValues+ }+++-- | Starting environment for programs not running as main.+initialEnvNotMain :: Env+initialEnvNotMain = startEnv { runAsMain = False }+++-- | Starting environment for programs running as main.+initialEnvMain :: Env+initialEnvMain = startEnv { runAsMain = True }+++-- | Builtin file handles+builtinHandles :: [(String, LangLit)]+builtinHandles = [ ("stdin", LitHandle stdin)+ , ("stdout", LitHandle stdout)+ , ("stderr", LitHandle stderr)+ ]+++builtinVariables :: [(String, LangLit)]+builtinVariables = [ ("as_constr", LitBool False)+ , ("main", LitBool False)+ ]+++-- | True if the identifier represents a builtin function.+isBuiltin :: LangIdent -> Bool+isBuiltin = (`elem`builtins) . getIdent+++-- | List of the builtin functions.+builtins :: [String]+builtins = [ "print", "str"+ , "index", "length"+ , "input", "eval"+ , "isNull"+ , "asType", "getArgs"+ , "read", "write", "open", "close"+ , "include"+ , "local", "nonlocal", "global"+ , "shell"+ , "round"]+++-- | List of builtin variables and their values.+builtinValues :: [(String, LangLit)]+builtinValues = builtinHandles ++ builtinVariables+++-- | Builtin @print@ function.+--+-- @print(..x)@: converts each element of @..x@ to a string+-- before printing the concatenated result followed by a newline to STDOUT.+builtinPrint :: [LangLit] -> ExecIO LangLit+builtinPrint xs = withIOError (putStrLn res) >> returnVal (LitStr res)+ where res = argsToString xs+++-- | Builtin @input@ function.+--+-- @input(..x)@: does the same as @builtinPrint@, but does+-- not automatically append a newline and returns the result+-- from STDIN.+builtinInput :: [LangLit] -> ExecIO LangLit+builtinInput xs = liftM LitStr (withIOError $ putStr res >> hFlush stdout >> getLine) >>= returnVal+ where res = argsToString xs+++-- | Convert arguments to a string.+argsToString :: [LangLit] -> String+argsToString = concatMap (\x -> case x of+ (LitStr s) -> s+ _ -> showSyn x)+++-- | Builtin @asType@ function.+--+-- @asType(typ, x)@ deduces the type of @typ@ and attempts to+-- cast @x@ to that type.+--+-- @asType(typ, ..x)@ produces a list of casted values.+builtinAsType :: [LangLit] -> ExecIO LangLit+builtinAsType [x] = return x+builtinAsType [x,y] = asType x y+builtinAsType (x:xs) = liftM LitList $ mapM (asType x) xs+builtinAsType _ = throwExecError $ callBuiltinErr "asType: invalid call"+++asType :: LangLit -> LangLit -> ExecIO LangLit+asType x y | typeOf x == typeOf y = return y+asType (LitStr _) (LitList xs)+ | all isLitChar xs = return . LitStr $ map (\(LitChar x) -> x) xs+ where isLitChar (LitChar _) = True+ isLitChar _ = False+asType (LitStr _) x = return . toLitStr $ x+asType (LitFloat _) (LitInt x) = return . LitFloat $ fromIntegral x+asType (LitFloat _) (LitStr y) = fromStr y LitFloat+asType (LitInt _) (LitStr y) = fromStr y LitInt+asType (LitList _) (LitStr xs) = return . LitList $ map LitChar xs+asType (LitBool _) (LitStr y) =+ case y of+ "true" -> return $ LitBool True+ "false" -> return $ LitBool False+ _ -> return LitNull+asType (LitList _) x@(LitRange _ (Just _) _) = iterToLit x+asType (LitList _) (LitRange _ Nothing _) = throwExecError infiniteRangeErr+asType x y = throwExecError $ typeCastErr (typeOf y) (typeOf x)+++fromStr :: (Read a) => String -> (a -> LangLit) -> ExecIO LangLit+fromStr s f = case reads s of+ [(r,"")] -> return $ f r+ _ -> throwExecError . readErr $ s+++-- | Builtin @length@ function.+--+-- @length(x:\@list)@ returns the number of elements in the list.+--+-- @length(x:\@range)@ returns the number of elements that would be+-- produced by the range if the range is finite, otherwise the+-- keyword @:infinite@.+builtinLength :: [LangLit] -> ExecIO LangLit+builtinLength [LitList xs] = return . LitInt $ length xs+builtinLength [x@(LitRange{})] | isInfiniteRange x = return $ LitKeyword $ LangIdent "infinite"+builtinLength [LitRange x (Just y) Nothing] = return . LitInt $ (fromEnumL y + 1) - fromEnumL x+builtinLength [LitRange x (Just y) (Just z)] = return .+ LitInt $ ceiling ((fromIntegral div1 / fromIntegral div2) :: Double)+ where+ div1 = (fromEnumL y + 1) - fromEnumL x+ div2 = fromEnumL z - fromEnumL x+builtinLength _ = throwExecError $ callBuiltinErr "length: invalid call"+++-- | Builtin @isNull@ function.+--+-- @isNull(x)@ returns @true@ if the passed value is the null literal.+--+-- @isNull(..x)@ returns a list of the above.+builtinIsNull :: [LangLit] -> ExecIO LangLit+builtinIsNull [x] = return . LitBool $ isNull x+builtinIsNull xs = return . LitList $ map (LitBool . isNull) xs+++-- | Builtin @str@ function.+--+-- @str(x)@ is the same as @asType("", x)@+builtinStr :: [LangLit] -> ExecIO LangLit+builtinStr [] = return $ LitStr ""+builtinStr xs | length xs > 1 = throwExecError $ wrongNumberOfArgumentsErr 1 (length xs)+ | otherwise = return $ toLitStr (head xs)+++-- | Builtin @index@ function.+--+-- @index(x:\@int, xs:\@list)@: retrieve element at index @x@ from @xs@+--+-- @index(x:\@int, y:\@int, xs:\@list)@: return a list of elements that lie between index @x@ and index @y@ of @xs@.+--+-- Negative indices are treated as working backwards from the+-- end of the list. With @-1@ being the last element.+builtinIndex :: [LangLit] -> ExecIO LangLit+builtinIndex [LitInt x,LitList xs]+ | x >= length xs = throwExecError $ indexOutOfBoundsErr x+ | x < 0 = return $ xs !! (length xs + x)+ | otherwise = return $ xs !! x+builtinIndex [x, LitStr s] = builtinIndex [x,LitList $ map LitChar s] >>= joinList+ where+ joinList l = builtinAsType [LitStr "", l]+builtinIndex [LitInt x,LitInt y,LitList xs]+ | x > length xs || y > length xs+ = throwExecError $ indexOutOfBoundsErr x+ | x < 0 = builtinIndex+ [LitInt (length xs + x), LitInt y, LitList xs]+ | y < 0 = builtinIndex+ [LitInt x, LitInt (length xs + y + 1), LitList xs]+ | otherwise+ = return . LitList $ splice x y xs+builtinIndex [x,y,LitStr s] = builtinIndex [x, y, LitList $ map LitChar s] >>= joinList+ where+ joinList l = builtinAsType [LitStr "", l]+builtinIndex _ = throwExecError $ callBuiltinErr "index: invalid call signature"+++splice :: Int -> Int -> [a] -> [a]+splice x y = take (y-x) . drop x+++toLitStr :: LangLit -> LangLit+toLitStr x@(LitStr _) = x+toLitStr (LitChar x) = LitStr [x]+toLitStr LitNull = LitStr ""+toLitStr x = LitStr $ showSyn x+++-- | Builtin @getArgs@ function.+--+-- @getArgs()@ returns the arguments passed to the program.+builtinGetArgs :: [LangLit] -> ExecIO LangLit+builtinGetArgs _ = liftM (LitList . map LitStr) $ withIOError getArgs+++-- | Builtin @open@ function.+--+-- @open(file, mode)@ returns a file handle for @file@ in @mode@.+--+-- Modes are as follows:+--+-- [<] read only mode+--+-- [>] write mode (clobbers)+--+-- [>>] append mode+--+-- [<>] read-write mode+builtinOpen :: [LangLit] -> ExecIO LangLit+builtinOpen [LitStr fn, LitStr "<"] = liftM LitHandle $ withIOError $ openFile fn ReadMode+builtinOpen [LitStr fn, LitStr ">"] = liftM LitHandle $ withIOError $ openFile fn WriteMode+builtinOpen [LitStr fn, LitStr ">>"] = liftM LitHandle $ withIOError $ openFile fn AppendMode+builtinOpen [LitStr fn, LitStr "<>"] = liftM LitHandle $ withIOError $ openFile fn ReadWriteMode+builtinOpen _ = throwExecError $ callBuiltinErr "open: invalid call signature"+++-- | Builtin @read@ function.+--+-- @read(handle)@ returns the unread part of the characters managed by @handle@.+--+-- @read(handle, integer)@ reads @integer@ lines from @handle@ and returns them as a new-line separated string.+--+-- @read(:char, handle)@ reads a single character from @handle@ and returns it as a character.+--+-- @read(:char, handle, integer)@ reads @integer@ characters from @handle@ and returns them in a string.+builtinRead :: [LangLit] -> ExecIO LangLit+builtinRead [LitHandle h] = liftM LitStr $ withIOError $ hGetContents h+builtinRead [LitHandle h, LitInt n] = liftM LitStr (withIOError $ liftM unlines $ replicateM n $ hGetLine h) >>= returnVal+builtinRead [LitKeyword (LangIdent "char"), LitHandle h] = liftM LitChar (withIOError $ hGetChar h) >>= returnVal+builtinRead [LitKeyword (LangIdent "char"), LitHandle h, LitInt n] = liftM LitStr (withIOError $ replicateM n $ hGetChar h) >>= returnVal+builtinRead (s@(LitStr _):xs) = builtinOpen [s, LitStr "<"] >>= (builtinRead . (:xs))+builtinRead _ = throwExecError $ callBuiltinErr "read: invalid call signature"+++-- | Builtin @write@ function.+--+-- @write(handle, string)@ writes @string@ to @handle@.+builtinWrite :: [LangLit] -> ExecIO LangLit+builtinWrite [LitHandle h, l@(LitStr s)] = withIOError (hPutStr h s) >> return l;+builtinWrite [h@(LitStr _), m@(LitStr _), l@(LitStr _)] = builtinOpen [h, m] >>= (builtinWrite . (:[l]))+builtinWrite _ = throwExecError $ callBuiltinErr "write: invalid call signature"+++-- | Builtin @close@ function.+--+-- @close(handle)@ closes @handle@ for reading and writing.+builtinClose :: [LangLit] -> ExecIO LangLit+builtinClose xs = mapM_ bClose xs >> return LitNull+ where+ bClose (LitHandle x) = withIOError $ hClose x+ bClose x = throwExecError $ typeUnexpectedErr (typeOf x) LTHandle+++-- | Builtin @shell@ function.+--+-- @shell(executable, arguments, stdin)@ runs the shell command+-- @executable@ with @args@ and @stdin@ and returns the result in a+-- string.+--+-- @shell(executable) = shell(executable, [], "")@+--+-- @shell(executable, arguments) = shell(executable, arguments, "")@+--+-- @shell(executable, stdin) = shell(executable, [], stdin)@+builtinShell :: [LangLit] -> ExecIO LangLit+builtinShell [p@(LitStr _)] = builtinShell [p, LitList [], LitStr ""]+builtinShell [p@(LitStr _), l@(LitList _)] = builtinShell [p, l, LitStr ""]+builtinShell [p@(LitStr _), sIn@(LitStr _)] = builtinShell [p, LitList [], sIn]+builtinShell [LitStr p, LitList args, LitStr sIn] = liftM LitStr $ withIOError $ readProcess p xs sIn+ where xs = map ((\(LitStr x) -> x) . toLitStr) args+builtinShell _ = throwExecError $ callBuiltinErr "shell: invalid call signature"+++-- | Builtin @round@ function.+--+-- @round(num)@ returns the closest integer to @num@ (prefers higher+-- numbers).+builtinRound :: [LangLit] -> ExecIO LangLit+builtinRound [x@(LitInt _)] = return x+builtinRound [LitFloat x] = return $ LitInt $ round x+builtinRound xs = liftM LitList $ mapM (builtinRound . (:[])) xs+builtinRound [x] = throwExecError $ typeNotValidErr x+++-- | Handler for assignments to builtin variables as literals.+handleBuiltinAssignLit :: LangIdent -> LangLit -> ExecIO a+handleBuiltinAssignLit n@(LangIdent "main") _ = throwExecError $ assignToBuiltinErr n (Just "assigned by execution program")+handleBuiltinAssignLit n _ = throwExecError $ assignToBuiltinErr n Nothing+++-- | Handler for assignments to builtin variables as functions.+handleBuiltinAssignFun :: LangIdent -> Lambda -> ExecIO a+handleBuiltinAssignFun n _ = throwExecError $ assignToBuiltinErr n Nothing+++handleIOError :: IOError -> ExecIO a+handleIOError e = throwExecError $ err e+ where+ err | isAlreadyExistsError e = alreadyExistsErr+ | isDoesNotExistError e = doesNotExistErr+ | isAlreadyInUseError e = alreadyInUseErr+ | isFullError e = deviceFullErr+ | isEOFError e = eofErr+ | isIllegalOperation e = illegalOperationErr+ | isPermissionError e = permissionErr+ | otherwise = error "Cannot handle user io exceptions"+++-- | Executes code in IO but attempts to embed the exception into+-- Angle's error system.+withIOError :: IO a -> ExecIO a+withIOError x = do+ r <- liftIO $ tryIOError x+ case r of+ Right res -> return res+ Left e -> handleIOError e
+ src/Angle/Exec/Error.hs view
@@ -0,0 +1,740 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-|+Module : Angle.Exec.Error+Description : Defines main error system used in Angle.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines functions for throwing, catching and handling errors that+occur in Angle.+-}+module Angle.Exec.Error+ (+ -- ** Type errors+ typeAnnWrongErr+ , typeConstrWrongReturnErr+ , typeExpectConstrErr+ , typeMismatchOpErr+ , typeNotValidErr+ , typeUnexpectedErr+ , typeCastErr++ -- ** Name errors+ , assignToBuiltinErr+ , nameNotDefinedErr+ , nameNotDefinedFunErr+ , nameNotDefinedLitErr++ -- ** Call errors+ , callBuiltinErr+ , malformedSignatureErr+ , wrongNumberOfArgumentsErr+++ -- ** Keyword errors+ , returnFromGlobalErr+++ -- ** Value errors+ , badRangeErr+ , indexOutOfBoundsErr+ , infiniteRangeErr+ , nonEnumErr+ , divideByZeroErr++ -- ** Control-flow+ , catchBreak+ , catchContinue+ , catchReturn+ , throwBreak+ , throwContinue+ , throwReturn++ -- ** User errors+ , userErr+ , errToKeyword+ , genErrKeyword++ -- ** IO errors+ , alreadyExistsErr+ , doesNotExistErr+ , alreadyInUseErr+ , deviceFullErr+ , eofErr+ , illegalOperationErr+ , permissionErr++ -- ** Syntax errors+ , syntaxErr+ , readErr++ -- ** Include errors+ , noSuchFileErr+ , badSyntaxErr++ -- ** Classes, base types and basic functions+ , AngleError+ , CanError(..)+ , CanErrorWithPos(..)+ , ExecError+ , throwError+ , throwImplementationErr+ , throwExecError+ ) where+++import Control.Monad.Except+import Data.Function (on)+import Data.Maybe (catMaybes)+import qualified System.IO.Error as IO++import Angle.Scanner+import Angle.Types.Lang+++-- | Instances are types that can throw Angle errors.+class (Monad m) => CanError (m :: * -> *) where+ throwAE :: AngleError -> m a+ catchAE :: m a -> (AngleError -> m a) -> m a+++instance CanError (Either AngleError) where+ throwAE = Left+ catchAE e f = case e of+ r@(Right _) -> r+ Left l -> f l+++-- | Instances are types that can throw Angle errors and provide+-- information about the position at which the error occurred.+class (CanError m) => CanErrorWithPos m where+ getErrorPos :: m SourceRef+ getErrorSource :: m String+ getErrorFile :: m (Maybe FilePath)+ -- FIXME: This should maybe just have the line numbers?+ -- Then could perhaps not need the separate position.+ getErrorCallStack :: m [(LangIdent, Stmt)]+ -- getErrorStmt :: m Stmt+ getErrorCall :: m (LangIdent, Stmt)+++-- | Errors that can be caught by the user via the try...catch+-- construct.+class KWError e where+ errToKeyword :: e -> LangIdent+ genErrKeyword :: e -> LangIdent+ -- ^ General keyword that can be used to handle multiple exceptions+ -- of this type.+++-- | General error structure.+data AngleError = ExecError+ { execErrSourceRef :: SourceRef+ , execErrErr :: ExecError+ , execErrSourceText :: String+ , execErrFile :: Maybe FilePath+ , execErrStack :: [(LangIdent, Stmt)]+ , execErrCall :: (LangIdent, Stmt)+ }+ | ImplementationError String+ deriving (Eq)+++implementationErr :: String -> AngleError+implementationErr = ImplementationError+++instance Show AngleError where+ show (ImplementationError x) = "Implementation error: " ++ x+ show (ExecError { execErrErr=ee+ , execErrSourceRef=SourceRef (start,_)+ , execErrSourceText=es+ , execErrFile=ef+ , execErrStack=eStack+ , execErrCall=eCall+ })+ = cEf ++ cEStack ++ cECall ++ cEk ++ cEe+ where+ cEf = case ef of+ Nothing -> ""+ Just f -> "In file: " ++ f ++ "\n"+ cECall = showCall eCall+ cEStack = concatMap showCall (reverse eStack)+ cEk = concat ["\n(:", showSyn $ errToKeyword ee, ")\n"]+ cEp = show start ++ "\n"+ cEe = show ee+ showCall (c,s) = r+ where+ r = " line " ++ ln ++ ", in " ++ f ++ "\n" ++ t+ t = " " ++ st ++ "\n"+ ln = show (stmtLine s + 1)+ f = showSyn c+ st = let (SingleStmt s' _) = s; tos = showSyn s' in if last tos == '\n' then init tos else tos+ stmtLine (SingleStmt _ (SourceRef (l,_))) = lineNo l+++instance KWError AngleError where+ errToKeyword (ImplementationError x) = error $ "(Attempt to handle) Implementation error: " ++ show x+ errToKeyword (ExecError { execErrErr = e }) = errToKeyword e++ genErrKeyword (ImplementationError x) = error $ "(Attempt to handle) Implementation error: " ++ show x+ genErrKeyword (ExecError { execErrErr = e }) = genErrKeyword e+++-- | Base for errors that occur during execution of code.+data ExecError = TypeError TypeError+ | NameError NameError+ | CallError CallError+ | ValueError ValueError+ | KeywordError KeywordError+ | EIOError EIOError+ | UserError LangIdent+ | SynError SynError+ | IncludeError IncludeError+ | ControlException ControlException+ deriving (Eq)+++-- | Expression produced an invalid type.+typeErr :: TypeError -> ExecError+typeErr = TypeError+++-- | Issue with identifier.+nameErr :: NameError -> ExecError+nameErr = NameError+++-- | Bad function call.+callErr :: CallError -> ExecError+callErr = CallError+++-- | Invalid literal.+valueErr :: ValueError -> ExecError+valueErr = ValueError+++-- | Misused keyword.+keywordErr :: KeywordError -> ExecError+keywordErr = KeywordError+++-- | IO Error.+eioErr :: EIOError -> ExecError+eioErr = EIOError+++-- | Custom exceptions.+userErr :: LangIdent -> ExecError+userErr = UserError+++-- | Syntax errors.+synErr :: SynError -> ExecError+synErr = SynError+++-- | Control flow+controlException :: ControlException -> ExecError+controlException = ControlException+++-- | Including files+includeErr :: IncludeError -> ExecError+includeErr = IncludeError+++instance Show ExecError where+ show (TypeError e) = "wrong type in expression: " ++ show e+ show (NameError v) = "name error: " ++ show v+ show (CallError x) = "call error: " ++ show x+ show (ValueError x) = "value error: " ++ show x+ show (EIOError e) = "io error: " ++ show e+ show (UserError (LangIdent x)) = "user error: " ++ x+ show (KeywordError x) = "keyword error: " ++ show x+ show (SynError e) = "syntax error:\n" ++ show e+ show (ControlException e) = "control: " ++ show e+ show (IncludeError e) = "include: " ++ show e+++instance KWError ExecError where+ errToKeyword (TypeError e) = errToKeyword e+ errToKeyword (NameError e) = errToKeyword e+ errToKeyword (CallError e) = errToKeyword e+ errToKeyword (ValueError e) = errToKeyword e+ errToKeyword (EIOError e) = errToKeyword e+ errToKeyword (UserError e) = e+ errToKeyword (KeywordError e) = errToKeyword e+ errToKeyword (SynError e) = errToKeyword e+ errToKeyword (ControlException e) = errToKeyword e+ errToKeyword (IncludeError e) = errToKeyword e++ genErrKeyword (TypeError e) = genErrKeyword e+ genErrKeyword (NameError e) = genErrKeyword e+ genErrKeyword (CallError e) = genErrKeyword e+ genErrKeyword (ValueError e) = genErrKeyword e+ genErrKeyword (EIOError e) = genErrKeyword e+ genErrKeyword (UserError{}) = LangIdent "user"+ genErrKeyword (KeywordError e) = genErrKeyword e+ genErrKeyword (SynError e) = genErrKeyword e+ genErrKeyword (ControlException e) = genErrKeyword e+ genErrKeyword (IncludeError e) = genErrKeyword e+++-- | Errors involving types.+data TypeError = TypeMismatch LangType LangType+ | TypeUnexpected LangType LangType+ | TypeNotValid LangType+ | TypeCast LangType LangType+ | TypeMismatchOp LangType LangType+ | TypeExpectConstr LangLit LangIdent+ | TypeConstrWrongReturn LangIdent LangType+ | TypeAnnWrong AnnType AnnType+ deriving (Eq)+++-- | Wrong type has been passed and required type is known.+typeUnexpectedErr :: LangType -> LangType -> ExecError+typeUnexpectedErr t1 = typeErr . TypeUnexpected t1+++-- | Wrong type has been passed and required type is not known.+typeNotValidErr :: LangLit -> ExecError+typeNotValidErr = typeErr . TypeNotValid . typeOf+++-- | Expecting types to be the same.+typeMismatchOpErr :: LangLit -> LangLit -> ExecError+typeMismatchOpErr x y = typeErr $ (TypeMismatchOp `on` typeOf) x y+++-- | Expecting value to satisfy given parameter constraint.+typeExpectConstrErr :: LangLit -> LangIdent -> ExecError+typeExpectConstrErr cls = typeErr . TypeExpectConstr cls+++-- | Function used as parameter constraint did not return boolean+-- value.+typeConstrWrongReturnErr :: LangIdent -> LangType -> ExecError+typeConstrWrongReturnErr cls = typeErr . TypeConstrWrongReturn cls+++-- | Value did not satisfy given annotation constraint.+typeAnnWrongErr :: AnnType -> AnnType -> ExecError+typeAnnWrongErr e = typeErr . TypeAnnWrong e+++-- | Cannot coerce one type to another+typeCastErr :: LangType -> LangType -> ExecError+typeCastErr t1 = typeErr . TypeCast t1+++instance Show TypeError where+ show (TypeMismatch l r) = "type mismatch: got (" ++ show l ++ ", " ++ show r ++ ") but both types should be the same"+ show (TypeUnexpected l r) = "unexpected type: " ++ show l ++ ", expecting: " ++ show r+ show (TypeNotValid l) = "type not valid : " ++ show l+ show (TypeCast l r) = "cannot convert " ++ show l ++ " to " ++ show r+ show (TypeMismatchOp l r) = "cannot perform operation on types " ++ show l ++ " and " ++ show r+ show (TypeExpectConstr v c) = "expecting value that satisfies function '" ++ showSyn c ++ "' but got: " ++ showSyn v+ show (TypeConstrWrongReturn c t) = "bad class: " ++ showSyn c ++ ", expecting return value of type bool, but got " ++ show t+ show (TypeAnnWrong t1 t2) = "bad type in function call, expecting " ++ show t1 ++ " but got " ++ show t2+++instance KWError TypeError where+ errToKeyword (TypeMismatch{}) = LangIdent "typeMismatch"+ errToKeyword (TypeUnexpected{}) = LangIdent "typeUnexpected"+ errToKeyword (TypeNotValid{}) = LangIdent "typeNotValid"+ errToKeyword (TypeCast{}) = LangIdent "typeCast"+ errToKeyword (TypeMismatchOp{}) = LangIdent "typeMismatchOp"+ errToKeyword (TypeExpectConstr{}) = LangIdent "typeExpectConstr"+ errToKeyword (TypeConstrWrongReturn{}) = LangIdent "typeConstrWrongReturn"+ errToKeyword (TypeAnnWrong{}) = LangIdent "typeAnnWrong"+ genErrKeyword _ = LangIdent "typeError"+++-- | Errors involving identifiers and names.+data NameError = NameNotDefined LangIdent+ | NameNotDefinedFun LangIdent+ | NameNotDefinedLit LangIdent+ | NameNotOp LangIdent+ | AssignToBuiltin LangIdent (Maybe String)+ deriving (Eq)+++-- | Given identifier has no definition.+nameNotDefinedErr :: LangIdent -> ExecError+nameNotDefinedErr = nameErr . NameNotDefined+++-- | Given identifier has no lambda assigned.+nameNotDefinedFunErr :: LangIdent -> ExecError+nameNotDefinedFunErr = nameErr . NameNotDefinedFun+++-- | Given identifier has no value assigned.+nameNotDefinedLitErr :: LangIdent -> ExecError+nameNotDefinedLitErr = nameErr . NameNotDefinedLit+++-- | Attempt to re-assign a builtin variable.+assignToBuiltinErr :: LangIdent -> Maybe String -> ExecError+assignToBuiltinErr name = nameErr . AssignToBuiltin name+++instance Show NameError where+ show (NameNotDefined (LangIdent name)) = "not in scope: " ++ name+ show (NameNotDefinedFun (LangIdent name)) = "not a valid function: " ++ name+ show (NameNotDefinedLit (LangIdent name)) = "no value assigned: " ++ name+ show (NameNotOp (LangIdent name)) = "not a valid operator: " ++ name+ show (AssignToBuiltin (LangIdent name) reason) = "cannot assign to builtin: " ++ name+ ++ maybe "" ("\n" ++) reason+++instance KWError NameError where+ errToKeyword (NameNotDefined{}) = LangIdent "nameNotDefined"+ errToKeyword (NameNotDefinedFun{}) = LangIdent "nameNotDefinedFun"+ errToKeyword (NameNotDefinedLit{}) = LangIdent "nameNotDefinedLit"+ errToKeyword (NameNotOp{}) = LangIdent "nameNotOp"+ errToKeyword (AssignToBuiltin{}) = LangIdent "assignToBuiltin"+ genErrKeyword _ = LangIdent "nameError"+++-- | Errors involving operator and function calls.+data CallError = WrongNumberOfArguments Int Int+ | BuiltIn String+ | MalformedSignature String+ deriving (Eq)+++-- | Attempted to pass an invalid number of arguments to a function.+wrongNumberOfArgumentsErr :: Int -> Int -> ExecError+wrongNumberOfArgumentsErr expect = callErr . WrongNumberOfArguments expect+++-- | Error when calling builtin.+callBuiltinErr :: String -> ExecError+callBuiltinErr = callErr . BuiltIn+++-- | Order of arguments not valid in scenario.+malformedSignatureErr :: String -> ExecError+malformedSignatureErr = callErr . MalformedSignature+++instance Show CallError where+ show (WrongNumberOfArguments x y) = "wrong number of arguments: expected " ++ show x ++ " but got " ++ show y+ show (BuiltIn x) = "builtin: " ++ x+ show (MalformedSignature x) = "malformed signature: " ++ x+++instance KWError CallError where+ errToKeyword (WrongNumberOfArguments{}) = LangIdent "wrongNumberOfArguments"+ errToKeyword (BuiltIn{}) = LangIdent "builtin"+ errToKeyword (MalformedSignature{}) = LangIdent "malformedSignature"+ genErrKeyword _ = LangIdent "callError"+++-- | Errors involving keywords.+data KeywordError = ReturnFromGlobal+ deriving (Eq)+++-- | Return keyword used in wrong place.+returnFromGlobalErr :: ExecError+returnFromGlobalErr = keywordErr ReturnFromGlobal+++instance Show KeywordError where+ show ReturnFromGlobal = "return from outermost scope"+++instance KWError KeywordError where+ errToKeyword ReturnFromGlobal = LangIdent "returnFromGlobal"+ genErrKeyword _ = LangIdent "keywordError"+++-- | Raise a 'ExecError' into an 'AngleError'.+throwExecError :: (CanErrorWithPos m, Monad m) => ExecError -> m a+throwExecError e = do+ errPosRef <- getErrorPos+ errSource <- getErrorSource+ errPath <- getErrorFile+ errStack <- getErrorCallStack+ errCall <- getErrorCall+ throwAE ExecError { execErrSourceRef = errPosRef+ , execErrSourceText = errSource+ , execErrErr = e+ , execErrFile = errPath+ , execErrStack = errStack+ , execErrCall = errCall+ }+++-- | Throw a fatal error caused by the internals of the implementation.+throwImplementationErr :: (CanError m) => String -> m a+throwImplementationErr = throwAE . implementationErr+++-- | Errors involving literals.+data ValueError = IndexOutOfBoundsError Int+ | BadRange LangType (Maybe LangType) (Maybe LangType)+ | InfiniteRange+ | NonEnum LangType+ | DivideByZero+ deriving (Eq)+++-- | Attempt to access a non-existant index of a list.+indexOutOfBoundsErr :: Int -> ExecError+indexOutOfBoundsErr = valueErr . IndexOutOfBoundsError+++-- | Types are not uniform in range.+badRangeErr :: LangType -> Maybe LangType -> Maybe LangType -> ExecError+badRangeErr t1 t2 = valueErr . BadRange t1 t2+++-- | Range is infinite.+infiniteRangeErr :: ExecError+infiniteRangeErr = valueErr InfiniteRange+++-- | Non-enumerable type used where enumerable expected.+nonEnumErr :: LangType -> ExecError+nonEnumErr = valueErr . NonEnum+++-- | Attempted division by zero.+divideByZeroErr :: ExecError+divideByZeroErr = valueErr DivideByZero+++instance Show ValueError where+ show (IndexOutOfBoundsError x) = "index out of bounds: " ++ show x+ show (BadRange t1 t2 t3) = "bad range: all types should be same, but got: " ++ show t1 ++ concatMap ((", "++) . show) (catMaybes [t2,t3])+ show InfiniteRange = "infinite range"+ show (NonEnum t) = "expected enumerable type but got: " ++ show t+ show DivideByZero = "attempted division by zero"+++instance KWError ValueError where+ errToKeyword (IndexOutOfBoundsError{}) = LangIdent "indexOutOfBounds"+ errToKeyword (BadRange{}) = LangIdent "badRange"+ errToKeyword InfiniteRange = LangIdent "infiniteRange"+ errToKeyword (NonEnum{}) = LangIdent "nonEnum"+ errToKeyword DivideByZero = LangIdent "divideByZero"+ genErrKeyword _ = LangIdent "valueError"++++-- | Errors that occur during IO operations.+data EIOError = AlreadyExists IOError+ | DoesNotExist IOError+ | AlreadyInUse IOError+ | DeviceFull IOError+ | EOF IOError+ | IllegalOperation IOError+ | Permission IOError+ deriving (Eq)+++alreadyExistsErr :: IOError -> ExecError+alreadyExistsErr = eioErr . AlreadyExists+++doesNotExistErr :: IOError -> ExecError+doesNotExistErr = eioErr . DoesNotExist+++alreadyInUseErr :: IOError -> ExecError+alreadyInUseErr = eioErr . AlreadyInUse+++deviceFullErr :: IOError -> ExecError+deviceFullErr = eioErr . DeviceFull+++eofErr :: IOError -> ExecError+eofErr = eioErr . EOF+++illegalOperationErr :: IOError -> ExecError+illegalOperationErr = eioErr . IllegalOperation+++permissionErr :: IOError -> ExecError+permissionErr = eioErr . Permission+++eioErrorShow :: IOError -> String+eioErrorShow e = l ++ fn ++ s+ where+ fn = case IO.ioeGetFileName e of+ Nothing -> ""+ Just n -> show n ++ ": "+ l = case IO.ioeGetLocation e of+ "openFile" -> "open file: "+ "readFile" -> "read file: "+ "readProcess: runInteractiveProcess: exec" -> "shell: "+ x -> x ++ ": "+ s = IO.ioeGetErrorString e+++instance Show EIOError where+ show (AlreadyExists e) = eioErrorShow e+ show (DoesNotExist e) = eioErrorShow e+ show (AlreadyInUse e) = eioErrorShow e+ show (DeviceFull e) = eioErrorShow e+ show (EOF e) = eioErrorShow e+ show (IllegalOperation e) = eioErrorShow e+ show (Permission e) = eioErrorShow e+++instance KWError EIOError where+ errToKeyword (AlreadyExists{}) = LangIdent "alreadyExists"+ errToKeyword (DoesNotExist{}) = LangIdent "doesNotExist"+ errToKeyword (AlreadyInUse{}) = LangIdent "alreadyInUse"+ errToKeyword (DeviceFull{}) = LangIdent "deviceFull"+ errToKeyword (EOF{}) = LangIdent "eof"+ errToKeyword (IllegalOperation{}) = LangIdent "illegalOperation"+ errToKeyword (Permission{}) = LangIdent "permission"++ genErrKeyword _ = LangIdent "ioError"+++-- | Represents errors that occur during run-time parsing.+data SynError = SyntaxError ParseError+ | ReadError String+ deriving (Eq)+++-- | Error when parsing text intended to be code.+syntaxErr :: ParseError -> ExecError+syntaxErr = synErr . SyntaxError+++-- | Error when parsing non-code.+readErr :: String -> ExecError+readErr = synErr . ReadError+++instance Show SynError where+ show (SyntaxError e) = show e+ show (ReadError e) = "could not read: " ++ show e+++instance KWError SynError where+ errToKeyword (SyntaxError{}) = LangIdent "syntax"+ errToKeyword (ReadError{}) = LangIdent "read"++ genErrKeyword _ = LangIdent "syntaxError"++++data IncludeError = NoSuchFile FilePath+ | BadSyntax ParseError+ deriving (Eq)+++noSuchFileErr :: FilePath -> ExecError+noSuchFileErr = includeErr . NoSuchFile+++badSyntaxErr :: ParseError -> ExecError+badSyntaxErr = includeErr . BadSyntax+++instance Show IncludeError where+ show (NoSuchFile fp) = "no such file: " ++ fp+ show (BadSyntax e) = show e+++instance KWError IncludeError where+ errToKeyword (NoSuchFile{}) = LangIdent "doesNotExist"+ errToKeyword (BadSyntax{}) = LangIdent "syntax"+ genErrKeyword _ = LangIdent "include"+++-- | Used for control-flow within the language.+--+-- These should never make it to the user, but instead be caught in+-- internal code.+data ControlException = ControlReturn LangLit+ | ControlBreak (Maybe LangLit)+ | ControlContinue+ deriving (Eq)+++controlReturn :: LangLit -> ExecError+controlReturn = controlException . ControlReturn+++controlBreak :: Maybe LangLit -> ExecError+controlBreak = controlException . ControlBreak+++controlContinue :: ExecError+controlContinue = controlException ControlContinue+++instance Show ControlException where+ show (ControlReturn{}) = "return made it to top level"+ show (ControlBreak{}) = "break outside of loop"+ show ControlContinue = "continue outside of loop"+++instance KWError ControlException where+ errToKeyword (ControlReturn{}) = LangIdent "return"+ errToKeyword (ControlBreak{}) = LangIdent "break"+ errToKeyword ControlContinue = LangIdent "continue"++ genErrKeyword _ = LangIdent "controlException"+++-- | Used for the 'return' keyword.+throwReturn :: (CanErrorWithPos m) => LangLit -> m a+throwReturn = throwExecError . controlReturn -- throwAE . controlReturn+++-- | Used for the 'break' keyword.+throwBreak :: (CanErrorWithPos m) => Maybe LangLit -> m a+throwBreak = throwExecError . controlBreak -- throwAE . controlBreak+++-- | Used for the 'continue' keyword.+throwContinue :: (CanErrorWithPos m) => m a+throwContinue = throwExecError controlContinue -- throwAE controlContinue+++-- | Catch 'ControlReturn', but allow other errors to propagate.+catchReturn :: (CanError m) => m a -> (LangLit -> m a) -> m a+catchReturn ex h = ex `catchAE`+ (\e -> case e of+ ExecError { execErrErr = ControlException (ControlReturn v) } -> h v+ err -> throwAE err)+++-- | Catch 'ControlBreak', but allow other errors to propagate.+catchBreak :: (CanError m) => m a -> (Maybe LangLit -> m a) -> m a+catchBreak ex h+ = ex `catchAE`+ (\e -> case e of+ ExecError+ { execErrErr = ControlException (ControlBreak v)+ } -> h v+ err -> throwAE err)+++-- | Catch 'ControlContinue', but allow other errors to propagate.+catchContinue :: (CanError m) => m a -> m a -> m a+catchContinue ex v+ = ex `catchAE`+ (\e -> case e of+ ExecError+ { execErrErr = ControlException ControlContinue } -> v+ err -> throwAE err)
+ src/Angle/Exec/Exec.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-|+Module : Angle.Exec.Exec+Description : Controls execution of an Angle program.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++All programs in Angle can be expressed as a single statement+(usually a multi-statement) and as such all programs are executed+via this one statement.+-}+module Angle.Exec.Exec+ ( execStmt+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (isNothing, fromMaybe)+import System.Directory (findFile, canonicalizePath)+import System.FilePath (takeDirectory)++import Angle.Parse.Parser (program, evalParse)+import Angle.Exec.Builtins+import Angle.Exec.Error+import Angle.Exec.Operations+import Angle.Exec.Scope+import Angle.Exec.Types+import Angle.Types.Lang+import Angle.Types.Scope+++bindArgs :: [Expr] -> ArgSig -> ExecIO ()+bindArgs args (ArgSig+ { stdArgs=params+ , catchAllArg=catchParam})+ = do+ let toCheck = zip args params+ la = length args+ lp = length params+ when ((la > lp && isNothing catchParam) || la < lp)+ (throwExecError $ wrongNumberOfArgumentsErr lp la)+ catchBind <- case catchParam of+ Nothing -> return []+ Just cp -> do+ let toCatch = drop lp args+ res <- mapM execExpr toCatch+ return [(catchArgName cp, LitList res)]+ vals <- mapM (uncurry checkArg) toCheck+ case catchParam of+ Nothing -> return ()+ Just catcher ->+ case catchArgConstr catcher of+ Nothing -> return ()+ Just (ConstrRef cstr constrArgs) ->+ case catchBind of+ [] -> return ()+ [(_, r)] -> checkSatConstr r (Just cstr) (fromMaybe [] constrArgs)+ _ -> undefined+ let toBindFuns = map fst $ filter (isAnnFun . snd) vals+ toBindLits = map fst $ filter (isAnnLit . snd) vals+ toBindAny = map fst (filter (isAnnAny . snd) vals) ++ catchBind+ isAnnFun AnnFun = True+ isAnnFun _ = False+ isAnnLit AnnLit = True+ isAnnLit _ = False+ isAnnAny AnnAny = True+ isAnnAny _ = False+ newScope+ forM_ toBindFuns (\(x, LitLambda l) -> assignVarFunLocal x l)+ forM_ toBindLits (uncurry assignVarLitLocal)+ forM_ toBindAny (uncurry assignVarLitLocal)+ return ()+++-- | Make sure the argument satisfies any+-- class or type restrictions placed upon it.+checkArg :: Expr -> ArgElt -> ExecIO ((LangIdent, LangLit), AnnType)+checkArg ex (ArgElt {argEltConstr=constr, argEltType=typ+ , argEltName=name}) = do+ v <- execExpr ex+ let cstr = fmap getConstrRef constr+ checkSatConstr v cstr (fromMaybe [] $ maybe Nothing constrRefArgs constr)+ checkSatType v typ+ return ((name, v), typ)+++checkSatConstr :: LangLit -> Maybe LangIdent -> [Expr] -> ExecIO ()+checkSatConstr _ Nothing _ = return ()+checkSatConstr v (Just clsName) constrArgs = do+ res <- satConstr v clsName constrArgs+ unless res (throwExecError $ typeExpectConstrErr v clsName)+++execConstr :: LangLit -> LangIdent -> [Expr] -> ExecIO LangLit+execConstr val clsName args = do+ cls <- lookupVarFunLocal clsName+ res <- callLambda cls True $ ExprLit val : args+ case res of+ x@(LitBool _) -> return x+ y -> throwExecError+ $ typeConstrWrongReturnErr clsName (typeOf y)+++-- | Sets the 'as_constr' variable to true if the function is+-- being called as a class, and cleans up afterwords.+withClass :: ExecIO a -> ExecIO a+withClass s = do+ assignVarBuiltinLit (LangIdent "as_constr") (LitBool True)+ res <- s `catchAE` (\e -> setClassFalse >> throwAE e)+ setClassFalse+ return res+ where+ setClassFalse = assignVarBuiltinLit (LangIdent "as_constr") (LitBool False)+++-- | True if the literal is of the specified annotation type.+satType :: LangLit -> AnnType -> Bool+satType _ AnnAny = True+satType (LitLambda _) AnnFun = True+satType (LitLambda _) AnnLit = False+satType _ AnnLit = True+satType _ _ = False+++-- | Fails if @satType@ returns false with the same arguments.+checkSatType :: CanErrorWithPos m => LangLit -> AnnType -> m ()+checkSatType val typ = do+ let res = satType val typ+ unless res $ throwExecError $ typeAnnWrongErr typ $ typeAnnOf val+++-- | True if the given constraint returns true when+-- passed the literal.+satConstr :: LangLit -> LangIdent -> [Expr] -> ExecIO Bool+satConstr val clsName constrArgs = do+ (LitBool res) <- execConstr val clsName constrArgs+ return res+++-- | Expand any ExprParamExpand expressions in an argument list.+expandParams :: [Expr] -> ExecIO [Expr]+expandParams [] = return []+expandParams (x:xs)+ = case x of+ ExprParamExpand n -> do+ val <- lookupVarLitLocal n+ case val of+ LitList vs -> liftM (map ExprLit vs ++) $ expandParams xs+ _ -> liftM (x:) $ expandParams xs+ _ -> liftM (x:) $ expandParams xs+++execExpr :: Expr -> ExecIO LangLit+execExpr (ExprLit x@(LitRange{})) = checkLitRange x >> returnVal x+execExpr (ExprLit (LitClosure lam)) = do+ currScope <- getScope+ returnVal . LitLambda $ lam { lambdaScope = Just currScope }+execExpr (ExprLit x) = returnVal x+execExpr (ExprIdent x) = lookupVarLitLocal x+execExpr (ExprFunIdent x) = liftM LitLambda $ lookupVarFunLocal x+execExpr (ExprOp x) = execOp x+execExpr (ExprFunCall name asClass args) = execFunCall name asClass args+execExpr (ExprList xs) = liftM LitList $ mapM execExpr xs+execExpr (ExprLambdaCall f xs) = callPureLambda f False xs+execExpr x@(ExprRange{}) = do+ r <- execExprRange x+ checkLitRange r+ returnVal r+execExpr _ = undefined++++callPureLambda :: Lambda -> Bool -> [Expr] -> ExecIO LangLit+callPureLambda lam asClass exprs = do+ pushEnvCall (LangIdent "LAMBDA")+ res <- callLambda lam asClass exprs+ popEnvCall+ return res+++execExprRange :: Expr -> ExecIO LangLit+execExprRange (ExprRange x Nothing Nothing)+ = liftM3 LitRange (execExpr x) (return Nothing) (return Nothing)+execExprRange (ExprRange x (Just y) Nothing)+ = liftM3 LitRange (execExpr x) (liftM Just $ execExpr y) (return Nothing)+execExprRange (ExprRange x Nothing (Just z))+ = liftM3 LitRange (execExpr x) (return Nothing) (liftM Just $ execExpr z)+execExprRange (ExprRange x (Just y) (Just z))+ = liftM3 LitRange (execExpr x) (liftM Just $ execExpr y) (liftM Just $ execExpr z)+execExprRange _ = error "excExprRange: passed non-range expression"+++execFunCall :: LangIdent -> Bool -> [Expr] -> ExecIO LangLit+execFunCall = callFun+++execOp :: LangOp -> ExecIO LangLit+execOp (SpecOp op expr) = execSpecOp op expr+execOp (MultiOp op exprs) = execMultiOp op exprs+++execSpecOp :: Op -> Expr -> ExecIO LangLit+execSpecOp OpNeg x = execExpr x >>= negLit+execSpecOp OpNot x = execExpr x >>= notLit+execSpecOp x _ = throwImplementationErr $ "execSpecOp - not a SpecOp: " ++ show x+++execMultiOp :: Op -> [Expr] -> ExecIO LangLit+execMultiOp OpAdd xs = withMultiOp xs addLit+execMultiOp OpAnd xs = withMultiOp xs andLit+execMultiOp OpConcat xs = withMultiOp xs concatLit+execMultiOp OpDiv xs = withMultiOp xs divLit+execMultiOp OpEq xs = withMultiOp xs eqLit+execMultiOp OpExp xs = withMultiOp xs expLit+execMultiOp OpGreater xs = withMultiOp xs greaterLit+execMultiOp OpGreaterEq xs = withMultiOp xs greaterEqLit+execMultiOp OpLess xs = withMultiOp xs lessLit+execMultiOp OpLessEq xs = withMultiOp xs lessEqLit+execMultiOp OpMult xs = withMultiOp xs multLit+execMultiOp OpOr xs = withMultiOp xs orLit+execMultiOp OpSub xs = withMultiOp xs subLit+execMultiOp (UserOp _) _ = throwImplementationErr "execMultiOp: implement user operators"+execMultiOp x _ = throwImplementationErr $ "execMultiOp - not a multiOp: " ++ show x+++withMultiOp :: [Expr] -> ([LangLit] -> ExecIO LangLit) -> ExecIO LangLit+withMultiOp xs f = mapM execExpr xs >>= f+++callFun :: LangIdent -> Bool -> [Expr] -> ExecIO LangLit+callFun x asClass args+ | isBuiltin x = callBuiltin x args+ | otherwise = do+ l <- lookupVarFunLocal x+ pushEnvCall x+ res <- callLambda l asClass args+ popEnvCall+ return res+++callLambda :: Lambda -> Bool -> [Expr] -> ExecIO LangLit+callLambda l@(Lambda { lambdaScope = (Just s) }) asClass args+ = do+ cScope <- getScope+ modifyScope (const s)+ res <- callLambda l { lambdaScope = Nothing } asClass args+ `catchAE` (\e -> modifyScope (const cScope) >> throwError e)+ modifyScope (const cScope)+ return res+callLambda (Lambda+ { lambdaArgs=params+ , lambdaBody=body}) asClass args+ = do+ fullArgs <- expandParams args+ bindArgs fullArgs params+ let f = if asClass then withClass else id+ res <- f (execStmt body `catchReturn` return)+ upScope+ return res+++-- | Executes a single statement.+execStmt :: Stmt -> ExecIO LangLit+execStmt s@(SingleStmt x pos) = updateStmt s >> updatePos pos >> execSingStmt x+execStmt (MultiStmt (x@(SingleStmt (StmtReturn _) _):_)) = execStmt x+execStmt (MultiStmt []) = return LitNull+execStmt (MultiStmt [x]) = execStmt x+execStmt (MultiStmt (x:xs)) = execStmt x >> execStmt (MultiStmt xs)+++assignment+ :: (LangIdent -> Lambda -> ExecIO ())+ -> (LangIdent -> LangLit -> ExecIO ())+ -> LangIdent -> Expr -> ExecIO LangLit+assignment aFun aLit name e = execExpr e+ >>= (\x -> case x of+ x'@(LitLambda l) -> aFun name l >> returnVal x'+ x' -> aLit name x' >> returnVal x')+++execSingStmt :: SingStmt -> ExecIO LangLit+execSingStmt (StmtAssign name e) = assignment assignVarFunLocal assignVarLitLocal name e+execSingStmt (StmtAssignNonLocal name e) = assignment assignVarFunOuter assignVarLitOuter name e+execSingStmt (StmtAssignGlobal name e) = assignment assignVarFunGlobal assignVarLitGlobal name e+execSingStmt (StmtStruct x) = execLangStruct x+execSingStmt (StmtExpr x) = do+ res <- execExpr x+ setEnvSynRep (showSyn res)+ returnVal res+execSingStmt (StmtComment _) = return LitNull+execSingStmt (StmtReturn x) = execReturn x+execSingStmt (StmtBreak x False) = execBreak x+execSingStmt (StmtBreak _ True) = throwContinue+execSingStmt (StmtRaise e) = raiseException e+++execReturn :: Expr -> ExecIO LangLit+execReturn x = do+ isGlob <- liftM (isOutermostScope . currentScope) getEnv+ if isGlob+ then throwExecError returnFromGlobalErr+ else do+ res <- execExpr x+ case res of+ LitLambda lam -> do+ sc <- getScope+ let newS = case lambdaScope lam of+ Nothing -> sc+ Just s -> modifyGlobalScope s (\sc' -> sc' { outerScope = Just sc })+ throwReturn $ LitLambda lam { lambdaScope = Just newS }+ y -> throwReturn y+++execBreak :: Maybe Expr -> ExecIO LangLit+execBreak x = case x of+ Nothing -> throwBreak Nothing+ Just v -> execExpr v+ >>= returnVal >>= (throwBreak . Just)+++raiseException :: LangIdent -> ExecIO LangLit+raiseException e = do+ env <- getEnv+ let currE = currentException env+ return (LitKeyword e)+ case currE of+ Nothing -> throwExecError $ userErr e+ Just err -> if similarErr err+ then throwAE err+ else throwExecError $ userErr e+ where+ similarErr err = errToKeyword err == e+ || genErrKeyword err == e+ || LangIdent "error" == e+++execLangStruct :: LangStruct -> ExecIO LangLit+execLangStruct (StructFor name e s)+ = execStructFor name e s `catchBreak` maybe (getEnvValue >>= returnVal) returnVal+execLangStruct (StructWhile e s)+ = execStructWhile e s `catchBreak` maybe (getEnvValue >>= returnVal) returnVal+execLangStruct (StructIf if' thn els)+ = execStructIf if' thn els+execLangStruct (StructDefun name cs)+ = assignVarFunLocal name cs *> return LitNull+execLangStruct (StructTryCatch b cs)+ = execStructTryCatch b cs+++execStructIf :: Expr -> Stmt -> Maybe Stmt -> ExecIO LangLit+execStructIf if' thn els = do+ p <- execExpr if'+ case p of+ (LitBool True) -> execStmt thn+ (LitBool False) -> case els of+ Nothing -> return LitNull+ Just s -> execStmt s+ x -> throwExecError $ typeUnexpectedErr (typeOf x) LTBool+++execStructFor :: LangIdent -> Expr -> Stmt -> ExecIO LangLit+execStructFor name e s = do+ iterable <- execExpr e >>= fromIter+ outScope <- liftM currentScope getEnv+ res <- forM iterable (\v -> do+ assignVarLitLocal name v+ execStmt s `catchContinue` getEnvValue)+ newS <- liftM currentScope getEnv+ let newS' = deleteLitFromScope name newS+ modifyScope (const $ mergeScope newS' outScope)+ returnVal (LitList res)+++execStructWhile :: Expr -> Stmt -> ExecIO LangLit+execStructWhile ex s = do+ pos <- liftM envSourceRef getEnv+ execStructFor (LangIdent "__WHILEVAL__")+ (ExprLit+ (LitRange (LitInt 1) Nothing Nothing))+ (SingleStmt+ (StmtStruct+ (StructIf ex s (Just (SingleStmt (StmtBreak Nothing False) pos)))) pos)+++execStructTryCatch :: Stmt -> [([LangIdent], Stmt)] -> ExecIO LangLit+execStructTryCatch b catchers = do+ currEnv <- getEnv+ execStmt b `catchAE` genHandle currEnv+ where+ genHandle env e = do+ cscope <- getScope -- Preserve the scope!+ updateEnv env { currentException = Just e, currentScope = cscope }+ res <- checkCatch e catchers `catchBreak` breakTry+ newEnv <- getEnv+ updateEnv newEnv { currentException = Nothing }+ return res+ checkCatch e [] = throwError e+ checkCatch e ((toCatch, ex):es) = if catches+ then execStmt ex+ else checkCatch e es+ where catches = errToKeyword e `elem` toCatch || genErrKeyword e `elem` toCatch+ || LangIdent "error" `elem` toCatch+ breakTry (Just (LitKeyword (LangIdent "try")))+ = execStructTryCatch b catchers+ breakTry e = throwBreak e+++builtinArgs :: [Expr] -> ExecIO [LangLit]+builtinArgs xs = expandParams xs >>= mapM execExpr+++callBuiltin :: LangIdent -> [Expr] -> ExecIO LangLit+callBuiltin (LangIdent "print") xs = builtinArgs xs >>= builtinPrint+callBuiltin (LangIdent "str") xs = builtinArgs xs >>= builtinStr+callBuiltin (LangIdent "index") xs = builtinArgs xs >>= builtinIndex+callBuiltin (LangIdent "length") xs = builtinArgs xs >>= builtinLength+callBuiltin (LangIdent "input") xs = builtinArgs xs >>= builtinInput+callBuiltin (LangIdent "eval") xs = builtinArgs xs >>= builtinEval+callBuiltin (LangIdent "asType") xs = builtinArgs xs >>= builtinAsType+callBuiltin (LangIdent "getArgs") xs = builtinArgs xs >>= builtinGetArgs+callBuiltin (LangIdent "isNull") xs = builtinArgs xs >>= builtinIsNull+callBuiltin (LangIdent "open") xs = builtinArgs xs >>= builtinOpen+callBuiltin (LangIdent "read") xs = builtinArgs xs >>= builtinRead+callBuiltin (LangIdent "write") xs = builtinArgs xs >>= builtinWrite+callBuiltin (LangIdent "close") xs = builtinArgs xs >>= builtinClose+callBuiltin (LangIdent "shell") xs = builtinArgs xs >>= builtinShell+callBuiltin (LangIdent "include") xs = builtinArgs xs >>= builtinInclude+callBuiltin (LangIdent "nonlocal") xs = builtinArgs xs >>= builtinNonLocal+callBuiltin (LangIdent "global") xs = builtinArgs xs >>= builtinGlobal+callBuiltin (LangIdent "local") xs = builtinArgs xs >>= builtinLocal+callBuiltin (LangIdent "round") xs = builtinArgs xs >>= builtinRound+callBuiltin (LangIdent x) _ = throwImplementationErr $ "callBuiltin - not a builtin function: " ++ x+++builtinEval :: [LangLit] -> ExecIO LangLit+builtinEval xs = do+ let r = evalParse st program+ case r of+ Left e -> throwExecError . syntaxErr $ e+ Right res -> execStmt res+ where st = argsToString xs+++-- | Builtin @include@ function.+--+-- @include(file_names)@ will attempt to open, read and evaluate+-- each file in @file_names@ inplace. This is effectively the+-- same as having written the code contained within the files+-- at the point of call.+--+-- If any of @file_names@ are handles, then they will be read+-- fully and evaluated.+--+-- Filepaths are assumed to be relative, unless an absolute+-- path is provided.+builtinInclude :: [LangLit] -> ExecIO LangLit+builtinInclude xs = mapM_ includeFile xs >> return LitNull+ where+ includeFile h@(LitHandle _) = builtinRead [h] >>= builtinEval . (:[])+ includeFile (LitStr f) = includeAngleFile f+ includeFile x = throwExecError $ typeNotValidErr x+ includeAngleFile f = do+ fn <- getAngleFile f+ case fn of+ Nothing -> throwExecError . noSuchFileErr $ f+ Just pth -> do+ txt <- builtinRead [LitStr pth]+ env <- getEnv+ currFile <- liftM currentFile getEnv+ currMain <- liftM runAsMain getEnv+ currScope <- liftM currentScope getEnv+ updateEnv env { currentFile = Just pth, runAsMain = False }+ builtinEval [txt]+ `catchAE` (\e -> do+ newEnv <- getEnv+ updateEnv env+ throwAE e)+ -- newEnv <- getEnv+ recentScope <- liftM currentScope getEnv+ updateEnv env { currentScope = mergeScope recentScope currScope }+ -- updateEnv newEnv { currentFile = currFile, runAsMain = currMain }+ return LitNull+-- builtinRead [f] >>= builtinEval . (:[])+++-- | Builtin @nonlocal@ function.+--+-- @nonlocal(var)@ attempts to lookup the value of @var@ in any+-- of the parent scopes of the current scope. Fails with a+-- @nameError@ if @var@ is not defined.+--+-- @nonlocal(:fun, var)@ attempts to lookup the lambda value+-- of @var@ in a parent scope.+builtinNonLocal :: [LangLit] -> ExecIO LangLit+builtinNonLocal [LitKeyword (LangIdent "fun"), LitKeyword n]+ = liftM LitLambda $ lookupVarFunOuter n+builtinNonLocal [LitKeyword n]+ = lookupVarLitOuter n+builtinNonLocal _ = throwExecError . callBuiltinErr $ "nonlocal: invalid call signature"+++-- | Builtin @global@ function.+--+-- @global(var)@ attempts to lookup the value of @var@ in the global+-- scope. Fails with a @nameError@ if @var@ is not defined.+--+-- @global(:fun, var)@ attempts to lookup the lambda value+-- of @var@ in the global scope.+builtinGlobal :: [LangLit] -> ExecIO LangLit+builtinGlobal [LitKeyword (LangIdent "fun"), LitKeyword n]+ = liftM LitLambda $ lookupVarFunGlobal n+builtinGlobal [LitKeyword n]+ = lookupVarLitGlobal n+builtinGlobal _ = throwExecError . callBuiltinErr $ "global: invalid call signature"+++-- | Built-in @local@ function.+--+-- @local(var)@ attempts to resolve the variable represented by the keyword+-- @var@.+--+-- @local(:fun, var)@ attempts to resove the lambda value of @var@@+builtinLocal :: [LangLit] -> ExecIO LangLit+builtinLocal [LitKeyword (LangIdent "fun"), LitKeyword n]+ = liftM LitLambda $ lookupVarFunLocal n+builtinLocal [LitKeyword n]+ = lookupVarLitLocal n+builtinLocal _ = throwExecError . callBuiltinErr $ "local: invalid call signature"+++getAngleFile :: FilePath -> ExecIO (Maybe FilePath)+getAngleFile fp = do+ searchPath <- liftM angleLibPath getEnv+ currFile <- liftM currentFile getEnv+ maybeFound <- liftIO $ findFile (searchPath ++ [maybe "" takeDirectory currFile, ""]) fp+ case maybeFound of+ Nothing -> return Nothing+ Just p -> liftM Just $ liftIO $ canonicalizePath p+++validRangeLit :: LangLit -> Bool+validRangeLit (LitRange x Nothing Nothing)+ = enumType x+validRangeLit (LitRange x (Just y) Nothing)+ = enumType x && typeOf x == typeOf y+validRangeLit (LitRange x (Just y) (Just z))+ = enumType x && all ((== typeOf x) . typeOf) [y, z]+validRangeLit (LitRange x Nothing (Just z))+ = enumType x && typeOf x == typeOf z+validRangeLit _ = error "validRangeLit: Attempting to verify a non-range"+++checkLitRange :: LangLit -> ExecIO ()+checkLitRange r@(LitRange x y z)+ = unless (validRangeLit r)+ (if enumType x+ then throwExecError $ badRangeErr (typeOf x) (fmap typeOf y) (fmap typeOf z)+ else throwExecError $ typeExpectConstrErr x (LangIdent "enum"))+checkLitRange _ = throwImplementationErr "checkLitRange: Attempting to check a non-range"
+ src/Angle/Exec/Operations.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE RankNTypes #-}+{-|+Module : Angle.Exec.Operations+Description : Definitions for builtin operators.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Angle provides many builtin logical and arithmetical operators,+of which many are overloaded to work on multiple types. Definitions+for these operators can be found in this module.+-}+module Angle.Exec.Operations+ ( addLit+ , andLit+ , concatLit+ , divLit+ , eqLit+ , expLit+ , greaterEqLit+ , greaterLit+ , lessEqLit+ , lessLit+ , multLit+ , negLit+ , notLit+ , orLit+ , subLit+ ) where++import Control.Monad++import Angle.Types.Lang+import Angle.Exec.Error+++-- | Addition operator.+--+-- On list followed by arbitrary types: appends the tail arguments to the list.+--+-- On numeric types: performs arithmetic addition.+--+-- On strings: performs concatenation.+addLit :: MultiOperator+addLit (LitList x:xs@(_:_)) = return $ LitList (x++xs)+addLit (LitStr x:xs) | allType LTStr xs = return $ LitStr $ x ++ concatMap (\(LitStr y) -> y) xs+addLit xs = onlyNumOp addLitNum xs+ where addLitNum = onNum (+) (+)+++-- | Logical and operator.+--+-- On booleans: performs logical and of the values.+andLit :: MultiOperator+andLit [] = return $ LitBool True+andLit [LitList xs] = andLit xs+andLit (x@(LitBool _):xs) = foldM andLitBool x xs+ where andLitBool = onLitBool (&&)+andLit (x:_) = throwExecError $ typeNotValidErr x+++-- | Concatenation operator+--+-- On lists: concatenates the lists.+--+-- On lists with other types: concatenates the lists+-- and appends the other elements in the appropriate places.+--+-- On other types: creates a list of the values.+concatLit :: MultiOperator+concatLit (z:zs) = foldM concatLit' z zs+ where concatLit' (LitList xs) (LitList ys) = return . LitList $ xs ++ ys+ concatLit' (LitList xs) y = return . LitList $ xs ++ [y]+ concatLit' x (LitList ys) = return . LitList $ x : ys+ concatLit' x y = return . LitList $ [x, y]+concatLit _ = throwExecError $ malformedSignatureErr "++"+++-- | Division operator.+--+-- On numerics: performs arithmetic division.+divLit :: MultiOperator+divLit (_:xs) | LitInt 0 `elem` xs = throwExecError divideByZeroErr+ | LitFloat 0 `elem` xs = throwExecError divideByZeroErr+divLit xs = onlyNumOp divLitNum xs+ where divLitNum = onNum div (/)+++-- | Equality operator+--+-- On any types: true if all of the values are equal+eqLit :: MultiOperator+eqLit [] = return $ LitBool True+eqLit [LitList xs] = eqLit xs+eqLit (x:xs) = return . LitBool . all (==x) $ xs+++-- | Exponentation operator+--+-- On numerics: raises the first item to the power produced+-- by raising each successive element to the next power.+expLit :: MultiOperator+expLit = onlyNumOp expLitNum+ where+ expLitNum = onNum (^) (**)+++-- | Greater than or equal to operator.+--+-- On strings: compares the strings lexiographically.+--+-- On numerics: compares the values numerically.+greaterEqLit :: MultiOperator+greaterEqLit = compOp (>=)+++-- | Greater than operator.+--+-- On strings: compares the strings lexiographically.+--+-- On numerics: compares the values numerically.+greaterLit :: MultiOperator+greaterLit = compOp (>)+++-- | Less than or equal to operator.+--+-- On strings: compares the strings lexiographically.+--+-- On numerics: compares the values numerically.+lessEqLit :: MultiOperator+lessEqLit = compOp (<=)+++-- | Less than comparison operator.+--+-- On strings: compares the strings lexiographically.+--+-- On numerics: compares the values numerically.+lessLit :: MultiOperator+lessLit = compOp (<)+++-- | Multiplication operator.+--+-- On numerics: performs arithmetical multiplication on the values.+multLit :: MultiOperator+multLit = onlyNumOp multLitNum+ where multLitNum = onNum (*) (*)+++-- | Negation operator.+--+-- On lists: returns the reversed list.+--+-- On numerics: returns the negative value.+negLit :: UnaryOperator+negLit (LitList xs) = return $ LitList (reverse xs)+negLit (LitInt x) = return $ LitInt (-x)+negLit (LitFloat x) = return $ LitFloat (-x)+negLit x@(LitBool _) = notLit x+negLit x = throwExecError $ typeNotValidErr x+++-- | Logical not operator.+--+-- On boolean: performs logical negation.+notLit :: UnaryOperator+notLit (LitBool x) = return . LitBool $ not x+notLit x = throwExecError $ typeNotValidErr x+++-- | Logical or operator.+--+-- On booleans: performs logical OR.+orLit :: MultiOperator+orLit [] = return $ LitBool False+orLit [LitList xs] = orLit xs+orLit (x@(LitBool _):xs) = foldM orLitBool x xs+ where orLitBool = onLitBool (||)+orLit (x:_) = throwExecError $ typeNotValidErr x+++-- | Subtraction operator.+--+-- On list followed by integers: treats the integers as indices to remove from the list.+--+-- On numerics: subtracts all tailing numerics from the first numeric.+subLit :: MultiOperator+subLit (x@(LitList _):ys@(_:_))+ | allType LTInt ys+ = foldM (flip $ \(LitInt i) -> langListDrop i ) x ys+ where langListDrop n (LitList zs)+ | n >= length zs = throwExecError $ indexOutOfBoundsErr n+ | otherwise = return (LitList res)+ where res = f++s+ (f,_:s) = splitAt n zs+ langListDrop _ _ = undefined+subLit xs = onlyNumOp subLitNum xs+ where subLitNum = onNum (-) (-)+++----------------------+-- END OF OPERATORS --+----------------------+++-- | Lift a binary operator across boolean values to+-- work on `LangLit's.+onLitBool :: Binary Bool Bool -> BinaryOperator+onLitBool f (LitBool x) (LitBool y) = return . LitBool $ f x y+onLitBool _ x y = throwExecError $ typeMismatchOpErr x y+++-- | Takes binary functions that act on Ints and Floats and+-- converts them to functions that act on `LangLit's.+onNum :: Binary Int Int -> Binary Double Double -> BinaryOperator+onNum i f = numOpLit i f LitInt LitFloat+++-- | @numOp i f@ produces a function that will act upon+-- literal numerical values, using @i@ for integers, and+-- @f@ for floats. Integers will be casted to floats+-- if required.+numOp :: Binary Int LangLit -> Binary Double LangLit -> BinaryOperator+numOp i _ (LitInt x) (LitInt y) = return $ i x y+numOp _ f (LitFloat x) (LitFloat y) = return $ f x y+numOp _ f (LitInt x) (LitFloat y) = return $ f (fromIntegral x) y+numOp _ f (LitFloat x) (LitInt y) = return $ f x (fromIntegral y)+numOp _ _ x y = throwExecError $ typeMismatchOpErr x y+++-- | Synonym for a function that performs a comparison+-- between its arguments.+type CompFunc = forall a. (Ord a) => a -> a -> Bool++-- | Synonym for standard operators that act on a list of values.+type MultiOperator = (CanErrorWithPos m) => [LangLit] -> m LangLit+++-- | Synonym for an operator that acts upon only two values.+type BinaryOperator = (CanErrorWithPos m) => LangLit -> LangLit -> m LangLit+++-- | Synonym for an operator that acts upon one value.+type UnaryOperator = (CanErrorWithPos m) => LangLit -> m LangLit+++-- | Synonym for a binary function.+type Binary a b = a -> a -> b+++-- | Given a comparison function, produces an operator+-- that produces a comparison between `LangLit's.+--+-- When the operand is a single list, then the list will be+-- flattened until either a non-list value is found, or there+-- is more than one operand.+compOp :: CompFunc -> MultiOperator+compOp f [LitList xs] = compOp f xs+compOp f xs = liftM (LitBool . and) $ mapM (uncurry $ compLit f) (group2 xs)+++-- | Lift a comparison function to work on 'LangLit's.+compLit :: (CanErrorWithPos m) => (forall a. (Ord a) => a -> a -> Bool) -> LangLit -> LangLit -> m Bool+compLit f (LitInt x) (LitInt y) = return $ f (toRational x) (toRational y)+compLit f (LitInt x) (LitFloat y) = return $ f (toRational x) (toRational y)+compLit f x@(LitFloat _) y@(LitInt _) = compLit f y x+compLit f (LitFloat x) (LitFloat y) = return $ f (toRational x) (toRational y)+compLit f (LitStr x) (LitStr y) = return $ f x y+compLit _ x y = throwExecError $ typeMismatchOpErr x y+++-- | Group the list into successive doubles.+--+-- e.g,+--+-- > group2 [1, 2, 3]+--+-- [(1, 2), (2, 3)]+group2 :: [a] -> [(a, a)]+group2 [] = []+group2 [x] = []+group2 xs = (fst', snd') : group2 (tail xs)+ where+ [fst', snd'] = take 2 xs+++-- | Convenience function for producing `LangLit' values from+-- functions to be supplied to `numOp'.+numOpLit :: Binary Int a -> Binary Double b -> (a -> LangLit) -> (b -> LangLit) -> BinaryOperator+numOpLit i f t1 t2 = numOp i' f'+ where i' x y = t1 $ i x y+ f' x y = t2 $ f x y+++-- | Like `onNum', but given functions must result in boolean+-- values.+--+-- Used for implementing comparison operators.+onNumBool :: Binary Int Bool -> Binary Double Bool -> BinaryOperator+onNumBool i f = numOpLit i f LitBool LitBool+++-- | Operator (or remaining cases of a) that can only+-- act upon numeric types.+--+-- When the operand is a single list, then the list will be+-- flattened until either a non-list value is found, or there+-- is more than one operand.+--+-- Throws a `TypeNotValidError' if invalid literals are passed.+onlyNumOp :: (CanErrorWithPos m) => (LangLit -> LangLit -> m LangLit) -> [LangLit] -> m LangLit+onlyNumOp f [LitList xs] = onlyNumOp f xs+onlyNumOp f (x@(LitInt _):xs) = foldM f x xs+onlyNumOp f (x@(LitFloat _):xs) = foldM f x xs+onlyNumOp _ (x:_) = throwExecError $ typeNotValidErr x+onlyNumOp _ [] = throwImplementationErr "onlyNumOp - got empty list"
+ src/Angle/Exec/Scope.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE RankNTypes #-}+{-|+Module : Angle.Exec.Scope+Description : Functions for working with the runtime scope.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Builds upon "Angle.Types.Scope" by providing functions for+working with scopes during run-time.+-}+module Angle.Exec.Scope+ ( -- ** Traversing the scope+ newScope+ , upScope+ , getScope++ -- ** Outer scope+ , lookupVarLitOuter+ , lookupVarFunOuter+ , assignVarLitOuter+ , assignVarFunOuter++ -- ** Current scope+ , lookupVarLitLocal+ , lookupVarFunLocal+ , modifyScope+ , assignVarLitLocal+ , assignVarFunLocal+ , assignVarBuiltinLit++ -- ** Global scope+ , lookupVarLitGlobal+ , lookupVarFunGlobal+ , assignVarLitGlobal+ , assignVarFunGlobal+ ) where+++import Control.Monad++import Angle.Exec.Builtins ( handleBuiltinAssignLit+ , handleBuiltinAssignFun)+import Angle.Exec.Error+import Angle.Exec.Types+import Angle.Types.Lang+import Angle.Types.Scope+++type VarMaybeLookup a = (Scope -> BindEnv LangIdent a) -> LangIdent -> ExecIO (Maybe a)+++type VarValLookup a = (Scope -> BindEnv LangIdent a) -> LangIdent -> ExecIO (Maybe (VarVal a))+++-- | Determine which scope to lookup the variable in, then perform+-- the lookup.+lookupVarWithScope :: (Scope -> Maybe Scope) -> VarValLookup a+lookupVarWithScope scopeF binds name = do+ actionScope <- liftM scopeF getScope+ return $ case actionScope of+ Nothing -> Nothing+ Just sc -> resolve binds name sc+++lookupVarGlobalScope :: VarValLookup a+lookupVarGlobalScope = lookupVarWithScope (Just . globalScope)+++lookupVarScope :: (Scope -> Maybe Scope) -> VarMaybeLookup a+lookupVarScope scopeF binds name = do+ actionScope <- liftM scopeF getScope+ case actionScope of+ Nothing -> return Nothing+ Just sc -> case resolve binds name sc of+ Nothing -> return Nothing+ Just x -> return $ varDef x++++-- | Retrieve the current scope from the environment.+getScope :: ExecIO Scope+getScope = liftM currentScope getEnv+++lookupVarLitLocal :: LangIdent -> ExecIO LangLit+lookupVarLitLocal (LangIdent "_it") = getEnvValue+lookupVarLitLocal (LangIdent "main") = liftM (LitBool . runAsMain) getEnv+lookupVarLitLocal n = lookupVarLitErr Just n+++lookupVarLitOuter :: LangIdent -> ExecIO LangLit+lookupVarLitOuter = lookupVarOuterErr nameNotDefinedLitErr valueBindings+++lookupVarLitErr :: (Scope -> Maybe Scope) -> LangIdent -> ExecIO LangLit+lookupVarLitErr scF n = lookupVarWithScopeAndError scF nameNotDefinedLitErr valueBindings n >>= returnVal+++lookupVarFunErr :: (Scope -> Maybe Scope) -> LangIdent -> ExecIO Lambda+lookupVarFunErr scF = lookupVarWithScopeAndError scF nameNotDefinedFunErr lambdaBindings+++lookupVarFunLocal :: LangIdent -> ExecIO Lambda+lookupVarFunLocal = lookupVarFunErr Just+++lookupVarLitGlobal :: LangIdent -> ExecIO LangLit+lookupVarLitGlobal = lookupVarLitErr (Just . globalScope)+++lookupVarFunGlobal:: LangIdent -> ExecIO Lambda+lookupVarFunGlobal = lookupVarFunErr (Just . globalScope)+++lookupVarFunOuter :: LangIdent -> ExecIO Lambda+lookupVarFunOuter = lookupVarOuterErr nameNotDefinedFunErr lambdaBindings++lookupVarOuterErr :: (LangIdent -> ExecError) -> VarLookup a+lookupVarOuterErr = lookupVarWithScopeAndError outerScope+++type VarLookup a = (Scope -> BindEnv LangIdent a) -> LangIdent -> ExecIO a+++-- | Lookup the value for the given variable with the specified set+-- of bindings; throw the specified exception if no value can be found.+lookupVarWithScopeAndError :: (Scope -> Maybe Scope) -> (LangIdent -> ExecError) -> VarLookup a+lookupVarWithScopeAndError scF err binds name+ = do+ res <- lookupVarScope scF binds name+ case res of+ Nothing -> throwExecError $ err name+ Just v -> return v+++-- | Modify the current scope using the given function.+modifyScope :: (Scope -> Scope) -> ExecIO ()+modifyScope f = do+ env <- getEnv+ let oldScope = currentScope env+ newScope' = f oldScope+ updateEnv env {currentScope=newScope'}+++lookupVarCurrentScope :: VarValLookup a+lookupVarCurrentScope binds name = do+ currScope <- liftM currentScope getEnv+ if isDefinedIn binds name currScope+ then return $ resolve binds name currScope+ else return Nothing+++assignVarFunLocal :: LangIdent -> Lambda -> ExecIO ()+assignVarFunLocal =+ assignVar lambdaBindings handleBuiltinAssignFun setVarFunInScope+++assignVarOuter :: (LangIdent -> a -> ExecIO ()) -> LangIdent -> a -> ExecIO ()+assignVarOuter f n v = do+ currScope <- getScope+ case outerScope currScope of+ Nothing -> f n v+ Just sc -> do+ modifyScope (const sc)+ f n v+ newParent <- getScope+ modifyScope (const currScope { outerScope = Just newParent })+++assignVarFunOuter :: LangIdent -> Lambda -> ExecIO ()+assignVarFunOuter = assignVarOuter assignVarFunLocal+++assignVarLitOuter :: LangIdent -> LangLit -> ExecIO ()+assignVarLitOuter = assignVarOuter assignVarLitLocal+++assignVarLitLocal :: LangIdent -> LangLit -> ExecIO ()+assignVarLitLocal+ = assignVar valueBindings handleBuiltinAssignLit setVarLitInScope+++assignVar :: (Scope -> BindEnv LangIdent a) -> (LangIdent -> b -> ExecIO b) -> (LangIdent -> VarVal b -> Scope -> Scope) -> LangIdent -> b -> ExecIO ()+assignVar binds handleBuiltin setf name val = do+ current <- lookupVarCurrentScope binds name+ val' <- if maybe False varBuiltin current+ then handleBuiltin name val+ else return val+ modifyScope $ setf name emptyVar {varDef=Just val'}+++-- | Changes the current scope to the parent scope.+upScope :: ExecIO ()+upScope = do+ currScope <- liftM currentScope getEnv+ case outerScope currScope of+ Nothing -> return ()+ Just x -> modifyScope (const x)+++-- | Create a new scope with the current scope as its+-- parent.+newScope :: ExecIO ()+newScope = do+ env <- getEnv+ modifyScope (\s -> emptyScope {outerScope=Just s})+ let oldScope = currentScope env+ newScope' = emptyScope { outerScope = Just oldScope }+ updateEnv env { currentScope = newScope' }++++assignVarBuiltinLit :: LangIdent -> LangLit -> ExecIO LangLit+assignVarBuiltinLit n v = assignVarBuiltin setVarLitInScope n v+ >> returnVal v+++assignVarBuiltin :: (LangIdent -> VarVal b -> Scope -> Scope) -> LangIdent -> b -> ExecIO ()+assignVarBuiltin setf name val+ = modifyScope $ setf name emptyVar { varDef=Just val, varBuiltin=True }+++type ScopeAssign a = forall b. (Scope -> BindEnv LangIdent a) -> (LangIdent -> VarVal b -> Scope -> Scope) -> (LangIdent -> b -> ExecIO b) -> LangIdent -> b -> ExecIO ()++assignVarWithScope :: (Scope -> (Scope -> Scope) -> Scope) -> VarValLookup a -> ScopeAssign a+assignVarWithScope scopeMod lookupF binds assignF handleBuiltin name val = do+ currScope <- getScope+ current <- lookupF binds name+ if maybe False varBuiltin current+ then handleBuiltin name val+ else return val+ let newScope' = scopeMod currScope (assignF name VarVal { varDef = Just val, varBuiltin = False })+ modifyScope (const newScope')+++assignVarGlobal :: ScopeAssign a+assignVarGlobal = assignVarWithScope modifyGlobalScope lookupVarGlobalScope+++assignVarFunGlobal :: LangIdent -> Lambda -> ExecIO ()+assignVarFunGlobal = assignVarGlobal lambdaBindings setVarFunInScope handleBuiltinAssignFun+++assignVarLitGlobal :: LangIdent -> LangLit -> ExecIO ()+assignVarLitGlobal = assignVarGlobal valueBindings setVarLitInScope handleBuiltinAssignLit
+ src/Angle/Exec/Types.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+Module : Angle.Exec.Types+Description : Exports functions from Angle.Exec.Types.Internal+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++-}+module Angle.Exec.Types+ ( ExecIO+ , runExecIOEnv+ , iterToLit+ , fromIter+ , returnVal+ , fromEnumL+ , isInfiniteRange+ -- ** Execution Environment+ , Env(..)+ , getEnv+ , updateEnv+ , basicEnv+ , getEnvValue+ , setEnvSynRep+ , updatePos++ , popEnvCall+ , pushEnvCall++ , updateStmt+ ) where++import Angle.Exec.Types.Internal
+ src/Angle/Exec/Types/Internal.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-|+Module : Angle.Exec.Types.Internal+Description : Defines types used for executing Angle programs.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines the base types (ExecIO and Env) for executing Angle programs.++Also defines functions for working with iterable types in Angle.+-}+module Angle.Exec.Types.Internal+ ( ExecIO+ , runExecIOBasic+ , runExecIOEnv+ , fromIter+ , returnVal+ , iterToLit+ , fromEnumL+ , isInfiniteRange+ -- ** Excution environment+ , Env(..)+ , getEnv+ , updateEnv+ , basicEnv+ , getEnvValue+ , setEnvSynRep+ , updatePos++ , pushEnvCall+ , popEnvCall++ , updateStmt+ ) where+++import Control.Applicative+import Control.Monad.Except+import Control.Monad.Trans.Except+import Control.Monad.State++import Angle.Exec.Error+import Angle.Types.Lang+import Angle.Types.Scope+++-- | Angle program execution monad.+newtype ExecIO a = ExecIO+ { runExecIO :: ExceptT AngleError (StateT Env IO) a }+ deriving ( Functor, Applicative, Monad+ , MonadIO)+++instance MonadError AngleError ExecIO where+ throwError = throwAE+ catchError = catchAE+++instance CanErrorWithPos ExecIO where+ getErrorPos = liftM envSourceRef get+ getErrorSource = liftM sourceText get+ getErrorFile = liftM currentFile get+ getErrorCallStack = liftM (currentStack . callStack) get+ getErrorCall = liftM (((,) <$> currentName <*> currentStmt) . callStack) get+++instance CanError ExecIO where+ throwAE = ExecIO . throwE+ catchAE (ExecIO e) h+ = ExecIO (lift $ runExceptT e) >>= either h return+++instance MonadState Env ExecIO where+ get = ExecIO $ lift get+ put x = ExecIO $ lift $ put x+++-- | Environment in which Angle programs execute.+data Env = Env { currentScope :: Scope+ , sourceText :: String+ , envSourceRef :: SourceRef+ , envSynRep :: String+ , envValue :: LangLit+ , currentException :: Maybe AngleError+ , callStack :: CallStack+ -- ^ Calls and the statements that call them.+ , angleLibPath :: [FilePath]+ , currentFile :: Maybe FilePath+ , runAsMain :: Bool+ } deriving (Show, Eq)+++-- | Track function calls and statement execution.+data CallStack = CallStack+ { currentStack :: [(LangIdent, Stmt)]+ , currentName :: LangIdent+ , currentStmt :: Stmt+ } deriving (Show, Eq)+++startStack :: CallStack+startStack = CallStack { currentStack = []+ , currentName = LangIdent "MODULE" }++-- | Retrieve the current execution environment.+getEnv :: ExecIO Env+getEnv = get+++-- | Update the current execution environment+updateEnv :: Env -> ExecIO ()+updateEnv = put+++-- | Run Angle program with a custom environment.+runExecIOEnv :: Env -> ExecIO a -> IO (Either AngleError a)+runExecIOEnv e x = evalStateT (runExceptT $ runExecIO x) e+++-- | Run Angle program with a basic environment.+runExecIOBasic :: ExecIO a -> IO (Either AngleError a)+runExecIOBasic = runExecIOEnv basicEnv+++-- | Update the current environment tracking position.+updatePos :: SourceRef -> ExecIO ()+updatePos pos = modify (\e -> e { envSourceRef = pos })+++-- | Set the environment's current syntax representation.+setEnvSynRep :: String -> ExecIO ()+setEnvSynRep x = modify (\e -> e { envSynRep = x })+++-- | Basic environment.+basicEnv :: Env+basicEnv = Env { currentScope = emptyScope+ , sourceText = ""+ , envSourceRef = startRef+ , envSynRep = ""+ , envValue = LitNull+ , currentException = Nothing+ , angleLibPath = []+ , currentFile = Nothing+ , callStack = startStack+ }+++-- In a language like Java, could use try..catch+-- to exit early from function, maybe something+-- similar for this?++-- For this,+-- Throw the 'error' in the return statement,+-- then catch it in the calling expression.++-- | Set the current value in the execution environment.+returnVal :: LangLit -> ExecIO LangLit+returnVal v = putEnvValue v >> return v+++-- | Retrieve the current environment value.+getEnvValue :: ExecIO LangLit+getEnvValue = liftM envValue get+++putEnvValue :: LangLit -> ExecIO ()+putEnvValue v = modify (\e -> e {envValue=v})+++popEnvCall :: ExecIO ()+popEnvCall = do+ currEnv <- getEnv+ let currStack = callStack currEnv+ ((newName,_):newStack) = currentStack currStack+ newCallStack = currStack { currentStack = newStack, currentName = newName }+ put currEnv { callStack = newCallStack }+++pushEnvCall :: LangIdent -> ExecIO ()+pushEnvCall newCall = do+ currEnv <- getEnv+ let currStack = callStack currEnv+ oldName = currentName currStack+ oldStmt = currentStmt currStack+ oldStack = currentStack currStack+ newStack = (oldName, oldStmt) : oldStack+ newCallStack = currStack { currentName = newCall, currentStack = newStack }+ put currEnv { callStack = newCallStack }+++updateStmt :: Stmt -> ExecIO ()+updateStmt s = do+ currEnv <- getEnv+ let oldStack = callStack currEnv+ put currEnv { callStack = oldStack { currentStmt = s } }+++-- | Convert a list or range into a list of literals.+fromIter :: LangLit -> ExecIO [LangLit]+fromIter (LitList xs) = return xs+fromIter (LitStr xs) = return $ map LitChar xs+fromIter (LitRange x (Just y) Nothing) = iterFromTo x y+fromIter (LitRange x (Just y) (Just z)) = iterFromThenTo x y z+fromIter (LitRange x Nothing Nothing) = iterFrom x+fromIter (LitRange x Nothing (Just y)) = iterFromThen x y+fromIter x = throwExecError $ nonEnumErr $ typeOf x+++-- | True if the range has infinite size.+isInfiniteRange :: LangLit -> Bool+isInfiniteRange (LitRange _ Nothing _) = True+isInfiniteRange (LitRange x (Just y) (Just z))+ = (y' > x' || y' == x') && zeroStep+ where+ [x',y',z'] = map fromEnumL [x,y,z]+ zeroStep = z' == x'+isInfiniteRange (LitRange x y@(Just _) Nothing) = isInfiniteRange (LitRange x y (Just (LitInt (fromEnumL x + 1))))+isInfiniteRange _ = error "isInfiniteRange: Passed a non-range"+++-- | Retrieve enum value from literal, literal must be+-- enumerable.+fromEnumL :: LangLit -> Int+fromEnumL (LitInt x) = fromEnum x+fromEnumL (LitChar x) = fromEnum x+fromEnumL (LitFloat x) = fromEnum x+fromEnumL _ = error "fromEnumL: non-enumerable type"+++-- | Convert a list or range into a literal list.+iterToLit :: LangLit -> ExecIO LangLit+iterToLit x@(LitRange{}) | isInfiniteRange x = throwExecError infiniteRangeErr+iterToLit x = liftM LitList $ fromIter x+++iterFromThenTo :: LangLit -> LangLit -> LangLit -> ExecIO [LangLit]+iterFromThenTo (LitInt x) (LitInt y) (LitInt z) = return $ map LitInt $ enumFromThenTo x z y -- (succ z) y+iterFromThenTo (LitFloat x) (LitFloat y) (LitFloat z) = return $ map LitFloat $ enumFromThenTo x z y -- (succ z) y+iterFromThenTo (LitChar x) (LitChar y) (LitChar z) = return $ map LitChar $ enumFromThenTo x z y -- (succ z) y+iterFromThenTo _ _ _ = throwImplementationErr "iterFromThenTo: cannot handle non-enumerable types"+++-- Potential: looping to infinity (and beyond)+iterFrom :: LangLit -> ExecIO [LangLit]+iterFrom (LitInt x) = return $ map LitInt $ enumFrom x+iterFrom (LitChar x) = return $ map LitChar $ enumFrom x+iterFrom (LitFloat x) = return $ map LitFloat $ enumFrom x+iterFrom _ = throwImplementationErr "iterFrom: define failure"+++iterFromThen :: LangLit -> LangLit -> ExecIO [LangLit]+iterFromThen (LitInt x) (LitInt y) = return $ map LitInt $ enumFromThen x y+iterFromThen (LitChar x) (LitChar y) = return $ map LitChar $ enumFromThen x y+iterFromThen (LitFloat x) (LitFloat y) = return $ map LitFloat $ enumFromThen x y+iterFromThen _ _ = throwImplementationErr "iterFromThen: define failure"++++iterFromTo :: LangLit -> LangLit -> ExecIO [LangLit]+iterFromTo (LitInt x) (LitInt y) = return $ map LitInt $ enumFromTo x y+iterFromTo (LitChar x) (LitChar y) = return $ map LitChar $ enumFromTo x y+iterFromTo (LitFloat x) (LitFloat y) = return $ map LitFloat $ enumFromTo x y+iterFromTo _ _ = throwImplementationErr "iterFromTo: cannot handle non-enumerable types"+
+ src/Angle/Parse/Helpers.hs view
@@ -0,0 +1,175 @@+{-|+Module : Angle.Parse.Helpers+Description : Defines functions for working with the parser.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Provided functions are split into two categories:++[@basic@] the functions that work on standard types.++[@advanced@] higher-order parsers.+-}+module Angle.Parse.Helpers+ (+ -- ** Basic+ anyChar+ , char+ , charFrom+ , cond+ , notChar+ , string++ -- ** Advanced+ , choice+ , followed+ , manyTill+ , noneFrom+ , notParse+ , sepWith+ , surrounded+ , tryParse+ , within+ , lookAhead++ -- ** Other+ , evalParse+ , Parser+ , SourcePos+ , sourcePos+ , unexpectedErr+ , (<?>)+ ) where+++import Control.Applicative+import Control.Monad.Except+import Control.Monad.State++import Angle.Scanner+++-- | Succeeds if the predicate function returns+-- true when passed the next character.+cond :: (Char -> Bool) -> Parser Char+cond f = tryParse $ do+ ch <- scanChar+ if f ch then return ch+ else unexpectedErr ("character: " ++ show ch)+++-- | Attempt to satisfy the provided parser, but revert+-- the state upon failure.+tryParse :: Parser a -> Parser a+tryParse sc = do+ st <- get+ sc `catchError` (\e -> do+ put st+ throwError e)+++-- | Match the specified character.+char :: Char -> Parser Char+char ch = cond (==ch) <?> show ch+++-- | Matches if character is an element of the provided string.+charFrom :: String -> Parser Char+charFrom str = cond (`elem` str)+++-- | Match `str' in its entirety.+string :: String -> Parser String+string str = tryParse (mapM char str) <?> str+++-- | @within start end sc@ matches @sc@ between @start@ and @end@.+within :: Parser a -> Parser b -> Parser c -> Parser c+within start end sc = start *> sc <* end+++-- | @surrounded x@ is the same as @within x x@.+surrounded :: Parser a -> Parser b -> Parser b+surrounded surr = within surr surr+++-- | Parses second parser before first parser, returning the result+-- of the second parser.+followed :: Parser a -> Parser b -> Parser b+followed f sc = sc <* f+++-- | Use first Parser that succeeds.+choice :: [Parser a] -> Parser a+choice = msum+++++-- | Succeeds if it does not parse the specified character.+notChar :: Char -> Parser Char+notChar ch = cond (/=ch)+++-- | Matches any character, only fails when there is no more input.+anyChar :: Parser Char+anyChar = scanChar <?> "any character"+++-- | Succeeds if the parser succeeds, but does not consume+-- input upon success.+lookAhead :: Parser a -> Parser a+lookAhead sc = do+ pos <- get+ res <- sc+ put pos+ return res+++-- | Succeeds only if `sc' does not succeed.+notParse :: (Show a) => Parser a -> Parser ()+notParse sc = tryParse (do+ res <- optional (tryParse (lookAhead sc))+ case res of Nothing -> return ()+ Just x -> unexpectedErr (show x))+++-- | @noneFrom sc scs@ builds a list of parsers by+-- applying @sc@ to each of @scs@, the resultant parser+-- then succeeds only if all of the resultant parsers+-- fail.+noneFrom :: (Show a) => (a -> Parser a) -> [a] -> Parser ()+noneFrom scf = notParse . oneFrom+ where oneFrom xs = choice $ map scf xs+++-- | List of `sc' separated with `sep'.+sepWith :: Parser a -> Parser b -> Parser [b]+sepWith sep sc = tryParse (do+ fsm <- optional sc+ case fsm of+ Nothing -> return []+ Just fs -> do+ s <- optional sep+ case s of+ Nothing -> return [fs]+ Just _ -> liftM (fs:) (sepWith sep sc))+++-- | Collect sc until `ti' succeeds.+manyTill :: (Show b) => Parser b -> Parser a -> Parser [a]+manyTill ti sc = many (notParse ti *> sc)++++++++++++
+ src/Angle/Parse/Parser.hs view
@@ -0,0 +1,17 @@+{-|+Module : Angle.Parse.Parser+Description : Exports functions from Angle.Parse.Parser.Internal+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++-}+module Angle.Parse.Parser+ ( litList+ , evalParse+ , program+ , stmt+ ) where++import Angle.Parse.Parser.Internal
+ src/Angle/Parse/Parser/Internal.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module : Angle.Parse.Parser.Internal+Description : Module defining functions for parsing Angle code.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Uses parsers from "Angle.Parse.Token" and "Angle.Parse.Helpers", as well+as custom lexing functions to define all the necessary functions for+converting Angle source code into Haskell types.+-}+module Angle.Parse.Parser.Internal+ ( program+ , evalParse++ -- ** Literals+ , lambda+ , langLit+ , litBool+ , litInt+ , litList+ , litNull+ , litRange+ , litStr++ -- ** Statements and structures+ , langStruct+ , singStmt+ , stmt++ -- ** Expressions+ , expr+ , exprFunCall+ , langOp+ ) where+++import Control.Applicative+import Control.Monad.State++import Angle.Parse.Helpers+import Angle.Parse.Token+import Angle.Types.Lang+++-- | Single statement or a multi-statement.+--+-- See 'singleStmt' for the syntax of singular statments.+--+-- Multi-statements are declared by surrounding a series+-- of statements with braces.+--+-- For example: a series of statements that swaps the values+-- of two variables might be:+--+-- @+-- {+-- c = x;+-- x = y;+-- y = c;+-- }+-- @+--+-- Which would swap he values of @x@ and @y@, and the value produced by+-- the series of statements would be the value of the last (value of+-- @c@).+stmt :: Parser Stmt+stmt = (multiStmt <|> singleStmt) <?> "statement"+++singleStmt :: Parser Stmt+singleStmt = do+ many $ surrounded whitespace stmtComment+ initPos <- liftM sourcePos get+ res <- singStmt+ endPos <- liftM sourcePos get+ return SingleStmt+ { stmtSingStmt = res+ , stmtSourcePos = SourceRef (initPos, endPos)+ }+++-- | Statement consisting of zero or more statements.+multiStmt :: Parser Stmt+multiStmt = MultiStmt <$> within tokMultiStmtStart tokMultiStmtEnd (many (tryParse stmt))+++-- | Singular statement.+--+-- Takes the following forms:+--+-- [@return expr@] exits early from a function and produces the+-- value that @expr@ evaluates to.+--+-- [@break {expr}@] exits early from a loop, and produces the value+-- @expr@ if supplied, or the last value present in the loop.+--+-- [@continue@] skips the rest of the body of the current loop and+-- begins the next iteration.+--+-- [@ident = expr@] assigns the value of @expr@ to the variable+-- @ident@.+--+-- [@expr@] executes an expression and produces the value evaluated.+--+-- Or a structure may be used, see 'langStruct'.+singStmt :: Parser SingStmt+singStmt = stmtStruct+ <|> stmtReturn <* singStmtEnd+ <|> stmtRaise <* singStmtEnd+ <|> stmtBreak <* singStmtEnd+ <|> stmtAssignGlobal <* singStmtEnd+ <|> stmtAssignNonLocal <* singStmtEnd+ <|> stmtAssign <* singStmtEnd+ <|> stmtExpr <* singStmtEnd+ <?> "statement"+++singStmtEnd :: Parser ()+singStmtEnd = surrounded whitespace (void (char ';')) <?> "end of statement"+++-- | Variable assignment.+stmtAssign :: Parser SingStmt+stmtAssign = StmtAssign+ <$> tryParse (langIdent <* tokAssign)+ <*> expr+++stmtAssignNonLocal :: Parser SingStmt+stmtAssignNonLocal = StmtAssignNonLocal+ <$> tryParse (langIdent <* tokAssignNonLocal)+ <*> expr+++stmtAssignGlobal :: Parser SingStmt+stmtAssignGlobal = StmtAssignGlobal+ <$> tryParse (langIdent <* tokAssignGlobal)+ <*> expr+++stmtBreak :: Parser SingStmt+stmtBreak = sBreak <|> sContinue+ where sContinue = string "continue" >> return StmtBreak { breakValue=Nothing, breakContinue=True}+ sBreak = string "break" >> (do+ retV <- optional (tryParse (tokNSpaced *> expr))+ return StmtBreak { breakValue=retV, breakContinue=False})+++stmtComment :: Parser SingStmt+stmtComment = StmtComment+ <$> (char '#' *> manyTill tokEndComment anyChar <* tokEndComment)+ where+ tokEndComment = void (char '\n')+ <|> void tokEOF+++stmtStruct :: Parser SingStmt+stmtStruct = liftM StmtStruct langStruct+++stmtReturn :: Parser SingStmt+stmtReturn = liftM StmtReturn (string "return " *> expr)+ <?> "return construct"+++stmtExpr :: Parser SingStmt+stmtExpr = liftM StmtExpr expr+++stmtRaise :: Parser SingStmt+stmtRaise = string "raise " >> liftM (StmtRaise . getLitKeyword) litKeyword+++-- | Language structure.+--+-- Possible forms are:+--+-- [@for ident in expr do stmt@] loops over values produced by+-- @expr@, allowing them to be referenced in @stmt@ by the name+-- @ident@.+--+-- [@while expr do stmt@] while @expr@ evaluates to @true@, will+-- execute @stmt@ then repeat.+--+-- [@if expr then stmt1 {else stmt2}@] if @expr@ evaluates to @true@,+-- executes @stmt1@, otherwise will execute @stmt2@ if it exists, or+-- produce a null value.+--+-- [@unless expr stmt@] if @expr@ evaluates to @false@ then execute+-- @stmt@, otherwise produce a null value.+--+-- [@defun ident(args) stmt@] defines a function @ident@ that has+-- a parameter list @args@ and body @stmt@.+langStruct :: Parser LangStruct+langStruct = structFor+ <|> structWhile+ <|> structIf+ <|> structUnless+ <|> structDefun+ <|> structTryCatch+ <?> "language construct"+++-- | For loop.+structFor :: Parser LangStruct+structFor = do+ name <- string "for " *> langIdent+ iter <- string " in " *> expr+ body <- string " do " *> stmt+ return $ StructFor name iter body+++-- | While loop.+structWhile :: Parser LangStruct+structWhile = StructWhile+ <$> (string "while " *> expr)+ <*> (string " do " *> stmt)+++-- | Conditional if statement.+--+-- of the form:+--+-- if EXPR then STMT {else STMT}+structIf :: Parser LangStruct+structIf = StructIf+ <$> (string "if " *> expr)+ <*> (string " then " *> stmt)+ <*> optional (string "else " *> stmt)+++-- | unless EXPR STMT+--+-- is equivalent to+--+-- if (NOT)EXPR then STMT+structUnless :: Parser LangStruct+structUnless = do+ e <- string "unless " *> expr+ tokNSpaced+ s <- stmt+ els <- optional $ string "else " *> stmt+ return $ StructIf (ExprOp (SpecOp OpNot e)) s els+++-- | Function definition.+structDefun :: Parser LangStruct+structDefun = StructDefun+ <$> (string "defun " *> identName)+ <*> (Lambda+ <$> callList <* tokStmtBetween+ <*> stmt <*> return Nothing)+++-- | Exception handling.+structTryCatch :: Parser LangStruct+structTryCatch = do+ string "try "+ tryCode <- stmt+ catchers <- many catchSec+ return $ StructTryCatch tryCode catchers+ where exceptionList = tokList $ sepWith tokEltSep (liftM getLitKeyword litKeyword)+ singleE = liftM ((:[]) . getLitKeyword) litKeyword+ catchSec = do+ string "catch "+ toCatch <- singleE <|> exceptionList+ exceptCode <- stmt+ return (toCatch, exceptCode)+++-- | A program consists of a series of statements.+program :: Parser Stmt+program = liftM MultiStmt $ followed tokEOF (many stmt)+++exprLit :: Parser Expr+exprLit = liftM ExprLit langLit+++-- | Language literals.+langLit :: Parser LangLit+langLit = litStr+ <|> litNull+ <|> litChar+ <|> tryParse litClosure+ <|> tryParse litLambda+ <|> litRange+ <|> litBool+ <|> litList+ <|> tryParse litFloat+ <|> litInt+ <|> litKeyword+ <?> "literal"+++-- | A literal string.+litStr :: Parser LangLit+litStr = liftM LitStr tokString+++-- | Denary integer.+litInt :: Parser LangLit+litInt = liftA LitInt tokInt <?> "integer literal"+++-- | Floating-point literal.+litFloat :: Parser LangLit+litFloat = liftM LitFloat tokFloat+ <?> "floating-point literal"+++-- | Multi-type list.+litList :: Parser LangLit+litList = liftM LitList (tokList $ sepWith tokEltSep langLit)+ <?> "list literal"+++litKeyword :: Parser LangLit+litKeyword = liftM LitKeyword (char ':' >> identKeyword)+++litLambda :: Parser LangLit+litLambda = liftM LitLambda lambda+++litClosure :: Parser LangLit+litClosure = char '$' >> liftM LitClosure lambda+++exprList :: Parser Expr+exprList = liftM ExprList (tokList $ sepWith tokEltSep expr)+++exprRange :: Parser Expr+exprRange = parens $ do+ from <- expr+ string ".."+ to <- optional expr+ step <- optional . tryParse $ do+ string ".."+ expr+ return $ ExprRange from to step+++-- | Boolean literal.+--+-- litBool = true | false ;+litBool :: Parser LangLit+litBool = liftM LitBool (litTrue <|> litFalse)+ <?> "boolean literal"+ where litTrue = string "true" >> return True+ litFalse = string "false" >> return False+++litChar :: Parser LangLit+litChar = liftM LitChar tokChar+++-- | Dotted range of values.+--+-- Ranges have a single mandatory part and two optional parts, in the+-- form @(start..[stop][..step])@.+--+-- Start is the value with which the range will begin. @(1..)@+-- represents a range starting with the integer 1 and enumerating+-- to infinity.+--+-- Stop is the value at which the range will stop enumerating when+-- it is equal to or higher than the specified value.+-- @(1..50)@ represents a range that can produce the numerical+-- values 1 through 50.+--+-- Step is the optional increment of the range, for non-integers, such+-- as characters, the range step is the positional difference between+-- the characters.+-- @(1..10..2)@ represents a range that will enumerate 1 through+-- 10, but incrementing by 2 on each enumeration.+--+-- The following are all valid forms of ranges:+--+-- [@(start..)@] range from start to maximum bound of type.+--+-- [@(start..stop)@] range from start to stop.+--+-- [@(start..stop..step)@] range from start to stop, incrementing by+-- step.+--+-- [@(start....step)@] range from start to maxmimum bound of type,+-- incrementing by step.+litRange :: Parser LangLit+litRange = tryParse $ parens $ do+ from <- langLit+ string ".."+ to <- optional langLit+ step <- optional . tryParse $ do+ string ".."+ langLit+ return $ LitRange from to step+++-- | Non-valued literal.+--+-- litNull = 'null' | '()' ;+litNull :: Parser LangLit+litNull = string "()" <|> string "null" >> return LitNull+++-- | Expression.+expr :: Parser Expr+expr = ( tryParse exprLit+ <|> exprList+ <|> exprFunIdent+ <|> tryParse exprOp+ <|> tryParse exprRange+ <|> exprFunCall+ <|> exprIdent)+ <?> "expression"+++exprIdent :: Parser Expr+exprIdent = liftM ExprIdent langIdent <?> "identifier"+++identName :: Parser LangIdent+identName = liftM LangIdent (tryParse $ ident False) <?> "identifier"+++identKeyword :: Parser LangIdent+identKeyword = liftM LangIdent (tryParse $ ident True)+++langIdent :: Parser LangIdent+langIdent = identName+++funIdent :: Parser LangIdent+funIdent = char '$' *> identName+++exprFunIdent :: Parser Expr+exprFunIdent = liftM ExprFunIdent funIdent+++-- | Lambdas are unnamed functions which can be assigned to+-- identifiers or passed to functions when used in their literal+-- form.+--+-- @((x y) (+ x y);)@+--+-- References a lambda that performs basic addition.+lambda :: Parser Lambda+lambda = parens $ do+ args <- callList <* tokNSpaced+ body <- stmt+ return $ Lambda args body Nothing+++-- | Set of arguments for a function+arglist :: Parser [Expr]+arglist = parens (sepWith tokEltSep (expr <|> exprParamExpand))+++exprParamExpand :: Parser Expr+exprParamExpand = liftM ExprParamExpand $ string ".." >> langIdent+++-- | Function call.+--+-- Function calls consist of an identifier followed+-- by an argument list surrounded by parentheses (see 'arglist').+exprFunCall :: Parser Expr+exprFunCall = (do+ asClass <- (char '@' >> return True) <|> return False+ name <- tryParse (langIdent <* lookAhead (char '('))+ args <- arglist+ return $ ExprFunCall name asClass args) <?> "function call"+++exprOp :: Parser Expr+exprOp = liftM ExprOp langOp+++-- | Either a special operator or a multi-operator.+--+-- Special operators are prefix and have one operand, i.e., prefix+-- unary operators.+--+-- Multi-operators can take an arbitrary number of arguments (usually+-- at least one) but must be surrounded by parentheses.+langOp :: Parser LangOp+langOp = specOp <|> multiOp+++makeOp :: Parser a -> Op -> Parser Op+makeOp sc op = sc >> return op+++opAdd, opAnd, opConcat, opDiv, opEq,+ opGreater, opGreaterEq, opLess, opLessEq,+ opMult, opNeg, opNot, opOr, opSub, opExp+ :: Parser Op+opAdd = makeOp (char '+') OpAdd+opAnd = makeOp (char '&') OpAnd+opConcat = makeOp (string "++") OpConcat+opDiv = makeOp (char '/') OpDiv+opEq = makeOp (string "==") OpEq+opGreater = makeOp (char '>') OpGreater+opGreaterEq = makeOp (string ">=") OpGreaterEq+opLess = makeOp (char '<') OpLess+opLessEq = makeOp (string "<=") OpLessEq+opMult = makeOp (char '*') OpMult+opNeg = makeOp (char '-') OpNeg+opNot = makeOp (char '^') OpNot+opOr = makeOp (char '|') OpOr+opSub = makeOp (char '-') OpSub+opExp = makeOp (string "**") OpExp+++userOp :: Parser Op+userOp = liftM (UserOp . LangIdent) (some tokOpChar) <?> "operator"+++-- | Special operators that can be used outside of+-- parentheses in a prefix form.+specOp :: Parser LangOp+specOp = choice (map preOp specOps) <?> "special operator"+++specOps :: [Parser Op]+specOps = [opNeg, opNot]+++preOp :: Parser Op -> Parser LangOp+preOp sc = do+ op <- sc+ opr <- expr+ return $ SpecOp op opr+++-- |Operators called within parentheses that may have+-- multiple operands+multiOp :: Parser LangOp+multiOp = parens (choice (map (tryParse . multOp) multiOps)+ <|> multOp userOp) <?> "operator expression"+++-- | List of all the MultiOp parsers.+multiOps :: [Parser Op]+multiOps = [ opAdd, opAnd, opConcat+ , opExp+ , opDiv, opEq+ , opGreater, opGreaterEq+ , opLess, opLessEq+ , opMult, opOr+ , opSub ]+++multOp :: Parser Op -> Parser LangOp+multOp sc = MultiOp+ <$> (sc <* tokSpace)+ <*> sepWith (some tokWhitespace) expr+++constrRef :: Parser ConstrRef+constrRef = char '@' >> liftM2 ConstrRef langIdent (optional arglist)+++constrRefArgSig :: Parser ConstrRef+constrRefArgSig = tryParse (char ':' >> constrRef)+++callList :: Parser ArgSig+callList = parens $ do+ params <- sepWith tokEltSep argElt+ catcher <- optional catchArg+ return $ ArgSig params catcher+++catchArg :: Parser CatchArg+catchArg = do+ string ".."+ n <- identName+ constr <- optional constrRefArgSig+ return $ CatchArg n constr+++argElt :: Parser ArgElt+argElt = do+ typ <- argSigType+ name <- identName+ cls <- optional constrRefArgSig+ return $ ArgElt typ name cls+++argSigType :: Parser AnnType+argSigType = char '$' *> return AnnFun+ <|> char '!'*> return AnnLit+ <|> return AnnAny
+ src/Angle/Parse/Token.hs view
@@ -0,0 +1,331 @@+{-|+Module : Angle.Parse.Token+Description : Definitons for language tokens.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Definitions for basic parsers to be used by the main parser.+-}+module Angle.Parse.Token+ (+ -- ** Whitespace+ tokNSpaced+ , tokSpace+ , tokWhitespace+ , whitespace++ -- ** Statements+ , tokAssign+ , tokAssignNonLocal+ , tokAssignGlobal+ , tokStmtBetween+ , tokMultiStmtEnd+ , tokMultiStmtStart++ -- ** Literals+ , tokFloat+ , tokInt+ , tokList+ , tokChar++ -- *** Strings+ , tokString+ , withCharEscape++ -- ** Misc+ , keywords+ , tokEOF+ , ident+ , parens+ , tokOpChar+ , tokEltSep+ ) where+++import Control.Applicative+import Control.Monad+import Data.Char+import Numeric++import Angle.Parse.Helpers+++-- | Start of a multi-stmt.+tokMultiStmtStart :: Parser Char+tokMultiStmtStart = surrounded whitespace (char '{')+ <?> "start of multi-statement"+++-- | End of a multi-stmt.+tokMultiStmtEnd :: Parser Char+tokMultiStmtEnd = surrounded whitespace (char '}')+ <?> "end of multi-statement"+++-- | Element separator for lists and arguments.+tokEltSep :: Parser Char+tokEltSep = surrounded whitespace (char ',')+ <?> "element separator"+++tokDenaryDigit :: Parser Char+tokDenaryDigit = cond isDigit <?> "denary digit"+++-- | A single space character.+tokSpace :: Parser Char+tokSpace = char ' ' <?> "space"+++-- | A single space character (see 'isSpace' for what qualifies).+tokWhitespace :: Parser Char+tokWhitespace = cond isSpace <?> "whitespace"+++-- | Assignment operator character.+tokAssign :: Parser Char+tokAssign = surrounded whitespace (char '=')+ <?> "assignment operator"++tokAssignNonLocal :: Parser String+tokAssignNonLocal = surrounded whitespace (string "|=")+ <?> "nonlocal assignment"+++tokAssignGlobal :: Parser String+tokAssignGlobal = surrounded whitespace (string "||=")+ <?> "global assignment"+++-- | Matches any amount of whitespace.+whitespace :: Parser String+whitespace = many tokWhitespace+++-- | Matches when there are no more characters in the stream.+tokEOF :: Parser ()+tokEOF = notParse anyChar+++-- | Characters valid between statements.+tokStmtBetween :: Parser String+tokStmtBetween = whitespace <?> "ignored characters"+++-- | Matches a string representing an integer.+tokInt :: (Integral a, Read a) => Parser a+tokInt = do+ negve <- optional (char '-')+ res <- read <$> tokDigits <?> "integer"+ case negve of+ Nothing -> return res+ Just _ -> return (-res)+++tokDigits :: Parser String+tokDigits = some tokDenaryDigit+++-- | Matches a string representing a floating-point number.+tokFloat :: Parser Double+tokFloat = do+ negve <- optional (char '-')+ f <- tokDigits+ rst <- (:) <$> char '.' <*> tokDigits+ let res = read $ f ++ rst+ case negve of+ Nothing -> return res+ Just _ -> return (-res)+++-- | Matches within square brackets.+tokList :: Parser a -> Parser a+tokList = within tokStartList tokEndList+ where+ tokStartList = char '[' <* whitespace+ tokEndList = whitespace *> char ']'+++-- | Function/variable identifier (but not a keyword).+ident ::+ Bool -- ^Are keywords allowed?+ -> Parser String+ident b = unless b (noneFrom (\x -> string x <* specEnd) keywords) *> ((:) <$> tokIdentStartChar <*> many tokIdentBodyChar)+ where specEnd = notParse tokIdentBodyChar+ tokIdentStartChar = cond (\x -> isAlpha x || x == '_')+ tokIdentBodyChar = cond (\x -> isAlphaNum x || x == '_')+++-- | Valid operator character.+tokOpChar :: Parser Char+tokOpChar = charFrom "*/+->=<|&^"+++-- | Angle keywords.+keywords :: [String]+keywords = [ "break"+ , "catch"+ , "continue"+ , "defun"+ , "do"+ , "else"+ , "false"+ , "for"+ , "if"+ , "in"+ , "null"+ , "raise"+ , "return"+ , "then"+ , "true"+ , "try"+ , "unless"+ , "while"]+++-- | Matches within parentheses.+parens :: Parser a -> Parser a+parens sc = within tokParenL tokParenR sc+ <?> "parentheses"+ where+ tokParenL = char '(' <* whitespace+ tokParenR = whitespace *> char ')'+++stringNorm :: Parser String+stringNorm = do+ char '"'+ r <- manyTill (char '"') (withCharEscape False)+ char '"'+ return (concat r)+++-- | String of the form "BODY".+tokString :: Parser String+tokString = tryParse stringBS <|> stringNorm+++-- | Character of the form 'C'.+tokChar :: Parser Char+tokChar = surrounded (char '\'') charNonEmpty+ where+ charNonEmpty = do+ c <- notChar '\''+ case c of+ '\\' -> escChar+ _ -> return c+++stringBS :: Parser String+stringBS = do+ string "e\""+ r <- manyTill (char '"') (withCharEscape True)+ char '"'+ return (concat r)+++-- | Space or newline followed by optional whitespace.+--+-- A common separator in Operators and Lambdas.+tokNSpaced :: Parser String+tokNSpaced = tokSpace <|> tokNewLine >> whitespace+ where+ tokNewLine = char '\n'++++-- | Parse a single character, escaping it if+-- it is preceded by a backslash and has no literal+-- meaning.+withCharEscape :: Bool -- ^ Treat backslashes as literal backslashes.+ -> Parser String+withCharEscape b = do+ c <- anyChar+ case c of+ '\\' -> if b+ then liftM (\x -> [c,x]) anyChar+ else escString -- liftM (:[]) escChar+ <|> liftM (\x -> [c, x]) anyChar+ _ -> return [c]+++escString :: Parser String+escString = (escEmpty >> return "")+ <|> liftM (:[]) escChar+++escEmpty :: Parser Char+escEmpty = char '&'+ <|> (some tokSpace >> char '\\')+++escChar :: Parser Char+escChar = genEsc+ <|> escNum+ <|> asciiEsc+ <|> controlEsc+ <?> "escape code"+++controlEsc :: Parser Char+controlEsc = do+ char '^'+ code <- upper+ return $ toEnum $ fromEnum code - fromEnum 'A'+ where upper = cond isUpper+++toBase :: (Show a, Integral a) => a -> a -> String+toBase base num = showIntAtBase base intToDigit num ""+++fromBase :: Int -> String -> Int+fromBase base = fst . head . readInt base ((<base) . digitToInt) digitToInt+++numBase :: Int -> Parser Char -> Parser Int+numBase base baseDig = do+ s <- some baseDig+ return $ read $ toBase10 $ fromBase base s+ where toBase10 = toBase 10+++escNum :: Parser Char+escNum = do+ code <- numBase 10 tokDenaryDigit+ <|> (char 'o' >> numBase 8 octDigit)+ <|> (char 'x' >> numBase 16 hexDigit)+ return $ toEnum $ fromIntegral code+ where hexDigit = cond isHexDigit+ octDigit = cond isOctDigit+++genEsc :: Parser Char+genEsc = choice (map genEscChar escs)+ where genEscChar c = char c >> return (codeToChar [c])+ escs = "abfnrtv\\\"\'"+++asciiEsc :: Parser Char+asciiEsc = choice (map asciiEscChar asciis)+ where asciiEscChar asc = tryParse (string asc) >> return (codeToChar asc)+ asciis = ascii3codes ++ ascii2codes+++ascii2codes :: [String]+ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO","SI","EM"+ , "FS","GS","RS","US","SP"]+++ascii3codes :: [String]+ascii3codes = [ "NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL"+ , "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB"+ , "CAN","SUB","ESC","DEL"]+++codeToChar :: String -> Char+codeToChar s = case readLitChar ('\\':s) of+ [(r,"")] -> r+ _ -> error $ "codeToChar: not a valid code: " ++ s
+ src/Angle/Scanner.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+Module : Angle.Scanner+Description : Defines the Parser type, and the base scanner function.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Defines the `Parser' monad along with the language scanner.++The main features are:++* 'Parser' @a@ - the type that represents a parser that will+turn the input stream into a type @a@.++* 'scanChar' - base function for yielding characters from the input+stream.++* 'evalParse' @stream parser@ - runs @parser@ on @stream@, producing a+result wrappied in 'Either'.+-}+module Angle.Scanner+ (+ -- * Types++ -- ** Parser+ Parser+ , evalParse++ -- ** Errors+ , ParseError(..)+ , (<?>)+ , unexpectedErr++ -- * Scanner+ , scanChar++ -- ** Position+ , SourcePos(..)+ , beginningOfFile+ , colNo+ , lineNo+ , sourcePos++ ) where+++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Except+import Control.Monad.Except+++-- | Represents a position in source.+newtype SourcePos = SourcePos+ { getSourcePos :: (Int, Int, Int) }+ deriving (Eq)+++instance Show SourcePos where+ show sp =+ let ln = lineNo sp+ cn = colNo sp+ in concat ["line: ", show (ln+1), ", column: ", show (cn+1)]+++-- | Start position in a file.+beginningOfFile :: SourcePos+beginningOfFile = SourcePos (0,0,0)+++-- | Retrieve the line number from a source position.+lineNo :: SourcePos -> Int+lineNo (SourcePos (ln, _, _)) = ln+++-- | Retrieve the column number from a source position.+colNo :: SourcePos -> Int+colNo (SourcePos (_, cn, _)) = cn+++-- | Reset the column number whilst incrementing the+-- line number and source index.+incNL :: SourcePos -> SourcePos+incNL (SourcePos (ln,_,si)) = SourcePos (ln+1, 0, si+1)+++-- | Increment the column and source index but keep the+-- line number constant.+incCol :: SourcePos -> SourcePos+incCol (SourcePos (ln,cn,si)) = SourcePos (ln,cn+1,si+1)+++-- | Holds information about the current position in source.+data ScanState = ScanState+ { sourcePos :: SourcePos+ -- ^ The current position in source.+ , sourceRemaining :: String+ -- ^ Source that has not yet been traversed.+ , sourceScanned :: String+ -- ^ Source that has already been traversed.+ } deriving (Show, Eq)+++-- | The environment variables that the parser can access.+data ParseEnv = ParseEnv+ { sourceText :: String+ } deriving (Show, Eq)+++-- A @Parser a@ builds a type @a@ from an input stream.+newtype Parser a = Parser+ { runParser :: ExceptT ParseError+ (StateT ScanState+ (Reader ParseEnv)) a }+ deriving ( Functor, Applicative, Monad )+++instance MonadError ParseError Parser where+ throwError = Parser . throwE+ catchError (Parser e) h+ = Parser (lift $ runExceptT e) >>= either h return+++instance MonadState ScanState Parser where+ get = Parser $ lift get+ put x = Parser $ lift $ put x+++instance MonadPlus Parser where+ mzero = do+ s <- get+ emptyErrh $ UnknownError (sourcePos s)+ mplus x y = x `catchError` const y+++instance Alternative Parser where+ empty = mzero+ (<|>) = mplus+++instance MonadReader ParseEnv Parser where+ ask = Parser $ lift ask+ local f (Parser (ExceptT e)) = Parser $ ExceptT $ local f e+++emptyErrh :: ParseError -> Parser a+emptyErrh = throwError+++-- | Type for tracking information about lexical errors.+data ParseError = ParseError+ { expectedMsg :: String -- ^Human readable statement of+ -- an expected value+ , unexpectedMsg :: String+ , errMsg :: String -- ^A general error message that+ -- does not fit into one of the+ -- above two categories+ , errPos :: SourcePos -- ^The position in source+ -- where the error occurred+ , parseErrText :: String -- Reference to the source text+ } | UnknownError SourcePos deriving (Eq)+++instance Show ParseError where+ show (ParseError{errPos=ep, expectedMsg=em+ , unexpectedMsg=um, errMsg=errm+ , parseErrText=et})+ = cEp ++ cEt ++ cUm ++ cEm ++ errm+ where cEp = show ep ++ "\n"+ cEt = let lns = lines et in+ if null lns+ then "no source\n"+ else replicate (colNo ep) ' ' ++ "v\n" ++ lns !! lineNo ep ++ "\n"+ cEm = if null em then ""+ else concat ["expected ", em, "\n"]+ cUm = if null um then ""+ else concat ["unexpected ", um, "\n"]+ show (UnknownError pos) = show pos ++ "\nUnknown Error!"+++-- | Throws an error stating the unexpected input.+unexpectedErr :: String -> Parser a+unexpectedErr = toErr (\e msg -> e { unexpectedMsg=msg })+++toErr :: (ParseError -> String -> ParseError) -> String -> Parser a+toErr err msg = do+ pos <- liftM sourcePos get+ txt <- liftM sourceText ask+ let e = basicErr { errPos=pos, parseErrText=txt }+ throwError (err e msg)+++basicErr :: ParseError+basicErr = ParseError { errMsg=""+ , unexpectedMsg=""+ , expectedMsg=""+ , errPos=beginningOfFile+ , parseErrText = ""}+++-- | Retrieves the next character from the+-- stream whilst updating the position.+--+-- Throws an error if it reaches the end of the stream.+scanChar :: Parser Char+scanChar = do+ st <- get+ let remSource = sourceRemaining st+ pos = sourcePos st+ if remSource == ""+ then unexpectedErr "end of stream"+ else do+ let chr = head remSource+ put st{ sourcePos=if chr == '\n'+ then incNL pos+ else incCol pos+ , sourceRemaining=tail remSource+ , sourceScanned=chr : sourceScanned st+ }++ return chr+++-- | Used for evaluating a single Parser with a given string.+--+-- Assumes reasonable default state.+evalParse :: String -> Parser a -> Either ParseError a+evalParse str sc = runReader (evalStateT (runExceptT (runParser sc)) defaultState) env+ where defaultState = ScanState { sourcePos = beginningOfFile+ , sourceRemaining = str+ , sourceScanned = ""+ }+ env = ParseEnv { sourceText = str+ }+++-- | If the parse fails, specify what was expected.+infix 0 <?>+(<?>) :: Parser a -> String -> Parser a+sc <?> msg = do+ oldPos <- liftM sourcePos get+ sc `catchError` (\e -> do+ newPos <- liftM sourcePos get+ if newPos == oldPos then throwError $ e {expectedMsg=msg}+ else throwError e)
+ src/Angle/Types/Lang.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-|+Module : Angle.Types.Lang+Description : Basic types that make up the Angle language.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : experimental++* LangLit is a container for the various literal values.+* LangType represents the types of these values.+* LangIdent represents names (identifiers).++* Stmt wraps SingStmts.+* SingStmt represents the statements in Angle.+++= Statements in Angle+In Angle, statements are split into two main types (see 'Stmt'),+singular statements and multi-statements.++Singular statements are represented by 'SingStmt' and are what the+programmer uses to achieve tasks; multi-statements are multiple+singular statements grouped together such that the effective value+of the statements is the same as the last statement in the group.+++== Singular statements+Statements are separated by semi-colons and allow the programmer to+perform actions.++[@assignment@] this allows the programmer to give a name to values and+functions, so that he may refer to them later on in the code.++[@comments@] comments have no functional value, but serve as a means+to document or explain parts of code.++[@structures@] see "Angle.Types.Lang#structures"++[@expressions@] see 'Expr'++[@return@] allows the programmer to exit a function early and use+the provided value as the function's value.++[@break and continue@] for use during loops: break exits the loop+immediately, whereas continue starts the next iteration of the loop,+skipping the rest of the loop body.++[@raise@] allows the user to throw exceptions.+++== Language structures #structures#+In Angle, there exist language structures for performing certain tasks.++[@for loops@ : 'StructFor'] a looping structure that iterates over the elements+of an enumerable type and allows each to be used within the body+individually.++[@while loops@ : 'StructWhile'] executes the body while some condition holds.++[@if statement@ : 'StructIf'] categorized as a structure for+convenience, consists of three parts: a condition, a body of code+that will execute if the condition holds, and an optional body that+will execute if the condition does not hold.++[@function definitions@ : 'StructDefun'] allows the assignment of previously+non-existant lambda bodies to a name.++[@try catch@ : 'StructTryCatch'] allows basic handling of exceptions.+-}+module Angle.Types.Lang+ ( Expr(..)+ , LangOp(..)+ , Op(..)++ -- * Fundamental types+ , LangLit(..)+ , isNull+ , LangIdent(..)++ -- * Advanced types+ , Stmt(..)+ , SingStmt(..)+ , LangStruct(..)++ -- ** Angle types+ , LangType(..)+ , typeOf++ , ArgSig(..)+ , CatchArg(..)+ , ShowSyn(..)+ , SourceRef(..)+ , startRef+ , ConstrRef(..)+ , AnnType(..)+ , typeAnnOf+ , ArgElt(..)+ , Lambda(..)+ , Scope+ , enumType+ , allType+ ) where++import Numeric (showFFloat)+import System.IO (Handle)++import Angle.Scanner (SourcePos, beginningOfFile)+import Angle.Types.Scope (GenScope)+++type Scope = GenScope LangIdent LangLit Lambda+++-- | Wraps statements to allow for positional tracking as well+-- as multiple statements grouped together.+data Stmt =+ SingleStmt+ { stmtSingStmt :: SingStmt+ , stmtSourcePos :: SourceRef+ } -- ^ Any language construct that+ -- performs some action or evaluation.+ | MultiStmt [Stmt]+ -- ^ Many statements, allowing+ -- a series of statements to be+ -- executed one after another,+ -- discarding intermediate+ -- results.+ deriving (Show)+++-- | Statements are equal if their contents are equal,+-- the position may differ.+instance Eq Stmt where+ (SingleStmt x _) == (SingleStmt y _) = x == y+ (MultiStmt xs) == (MultiStmt ys) = xs == ys+ _ == _ = False+++-- | Positional reference to a section of source code.+newtype SourceRef = SourceRef+ { getSourceRef :: (SourcePos, SourcePos)+ } deriving (Show, Eq)+++-- | The initial `SourceRef' - starting and ending at+-- the beginning of the file.+startRef :: SourceRef+startRef = SourceRef (beginningOfFile, beginningOfFile)+++-- | Interface for types that can have a string representation+-- in the language.+class ShowSyn a where+ -- | Convert the value to a string representation that+ -- would produce the exact same result if lexed.+ showSyn :: a -> String+++instance ShowSyn Stmt where+ showSyn (SingleStmt x _) = showSyn x+ showSyn (MultiStmt xs) = "{\n" ++ showRest ++ "}\n"+ where showRest = unlines+ $ map (" "++) $ lines+ $ concatMap showSyn xs+++instance ShowSyn SingStmt where+ showSyn (StmtAssign n e) = concat [showSyn n, " = ", showSyn e, ";\n"]+ showSyn (StmtAssignNonLocal n e) = concat [showSyn n, " |= ", showSyn e, ";\n"]+ showSyn (StmtAssignGlobal n e) = concat [showSyn n, " ||= ", showSyn e, ";\n"]+ showSyn (StmtStruct x) = showSyn x+ showSyn (StmtExpr e) = showSyn e ++ ";\n"+ showSyn (StmtComment x) = "#" ++ x ++ "\n"+ showSyn (StmtReturn x) = "return " ++ showSyn x ++ ";\n"+ showSyn (StmtBreak x False) = "break" ++ retVal ++ ";\n"+ where+ retVal = maybe "" ((" "++) . showSyn) x+ showSyn (StmtBreak Nothing True) = "continue;\n"+ showSyn (StmtRaise e) = "raise " ++ showSyn e ++ ";\n"+ showSyn (StmtBreak _ _) = error "showSyn: StmtBreak not a valid combination!"+++-- | A single statement.+data SingStmt = StmtAssign LangIdent Expr+ | StmtAssignNonLocal LangIdent Expr+ | StmtAssignGlobal LangIdent Expr+ | StmtComment String -- ^ Comment which is - for all intents and purposes - ignored by the parser.+ | StmtStruct LangStruct+ | StmtExpr Expr -- ^ Expression. Evaluates to a literal.+ | StmtReturn Expr+ | StmtBreak { breakValue :: Maybe Expr+ , breakContinue :: Bool }+ | StmtRaise LangIdent+ deriving (Show, Eq)+++-- | Specialised language constructs.+data LangStruct = StructFor LangIdent Expr Stmt+ | StructWhile Expr Stmt+ | StructIf Expr Stmt (Maybe Stmt)+ | StructDefun LangIdent Lambda+ | StructTryCatch Stmt [([LangIdent], Stmt)]+ deriving (Show, Eq)+++instance ShowSyn LangStruct where+ showSyn (StructFor n e s) =+ concat [ "for ", showSyn n+ , " in ", showSyn e+ , " do ", showSyn s]+ showSyn (StructWhile e s) =+ concat ["while ", showSyn e, " do ", showSyn s]+ showSyn (StructIf e s els)+ = concat [ "if " , showSyn e+ , " then ", showSyn s] +++ case els of+ Nothing -> ""+ Just x -> " else " ++ showSyn x+ showSyn (StructDefun n c)+ = concat ["defun ", showSyn n, showLambdaFun c]+ showSyn (StructTryCatch s es) = "try " ++ showSyn s ++ concatMap showCatch es+ where+ showCatch (toCatch, b) = "\ncatch " ++ es' toCatch ++ showSyn b+ es' toCatch = if length toCatch == 1+ then showSyn . LitKeyword $ head toCatch+ else showSyn . LitList . map LitKeyword $ toCatch++++showSynSep :: ShowSyn a => String -> String -> String -> [a] -> String+showSynSep start end _ [] = start ++ end+showSynSep start end sep xs = start ++ concatMap ((++sep) . showSyn) (init xs) ++ showSyn (last xs) ++ end+++showSynArgs :: (ShowSyn a) => [a] -> String+showSynArgs = showSynSep "(" ")" ", "+++showSynOpList :: (ShowSyn a) => [a] -> String+showSynOpList = showSynSep " " ")" " "+++-- | Lambdas consist of two parts: the parameter list and the body.+--+-- The parameter list describes the possible forms with which the+-- lambda can be invoked.+--+-- The body is the code that is executed upon successful invokation.+data Lambda = Lambda { lambdaArgs :: ArgSig+ , lambdaBody :: Stmt+ , lambdaScope :: Maybe Scope+ } deriving (Show, Eq)+++instance ShowSyn Lambda where+ showSyn (Lambda args body@(SingleStmt _ _) _)+ = concat ["(", showSyn args, " ", init $ showSyn body, ")"]+ showSyn (Lambda args body _) = concat ["(", showSyn args, " ", showSyn body, ")"]+++-- | An argument signature.+data ArgSig = ArgSig { stdArgs :: [ArgElt] -- ^ Standard positional arguments.+ , catchAllArg :: Maybe CatchArg -- ^ Argument that catches any remaining arguments after the positional arguments have been filled.+ } deriving (Show, Eq)+++data CatchArg = CatchArg+ { catchArgName :: LangIdent+ , catchArgConstr :: Maybe ConstrRef+ } deriving (Show, Eq)+++instance ShowSyn CatchArg where+ showSyn (CatchArg { catchArgName = n, catchArgConstr = c })+ = showSyn n ++ case c of+ Just constr -> ':' : showSyn constr+ Nothing -> ""+++-- | A single element of a parameter list, allows enforcing of+-- correct annotation types and parameter constraints.+data ArgElt = ArgElt+ { argEltType :: AnnType+ , argEltName :: LangIdent+ , argEltConstr :: Maybe ConstrRef+ } deriving (Show, Eq)+++instance ShowSyn ArgElt where+ showSyn (ArgElt {argEltType=typ+ , argEltName=name+ , argEltConstr=constr })+ = case typ of+ AnnFun -> "$"+ AnnLit -> "!"+ AnnAny -> ""+ ++ showSyn name ++ case constr of+ Just c -> ':' : showSyn c+ Nothing -> ""+++-- | Name referencing a function to be used as a parameter constraint.+--+-- Parameter-constraints perform run-time checks on arguments+-- passed to a function.+--+-- For example, if a function of the form @foo(x:\@largeInt)@+-- is called with some value @y@, the value of @y@ will be+-- evaluated and then passed to the function @largeInt@.+-- @largeInt@ should then return a boolean value stating whether+-- the value passed satisfies it's criteria. Failure to return+-- a boolean value will result in a fatal error.+-- If @largeInt@ returns @true@, then the function proceeds as normal,+-- otherwise an error is thrown.+--+-- Functions to be used as parameter-constraints must satisfy the following:+--+-- * Must be able to take 1 value on its own.+--+-- * Must return a true or false value when used as a constraint.+data ConstrRef = ConstrRef+ { getConstrRef :: LangIdent+ , constrRefArgs :: Maybe [Expr]+ }+ deriving (Show, Eq)+++instance ShowSyn ConstrRef where+ showSyn (ConstrRef {getConstrRef = name, constrRefArgs=a})+ = '@' : showSyn name ++ showRefArgs+ where+ showRefArgs = maybe "" showSynArgs a+++-- | Possible parameter restrictions provided in definition annotation.+--+-- As an example, in the function @foo(x)@, there+-- is no restriction on what @x@ is passed. However, in the+-- function @bar($x)@, @x@ must be a function if passed to @bar@,+-- if it is anything else an error will occur.+data AnnType = AnnFun | AnnLit | AnnAny+ deriving (Eq)+++instance Show AnnType where+ show AnnFun = "function"+ show AnnLit = "literal"+ show AnnAny = "any"+++-- | Represents the basic types that can be used in Angle.+--+-- The reason for the types being contained within one datatype+-- is to allow untyped expressions to exist in Angle, including+-- multi-type lists.+--+-- See 'ConstrRef' for a means of providing run-time parameter+-- constraints in Angle.+data LangLit = LitStr String -- ^ Strings.+ | LitInt Int -- ^ Integers, support at least the range -2^29 to 2^29-1.+ | LitFloat Double -- ^ Double-precision floating point value.+ | LitList [LangLit] -- ^ List of literal values. Values may be of different types.+ | LitBool Bool -- ^ Boolean value.+ | LitChar Char -- ^ Character literals, these cannot be specified by the programmer and are used internally+ -- by Angle.+ | LitRange LangLit (Maybe LangLit) (Maybe LangLit)+ | LitNull -- ^ Implicit value+ -- returned from any expression+ -- that fails to return a value+ -- explicitly.+ | LitLambda Lambda -- ^ A function without a name.+ | LitClosure Lambda+ | LitKeyword { getLitKeyword :: LangIdent }+ | LitHandle Handle+ deriving (Show, Eq)+++instance ShowSyn LangLit where+ showSyn (LitStr x) = show x+ showSyn (LitChar x) = show x+ showSyn (LitInt x) = show x+ showSyn (LitFloat x) = showFFloat Nothing x ""+ showSyn (LitList xs) = showSynList xs+ where showSynList = showSynSep "[" "]" ", "+ showSyn (LitBool x) = if x then "true" else "false"+ showSyn (LitRange x y z) = showRange+ where showRange+ = concat [ "("+ , showSyn x+ , ".."+ , maybe "" showSyn y+ , maybe "" ((".." ++) . showSyn) z+ , ")" ]++ showSyn LitNull = "null"+ showSyn (LitLambda x) = showSyn x+ showSyn (LitClosure x) = showSyn x+ showSyn (LitKeyword x) = ':' : showSyn x+ showSyn (LitHandle h) = show h+++-- | The types of the values that can be used in Angle.+--+-- The separation of the value containers ('LangLit') and+-- type representations allows untyped expressions to be+-- attained more easily.+data LangType = LTStr+ | LTChar+ | LTInt+ | LTFloat+ | LTList+ | LTBool+ | LTRange+ | LTNull+ | LTKeyword+ | LTLambda+ | LTHandle+ deriving (Eq)+++-- | Function for determining the type of a literal.+typeOf :: LangLit -> LangType+typeOf (LitStr _) = LTStr+typeOf (LitChar _) = LTChar+typeOf (LitInt _) = LTInt+typeOf (LitFloat _) = LTFloat+typeOf (LitList _) = LTList+typeOf (LitBool _) = LTBool+typeOf (LitRange{}) = LTRange+typeOf LitNull = LTNull+typeOf (LitLambda{}) = LTLambda+typeOf (LitClosure{}) = LTLambda+typeOf (LitKeyword _) = LTKeyword+typeOf (LitHandle _) = LTHandle+++-- | Determine the required annotation restriction of a+-- particular literal. See 'AnnType' for more information.+typeAnnOf :: LangLit -> AnnType+typeAnnOf (LitLambda{}) = AnnFun+typeAnnOf _ = AnnLit+++instance Show LangType where+ show LTList = "list"+ show LTBool = "boolean"+ show LTStr = "string"+ show LTInt = "integer"+ show LTFloat = "float"+ show LTNull = "null"+ show LTRange = "range"+ show LTLambda = "function"+ show LTKeyword = "keyword"+ show LTChar = "char"+ show LTHandle = "handle"+++-- | Expressions must be evaluable to some literal, although+-- in some cases they may evaluate to the null literal.+data Expr = ExprIdent LangIdent+ -- ^ 'LangIdent' when representing a variable.+ | ExprFunIdent LangIdent+ -- ^ 'LangIdent' when representing a function.+ | ExprLit LangLit -- ^ Expression wrapping a literal value.+ | ExprFunCall LangIdent Bool [Expr]+ | ExprLambdaCall Lambda [Expr]+ | ExprOp LangOp+ | ExprList [Expr]+ -- ^ An unevaluated list (see 'LitList').+ | ExprRange Expr (Maybe Expr) (Maybe Expr)+ -- ^ An unevaluated range (see 'LitRange').+ | ExprParamExpand LangIdent+ -- ^ Special form of expression that represents a+ -- catch parameter.+ deriving (Show, Eq)+++instance ShowSyn Expr where+ showSyn (ExprIdent x) = showSyn x+ showSyn (ExprLit x) = showSyn x+ showSyn (ExprFunCall n asClass es) = (if asClass then "@" else "") ++ showSyn n ++ showSynArgs es+ showSyn (ExprOp x) = showSyn x+ showSyn (ExprFunIdent x) = "$" ++ showSyn x+ showSyn (ExprList xs) = showSynList xs+ where showSynList = showSynSep "[" "]" ", "+ showSyn (ExprRange{}) = error "showSyn - cannot show unevaluated range"+ showSyn (ExprLambdaCall x xs) = showSyn (LitLambda x) ++ " : (" ++ showSynArgs xs ++ ")"+ showSyn (ExprParamExpand x) = ".." ++ showSyn x+++-- | Represents names that can be assigned values.+--+-- Each name can contain one literal value and one lambda (function).+-- When a name is being resolved, context and constraints expressed+-- by the programmer determine whether a name will resolve to the+-- contained value or lambda.+newtype LangIdent = LangIdent { getIdent :: String }+ deriving (Show, Eq, Ord)+++instance ShowSyn LangIdent where+ showSyn = getIdent+++instance ShowSyn ArgSig where+ showSyn (ArgSig args catchArg) =+ showSynSep "("+ (case catchArg of+ Nothing -> ")"+ Just x -> concat+ [ if not (null args)+ then ", .."+ else ".."+ , showSyn x+ , ")"]) ", " args+++-- | Two forms of operator exist in Angle:+data LangOp = SpecOp Op Expr+ -- ^ Special operators that can only be used in prefix+ -- and act upon a single expresson.+ | MultiOp Op [Expr]+ -- ^ Multi-operators that can take multiple values but+ -- must be enclosed within parentheses.+ deriving (Show, Eq)+++instance ShowSyn LangOp where+ showSyn (SpecOp o e) = showSyn o ++ showSyn e+ showSyn (MultiOp o es) = concat ["(", showSyn o, showSynOpList es]+++-- | Builtin operators.+data Op = OpAdd+ | OpAnd -- ^ Logical AND.+ | OpConcat+ | OpDiv+ | OpEq -- ^ Check equality.+ | OpGreater+ | OpGreaterEq+ | OpLess+ | OpLessEq+ | OpExp+ | OpMult+ | OpNeg+ | OpNot -- ^ Logical NOT.+ | OpOr -- ^ Logical OR.+ | OpSub+ | UserOp LangIdent+ deriving (Show, Eq)+++instance ShowSyn Op where+ showSyn OpAdd = "+"+ showSyn OpAnd = "&"+ showSyn OpConcat = "++"+ showSyn OpDiv = "/"+ showSyn OpEq = "=="+ showSyn OpGreater = ">"+ showSyn OpGreaterEq = ">="+ showSyn OpLess = "<"+ showSyn OpLessEq = "<="+ showSyn OpMult = "*"+ showSyn OpNeg = "-"+ showSyn OpNot = "^"+ showSyn OpOr = "|"+ showSyn OpSub = "-"+ showSyn OpExp = "**"+ showSyn (UserOp x) = showSyn x+++showLambdaFun :: Lambda -> String+showLambdaFun (Lambda {lambdaArgs=args, lambdaBody=body})+ = showSyn args ++ " " ++ showSyn body+++-- | True when passed the nullary literal.+isNull :: LangLit -> Bool+isNull LitNull = True+isNull _ = False+++-- | True if the type can be enumerated in Angle.+enumType :: LangLit -> Bool+enumType (LitInt _) = True+enumType (LitChar _) = True+enumType (LitFloat _) = True+enumType _ = False+++-- | True if all values in list have the specified type.+allType :: LangType -> [LangLit] -> Bool+allType t = all ((==t) . typeOf)
+ src/Angle/Types/Scope.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-|+Module : Angle.Types.Scope+Description : Defines functions for working with GenScopes.+Copyright : Copyright (C) 2015 Ben Moon+License : GNU GPL, version 3+Maintainer : GuiltyDolphin@gmail.com+Stability : alpha++Each variable in Angle belongs to a scope.++Each scope contains a reference to its parent scope and the binding+environment that maps variables to their respective values.++Each variable can have a function definition and a value definition,+which are resolved independently and at distinguishable times.++A variable is considered in-scope if it exists in the current scope+or any of the parent scopes.++The outer-most scope is called the global scope and is accessible+from all other parts of a program.+-}+module Angle.Types.Scope+ ( GenScope(..)+ , BindEnv(..)+ , VarVal(..)+ , bindEnvFromList+ , deleteLitFromScope+ , emptyScope+ , emptyVar+ , isDefinedIn+ , isOutermostScope+ , mergeScope+ , resolve+ , setVarFunInScope+ , setVarLitInScope+ , modifyOuterScope+ , modifyGlobalScope+ , globalScope+ ) where+++import Control.Monad+import qualified Data.Map as M+import Data.Maybe (isJust)+import Data.Function (on)+++-- | Convert a list to a binding environment.+bindEnvFromList :: (Ord n) => [(n, VarVal a)] -> BindEnv n a+bindEnvFromList = BindEnv . M.fromList+++emptyBindEnv :: BindEnv n a+emptyBindEnv = BindEnv M.empty+++-- | Binding environment.+newtype BindEnv n a = BindEnv+ { unBindEnv :: M.Map n (VarVal a) }+ deriving (Show, Eq)+++type BindMap n a = M.Map n (VarVal a)+++-- | Contains variable-value bindings, along with a reference+-- to a parent scope.+data GenScope n v f = Scope+ { outerScope :: Maybe (GenScope n v f) -- ^ Parent scope, if any.+ , valueBindings :: BindEnv n v+ , lambdaBindings :: BindEnv n f+ } deriving (Show, Eq)+++-- type GenScope n v f = (Ord n) => GScope n v f+++-- | True if the given scope has no parent scopes.+isOutermostScope :: GenScope n v f -> Bool+isOutermostScope s = case outerScope s of+ Nothing -> True+ Just _ -> False+++-- | The outermost scope of the given scope stack.+globalScope :: GenScope n v f -> GenScope n v f+globalScope sc@(Scope { outerScope = Nothing }) = sc+globalScope (Scope { outerScope = Just sc }) = globalScope sc+++-- | True if the scope contains a defition for the given+-- identifier.+isDefinedIn :: (Ord n) => (GenScope n v f -> BindEnv n a) -> n -> GenScope n v f -> Bool+isDefinedIn binds name scope = isJust $ lookupBind name $ binds scope+++onBind :: (BindMap n a -> b) -> BindEnv n a -> b+onBind f = f . unBindEnv+++withBind :: (BindMap n a -> BindMap n a) -> BindEnv n a -> BindEnv n a+withBind f = toBind . onBind f+++toBind :: BindMap n a -> BindEnv n a+toBind = BindEnv+++onBinds :: (BindMap n a -> BindMap n a -> BindMap n a) -> BindEnv n a -> BindEnv n a -> BindEnv n a+onBinds f x = toBind . (f `on` unBindEnv) x+++-- | Runs a function in the outer scope of that provided.+--+-- Returns `Nothing' if no outer scope exists.+withOuterScope :: GenScope n v f -> (GenScope n v f -> a) -> Maybe a+withOuterScope sc f = liftM f (outerScope sc)+++-- | Allows the modification of a parent scope without modifying+-- the current scope (bar the parent changing).+modifyOuterScope :: GenScope n v f -> (GenScope n v f -> GenScope n v f) -> GenScope n v f+modifyOuterScope sc parF =+ case outerScope sc of+ Nothing -> sc+ Just parS -> let newPar = parF parS in sc { outerScope = Just newPar }+++-- | Modifies the global scope while not affecting non-globals.+modifyGlobalScope :: GenScope n v f -> (GenScope n v f -> GenScope n v f) -> GenScope n v f+modifyGlobalScope sc globF =+ if isOutermostScope sc+ then globF sc+ else let (Just outer) = outerScope sc+ in sc { outerScope = Just $ modifyGlobalScope outer globF }+++-- | Finds the local-most GenScope that contains a definition+-- for the specified identifier.+innerScopeDefining :: (Ord n) => (GenScope n v f -> BindEnv n a) -> n -> GenScope n v f -> Maybe (GenScope n v f)+innerScopeDefining binds name scope+ = if isDefinedIn binds name scope+ then Just scope+ else join $ withOuterScope scope (innerScopeDefining binds name)+++-- | Retrieves the variable's definition from the local-most+-- scope in which it is defined.+--+-- Returns Nothing if no definition is found.+resolve :: (Ord n) => (GenScope n v f -> BindEnv n a) -> n -> GenScope n v f -> Maybe (VarVal a)+resolve binds name scope =+ case innerScopeDefining binds name scope of+ Nothing -> Nothing+ Just scope' -> fromCurrentScope binds scope'+ where+ fromCurrentScope b = lookupBind name . b+++-- | A scope with no parent or bindings.+emptyScope :: GenScope n v f+emptyScope = Scope {+ outerScope = Nothing+ , valueBindings = emptyBindEnv+ , lambdaBindings = emptyBindEnv+ }+++-- | Run a function over the bindings of a scope.+onLitBindings+ :: (BindEnv n v -> BindEnv n v) -> GenScope n v f -> GenScope n v f+onLitBindings f scope = scope { valueBindings = f $ valueBindings scope }+++onFunBindings+ :: (BindEnv n f -> BindEnv n f) -> GenScope n v f -> GenScope n v f+onFunBindings f scope = scope { lambdaBindings = f $ lambdaBindings scope }+++insertVar :: (Ord n) => n -> VarVal a -> BindEnv n a -> BindEnv n a+insertVar = insertBind+++-- | Set the value definition for the given variable in the given+-- scope.+setVarLitInScope :: (Ord n) => n -> VarVal v -> GenScope n v f -> GenScope n v f+setVarLitInScope name val = onLitBindings (insertVar name val)+++-- | Set the lambda definition for the given variable in the given+-- scope.+setVarFunInScope :: (Ord n) => n -> VarVal f -> GenScope n v f -> GenScope n v f+setVarFunInScope name val = onFunBindings (insertVar name val)++++-- | Merge the binding values of the scopes, favouring the first+-- when a definition exists in both, but always favouring a+-- definition over no definition.+mergeScope :: (Ord n) => GenScope n v f -> GenScope n v f -> GenScope n v f+mergeScope sc1 sc2+ = let nLits = mergeBinds `on` valueBindings+ nFuns = mergeBinds `on` lambdaBindings+ in sc1 { valueBindings = nLits sc1 sc2+ , lambdaBindings = nFuns sc1 sc2+ }+++-- | Remove the value binding of a variable from the given scope.+deleteLitFromScope :: (Ord n) => n -> GenScope n v f -> GenScope n v f+deleteLitFromScope = onLitBindings . deleteBind++++deleteBind :: (Ord n) => n -> BindEnv n a -> BindEnv n a+deleteBind = withBind . M.delete+++mergeBinds :: (Ord n) => BindEnv n a -> BindEnv n a -> BindEnv n a+mergeBinds = onBinds M.union+++lookupBind :: (Ord n) => n -> BindEnv n a -> Maybe (VarVal a)+lookupBind = onBind . M.lookup+++insertBind :: (Ord n) => n -> VarVal a -> BindEnv n a -> BindEnv n a+insertBind n = withBind . M.insert n+++-- | Represents a variable definition.+data VarVal a = VarVal+ { varDef :: Maybe a+ , varBuiltin :: Bool+ } deriving (Show, Eq, Ord)+++-- | Variable with no definitions.+emptyVar :: VarVal a+emptyVar = VarVal { varDef = Nothing+ , varBuiltin = False }
+ tests/Test/Angle/Exec/Exec.hs view
@@ -0,0 +1,270 @@+module Test.Angle.Exec.Exec+ ( tests+ ) where++import TestHelper+++appending :: [a] -> [[a]] -> [a]+appending x = concatMap (++x)+++setupAddF :: String+setupAddF = appending "\n" [defIsInt, defAddInts]+++defIsInt :: String+defIsInt = defun "isInt" "x" "return (== x asType(0, x));"++defAddInts :: String+defAddInts = defun "addInts" "x:@isInt, y:@isInt" "(+ x y);"+++defun :: String -> String -> String -> String+defun n a b = concat ["defun ", n, "(", a, ") ", b]+++checkRes :: String -> (LangLit -> Bool) -> Property+checkRes s r = monadicIO $ runEx s >>= (assert . r)+++checkFail :: String -> Property+checkFail s = expectFailure $ monadicIO $ runEx s+++checkResEq :: String -> LangLit -> Property+checkResEq s x = checkRes s (==x)+++testLess :: Int -> Int -> Property+testLess = binTest LitBool (<) "<"+++testGreater :: Int -> Int -> Property+testGreater = binTest LitBool (>) ">"+++testLessEq :: Int -> Int -> Property+testLessEq = binTest LitBool (<=) "<="+++testGreaterEq :: Int -> Int -> Property+testGreaterEq = binTest LitBool (>=) ">="+++testAdd :: NonEmptyList Int -> Property+testAdd (NonEmpty xs) = opTest LitInt sum "+" xs+++testAnd :: NonEmptyList Bool -> Property+testAnd (NonEmpty xs) = opTest LitBool and "&" xs+++testSub :: NonEmptyList Int -> Property+testSub (NonEmpty xs) = opTest LitInt (foldl1 (-)) "-" xs+++testMult :: NonEmptyList Int -> Property+testMult (NonEmpty xs) = opTest LitInt product "*" xs+++testNot :: Bool -> Property+testNot = opTestUnary LitBool not "^"+++testOr :: NonEmptyList Bool -> Property+testOr (NonEmpty xs) = opTest LitBool or "|" xs+++-- | Helper function for testing binary operators.+binTest ::+ (Show a, Show b) =>+ (b -> LangLit)+ -> (a -> a -> b)+ -> String -> a -> a+ -> Property+binTest t f op x y = checkResEq st (t $ f x y)+ where st = opElts op [show x, show y]+++opElts :: String -> [String] -> String+opElts op xs = concat [ "("+ , op, " "+ , appending " " (init xs)+ , last xs+ , ");"]+++opStr :: (a -> LangLit) -> String -> [a] -> String+opStr t op xs = concat [ "("+ , op, " "+ , appending " " (init xs')+ , last xs'+ , ");"]+ where xs' = map (showSyn . t) xs+++opTest ::+ (Show a) =>+ (a -> LangLit)+ -> ([a] -> a)+ -> String -> [a]+ -> Property+opTest t f op xs = checkResEq st (t $ f xs)+ where st = opStr t op xs+++opTestUnary :: (a -> LangLit) -> (a -> a) -> String -> a -> Property+opTestUnary t f op x = checkResEq st (t $ f x)+ where st = concat [op, showSyn $ t x, ";"]+++callShow :: (Show a) => String -> [a] -> String+callShow f xs = concat [ f, "("+ , concatMap ((++", ") . show) (init xs)+ , show (last xs)+ , ");"+ ]+++callShowSyn :: (ShowSyn a) => String -> [a] -> String+callShowSyn f xs = concat [ f, "("+ , concatMap ((++", ") . showSyn) (init xs)+ , showSyn (last xs)+ , ");"+ ]++testBuiltinLength :: TinyList LangLit -> Property+testBuiltinLength (TinyList xs) = checkResEq toRun $ LitInt (length xs)+ where toRun = callShowSyn "length" [LitList xs]+++testBuiltinLengthRange :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property+testBuiltinLengthRange (NonNegative x) (NonNegative y) (NonNegative z) =+ y > x && z > x ==> checkResEq toRun $ LitInt (length [x,z..y])+ where toRun = callShowSyn "length" [LitRange (LitInt x) (Just $ LitInt y) (Just $ LitInt z)]+++testBuiltinIsNull :: LangLit -> Property+testBuiltinIsNull x = checkResEq toRun $ LitBool (x == LitNull)+ where+ toRun = callShowSyn "isNull" [x]+++testBuiltinIndexBasic :: TinyList LangLit -> NonNegative Int -> Property+testBuiltinIndexBasic (TinyList xs) (NonNegative x) = x < length xs+ ==> checkResEq toRun $ xs !! x+ where+ toRun = callShowSyn "index" [LitInt x, LitList xs]+++testBuiltinStr :: LangLit -> Property+testBuiltinStr x = checkResEq toRun $ case x of+ LitStr _ -> x+ LitChar c -> LitStr [c]+ r@(LitRange{}) -> LitStr $ showSyn r+ x' -> LitStr (showSyn x')+ where+ toRun = callShowSyn "str" [x]++++testClassAdd :: LangLit -> LangLit -> Property+testClassAdd (LitInt x) (LitInt y) = checkResEq toRun $ LitInt (x + y)+ where toRun = setupAddF ++ callShow "addInts" [x, y]+testClassAdd x y = checkFail toRun+ where toRun = setupAddF ++ callShowSyn "addInts" [x, y]+++testReturnSimple :: NonLambda -> Property+testReturnSimple (NonLambda x) = checkResEq toRun x+ where toRun = setupReturnSimple ++ callShowSyn "returnSimple" [x]+ setupReturnSimple = defun "returnSimple" "x" "return x;"+++newtype NonLambda = NonLambda LangLit+ deriving (Show)++instance Arbitrary NonLambda where+ arbitrary = liftM NonLambda $ arbitrary `suchThat`+ (\x -> case x of+ LitLambda{} -> False+ _ -> True)++testReturnIfEmbedded :: Bool -> NonLambda -> NonLambda -> Property+testReturnIfEmbedded p (NonLambda x) (NonLambda y) | p = checkResEq toRun x+ | otherwise = checkResEq toRun y+ where toRun = setupReturnIfEmbedded ++ callShowSyn "returnIfEmbedded" [LitBool p, x, y]+ setupReturnIfEmbedded = defun "returnIfEmbedded" "p, x, y" "if p then return x; else return y;"+++testForLoopSimple :: TinyList LangLit -> Property+testForLoopSimple (TinyList xs) = checkResEq toRun (LitList xs)+ where toRun = for "i" (showSyn $ LitList xs) "i;"+++testForLoopBreakSimple :: NonEmptyList LangLit -> Property+testForLoopBreakSimple (NonEmpty xs) = checkResEq toRun (head xs)+ where+ toRun = for "i" (showSyn $ LitList xs) (multiStmt ["i;", "break;"])+++testForLoopBreakWithValue :: NonEmptyList LangLit -> LangLit -> Property+testForLoopBreakWithValue (NonEmpty xs) y = checkResEq toRun y+ where+ toRun = for "i" (showSyn $ LitList xs) (multiStmt ["i;", "break " ++ showSyn y ++ ";"])+++multiStmt :: [String] -> String+multiStmt xs = concat ["{", concat xs, "}"]+++for :: String -> String -> String -> String+for ident expr body = concat [ "for ", ident, " in "+ , expr, " do ", body]+++tests :: [TestTree]+tests = [ testGroup "filter tests"+ [+ ]+ , testGroup "basic operators"+ [ testProperty "less" testLess+ , testProperty "add" testAdd+ , testProperty "mult" testMult+ , testProperty "not" testNot+ , testProperty "sub" testSub+ , testProperty "and" testAnd+ , testProperty "or" testOr+ , testProperty "lessEq" testLessEq+ , testProperty "greaterEq" testGreaterEq+ , testProperty "greater" testGreater+ ]+ , testGroup "classes"+ [ testProperty "isAdd" testClassAdd+ ]+ , testGroup "basic functions"+ [ testProperty "returnSimple" testReturnSimple+ , testProperty "returnIfEmbedded" testReturnIfEmbedded+ ]+ , testGroup "structures"+ [ testProperty "simple for-loop" testForLoopSimple+ , testProperty "for loop break - simple" testForLoopBreakSimple+ , testProperty "for loop break - value" testForLoopBreakWithValue+ ]+ , testGroup "builtin functions"+ [ testProperty "length" testBuiltinLength+ , testProperty "length with range" testBuiltinLengthRange+ , testProperty "isNull" testBuiltinIsNull+ , testProperty "index - basic" testBuiltinIndexBasic+ , testProperty "str" testBuiltinStr+ ]+ ]++++++++
+ tests/Test/Angle/Exec/Operations.hs view
@@ -0,0 +1,28 @@+module Test.Angle.Exec.Operations+ ( tests+ ) where++import Test.QuickCheck++import Angle.Exec.Operations+import Angle.Types.Lang+import TestHelper+++testAndLitBool :: [Bool] -> Property+testAndLitBool xs = monadicIO $ do+ res <- run $ runExec $ andLit (map LitBool xs)+ assertEqual (LitBool $ and xs) res+++tests :: [TestTree]+tests = [ testGroup "add"+ [+ ]+ , testGroup "and"+ [ testProperty "andLit (with bools)" testAndLitBool+ ]+ ]+++
+ tests/Test/Angle/Exec/Types.hs view
@@ -0,0 +1,31 @@+module Test.Angle.Exec.Types+ ( tests+ ) where+++import TestHelper++import Angle.Exec.Types.Internal+++testFromIterInt :: RangeTriple Int -> Property+testFromIterInt (RangeTriple (x,y,z)) = monadicIO $ run (runExec (fromIter range)) >>= assertEqual expect+ where range = LitRange (LitInt x) (Just $ LitInt y) (Just $ LitInt z)+ expect = map LitInt [x,z..y]+++newtype RangeTriple a = RangeTriple (a, a, a)+ deriving (Show, Eq, Ord)+++instance (Enum a, Arbitrary a) => Arbitrary (RangeTriple a) where+ arbitrary = liftM RangeTriple $ suchThat arbitrary checkRange+ where+ checkRange (x1,y1,z1) = not ((y' > x' || y' == x') && (z' == x'))+ where+ [x', y', z'] = map fromEnum [x1,y1,z1]+++tests :: [TestTree]+tests = [ testProperty "testFromIter - range int int int" testFromIterInt+ ]
+ tests/Test/Angle/Parse/Parser.hs view
@@ -0,0 +1,131 @@+module Test.Angle.Parse.Parser+ ( tests+ ) where++import Angle.Parse.Parser.Internal+import qualified Test.QuickCheck.Property as P+import Angle.Types.Lang+import TestHelper+++testShowSynStmt :: Stmt -> Bool+testShowSynStmt x = showSynTest x stmt+++testShowSynSingStmt :: SingStmt -> Bool+testShowSynSingStmt x = showSynTest x singStmt+++testShowSynLangStruct :: LangStruct -> P.Result+testShowSynLangStruct x = prettySyn x langStruct+++testShowSynExpr :: Expr -> P.Result+testShowSynExpr x = prettySyn x expr+++testShowSynLambda :: Lambda -> P.Result+testShowSynLambda x = prettySyn x lambda+++showSynTest :: (ShowSyn a, Eq a) => a -> Parser a -> Bool+showSynTest x sc = evalParse (showSyn x) sc == Right x+++prettySyn :: (ShowSyn a, Eq a) => a -> Parser a -> P.Result+prettySyn = withPretty f p+ where p x sc = either (const $ "Could not parse: \n" ++ showSyn x)+ showSyn (evalParse (showSyn x) sc)+ f = showSynTest+++withPretty :: (a -> Parser b -> Bool) -- ^ Test function to apply+ -> (a -> Parser b -> String) -- ^ Prettify function+ -> a -> Parser b -> P.Result+withPretty f pretty x sc = P.result+ { P.ok = Just b+ , P.reason = if b+ then ""+ else pretty x sc+ }+ where b = f x sc+++escapedStr :: String -> String+escapedStr xs = "\"" ++ xs ++ "\""++++newtype NoQuoteString = NoQuoteString String+ deriving (Show, Eq)++instance Arbitrary NoQuoteString where+ arbitrary = liftM NoQuoteString $ suchThat arbitrary ("\"" `noneElem`)+++testLitStrEmpty :: Bool+testLitStrEmpty = evalParse "\"\"" litStr == Right (LitStr "")+++testLitStr :: String -> Property+testLitStr x = "\"\\" `noneElem` x ==> litStrShow x litStr+++noneElem :: (Eq a) => [a] -> [a] -> Bool+noneElem xs ys = all (`notElem` ys) xs+++litStrShow :: String -> Parser LangLit -> P.Result+litStrShow = withPretty f p+ where f x sc = evalParse (escapedStr x) sc == Right (LitStr x)+ p x sc = either (const "got an error!\n") showSyn (evalParse (escapedStr x) sc)+++testLitInt :: Int -> Bool+testLitInt x = evalParse (show x) litInt == Right (LitInt x)+++testLitBool :: Bool+testLitBool = evalParse "true" litBool == Right (LitBool True)+ && evalParse "false" litBool == Right (LitBool False)+++testEmptyCall :: Bool+testEmptyCall = evalParse "foo()" exprFunCall+ == Right (ExprFunCall (LangIdent "foo") False [])+++testOpAdd :: Bool+testOpAdd = evalParse "(+ 1 2)" langOp+ == Right (MultiOp OpAdd [ExprLit (LitInt 1), ExprLit (LitInt 2)])+++testOpNeg :: Bool+testOpNeg = evalParse "-x" langOp == Right (SpecOp OpNeg (ExprIdent (LangIdent "x")))+++tests :: [TestTree]+tests = [ testGroup "literals"+ [ testProperty "boolean" testLitBool+ , testProperty "integer" testLitInt+ , testProperty "string" testLitStr+ , testProperty "empty string" testLitStrEmpty+ ]+ , testGroup "functions"+ [ testProperty "no args from empty call" $ once testEmptyCall+ ]+ , testGroup "operators"+ [ testProperty "addition operator" $ once testOpAdd+ , testProperty "negation operator" $ once testOpNeg+ ]+ , localOption (QuickCheckMaxSize 10) $+ testGroup "show syntax"+ [ localOption (QuickCheckMaxSize 9) $+ testProperty "Stmt" testShowSynStmt+ , testProperty "SingStmt" testShowSynSingStmt+ , localOption (QuickCheckMaxSize 9) $+ testProperty "LangStruct" testShowSynLangStruct+ , testProperty "Expr" testShowSynExpr+ , localOption (QuickCheckMaxSize 10) $ testProperty "Lambda" testShowSynLambda+ ]+ ]
+ tests/Test/Angle/Parse/Token.hs view
@@ -0,0 +1,56 @@+module Test.Angle.Parse.Token+ ( tests+ ) where++import Numeric (showFFloat)++import Angle.Parse.Token+import TestHelper+++testTokInt :: Int -> Bool+testTokInt x = evalParse (show x) tokInt == Right x+++testTokFloat :: Double -> Bool+testTokFloat x = evalParse (showFFloat Nothing x "") tokFloat == Right x+++testTokChar :: Char -> Bool+testTokChar c = evalParse (show c) tokChar == Right c+++testTokCharAscii :: AsciiChar -> Bool+testTokCharAscii (AsciiChar c) = evalParse (show c) tokChar == Right c+++++newtype AsciiChar = AsciiChar Char+ deriving (Show, Eq, Ord)+++instance Arbitrary AsciiChar where+ arbitrary = liftM AsciiChar (elements [toEnum 0..toEnum 128])+++tests :: [TestTree]+tests = [ testGroup "numbers"+ [ testProperty "integer" testTokInt+ , testProperty "float" testTokFloat+ ]+ , testGroup "strings and characters"+ [ testProperty "tokChar" testTokChar+ , testProperty "tokCharAscii" testTokCharAscii+ ]+ ]++++++++++
+ tests/Test/Angle/Types/Scope.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Angle.Types.Scope+ ( tests+ ) where++import TestHelper+++tests :: [TestTree]+tests = [ testGroup "outermostScope"+ [+ ]+ , testGroup "resolve"+ [+ ]+ ]
+ tests/TestHelper.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module TestHelper+ ( module Test.Tasty+ , module Test.Tasty.QuickCheck+ , module Angle.Types.Lang+ , assert+ , Parser+ , evalParse+ , monadicEither+ , liftM+ , monadicIO+ , assertEqual+ , run+ , maxSized+ , runExecIOBasic+ , runExec+ , runEx+ , SmallList(..)+ , TinyList(..)+ ) where+++import Control.Applicative ((<*>), (<$>))+import Control.Monad.State+import Data.Char (isAlpha, isAlphaNum)+import qualified Data.Map as M++import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++import Angle.Parse.Helpers (evalParse, Parser)+import Angle.Parse.Token (keywords)+import Angle.Exec.Types.Internal+import Angle.Scanner (SourcePos(..))+import Angle.Types.Lang+import Angle.Types.Scope+import Angle.Parse.Parser (program)+import Angle.Exec.Exec (execStmt)+++instance Arbitrary LangLit where+ arbitrary = frequency+ [ (7, liftArby (LitStr . getValidLitStr))+ , (9, liftArby LitInt)+ , (9, liftArby LitFloat)+ , (1, liftM LitList (liftArby getTinyList))+ , (9, liftArby LitBool)+ , (1, arbyRange)+ , (6, liftArby LitChar)+ , (1, liftArby LitLambda)+ --, (9, return LitNull)+ ]+ where arbyRange = do+ x <- suchThat arbitrary enumType+ [y,z] <- suchThat (vector 2) (allType (typeOf x))+ (b1, b2) <- arbitrary+ let y' = if b1 then Just y else Nothing+ z' = if b2 then Just z else Nothing+ return $ LitRange x y' z'+++instance Arbitrary SingStmt where+ arbitrary = frequency+ [ (7, liftArby2 StmtAssign)+ , (2, liftArby StmtStruct)+ , (5, liftArby StmtExpr)+ , (8, liftArby StmtReturn)+ ]+ shrink (StmtAssign x y) =+ shrink2 StmtAssign x y+ shrink (StmtStruct x) = shrink1 StmtStruct x+ shrink (StmtExpr x) = shrink1 StmtExpr x+ shrink (StmtReturn x) = shrink1 StmtReturn x+ shrink _ = undefined+++instance Arbitrary LangStruct where+ arbitrary = frequency+ [ (3, liftArby3 StructFor)+ , (3, liftArby2 StructWhile)+ , (3, liftM3 StructIf arbitrary (liftArby MultiStmt) arbitrary)+ , (1, liftArby2 StructDefun)+ ]+ shrink (StructFor x y z) = shrink3 StructFor x y z+ shrink (StructWhile x y) = shrink2 StructWhile x y+ shrink (StructIf x y z) = shrink3 StructIf x y z+ shrink (StructDefun x y) = shrink2 StructDefun x y+ shrink (StructTryCatch x y) = shrink2 StructTryCatch x y+++instance Arbitrary Lambda where+ arbitrary = do+ args <- arbitrary+ body <- arbitrary+ return Lambda { lambdaArgs=args, lambdaBody=body, lambdaScope = Nothing}+ shrink (Lambda x y z) = shrink3 Lambda x y z+++instance Arbitrary Expr where+ arbitrary = frequency+ [ (15, liftArby ExprIdent)+ , (9, liftArby ExprLit)+ , (1, liftM3 ExprFunCall arbitrary arbitrary (liftArby getTinyList))+ , (4, liftArby ExprOp)+ , (4, liftArby ExprFunIdent)+ ]+++instance Arbitrary ArgSig where+ arbitrary = do+ args <- liftArby getTinyList+ catchArg <- arbitrary+ return ArgSig { Angle.Types.Lang.stdArgs = args, catchAllArg = catchArg }+ shrink (ArgSig x y) = shrink2 ArgSig x y+++instance Arbitrary ArgElt where+ arbitrary = liftArby3 ArgElt+ shrink (ArgElt x y z) = shrink3 ArgElt x y z+++instance Arbitrary CatchArg where+ arbitrary = liftArby2 CatchArg+++shrink1 :: Arbitrary a => (a -> b) -> a -> [b]+shrink1 f x = map f (shrink x)+++shrink2 :: (Arbitrary a, Arbitrary b) => (a -> b -> c) -> a -> b -> [c]+shrink2 f x y = zipWith f (shrink x) (shrink y)+++shrink3 :: (Arbitrary c, Arbitrary b, Arbitrary a) =>+ (a -> b -> c -> d) -> a -> b -> c -> [d]+shrink3 f x y z = zipWith3 f (shrink x) (shrink y) (shrink z)+++instance Arbitrary ConstrRef where+ arbitrary = liftArby2 ConstrRef+ shrink (ConstrRef x y) = shrink2 ConstrRef x y+++instance Arbitrary AnnType where+ arbitrary = elements [AnnFun, AnnLit]+ shrink AnnFun = [AnnLit]+ shrink AnnLit = [AnnFun]+ shrink _ = undefined+++instance Arbitrary Stmt where+ arbitrary = frequency+ [ (9, liftArby2 SingleStmt)+ , (1, liftM MultiStmt (liftArby getTinyList))+ ]+ shrink (SingleStmt x p) = shrink2 SingleStmt x p+ shrink (MultiStmt xs) = shrink1 MultiStmt xs+++instance Arbitrary LangOp where+ arbitrary = frequency+ [ (7, liftM SpecOp (liftArby getSpecOp) >>= checkOp)+ , (3, liftM MultiOp (liftArby getMultiOp) >>= liftArby)+ ]+ where checkOp f = do -- Prevent -ve on numbers+ x <- arbitrary+ case f x of+ (SpecOp OpNeg (ExprLit (LitInt _))) -> arbitrary+ (SpecOp OpNeg (ExprLit (LitFloat _))) -> arbitrary+ r -> return r++ shrink (SpecOp x y) = shrink2 SpecOp x y+ shrink (MultiOp x ys) = shrink2 MultiOp x ys+++instance Arbitrary Op where+ arbitrary = oneof [ liftArby getMultiOp+ , liftArby getSpecOp]++++liftArby :: (Arbitrary a) => (a -> b) -> Gen b+liftArby f = liftM f arbitrary+++liftArby2 :: (Arbitrary a, Arbitrary b) => (a -> b -> c) -> Gen c+liftArby2 f = liftM2 f arbitrary arbitrary+++liftArby3 :: (Arbitrary a, Arbitrary b, Arbitrary c) => (a -> b -> c -> d) -> Gen d+liftArby3 f = liftM3 f arbitrary arbitrary arbitrary+++newtype ValidLitStr =+ ValidLitStr { getValidLitStr :: String }+++instance Arbitrary ValidLitStr where+ arbitrary = liftArby (ValidLitStr . filter (/='"'))+++instance Arbitrary LangIdent where+ arbitrary = liftM LangIdent $ validIdent `suchThat` isValidIdent+ shrink (LangIdent x) = map LangIdent (filter isValidIdent (shrink x))+++validIdent :: Gen String+validIdent = (:) <$> chooseAlpha <*> listOf chooseAlphaNum+ where chooseAlpha = oneof [choose ('a','z'), choose ('A','Z')]+ chooseDigit = choose ('0','9')+ chooseAlphaNum = oneof [chooseAlpha, chooseDigit]+++newtype SpecOp = ArbySpecOp { getSpecOp :: Op }+++newtype MultiOp = ArbyMultiOp { getMultiOp :: Op }+++instance Arbitrary SpecOp where+ arbitrary = elements $ map ArbySpecOp [OpNeg, OpNot]+++instance Arbitrary MultiOp where+ arbitrary = elements $ map ArbyMultiOp+ [ OpAdd+ , OpAnd+ , OpConcat+ , OpDiv+ , OpEq+ , OpGreater+ , OpGreaterEq+ , OpLess+ , OpLessEq+ , OpMult+ , OpOr+ , OpSub+ ]+++newtype ValidComment = ValidComment String+++instance Arbitrary ValidComment where+ arbitrary = liftM ValidComment $ arbitrary `suchThat` isValidComment+ where isValidComment x | '\n' `elem` x = False+ | otherwise = True+++maxSmallListLength :: Int+maxSmallListLength = 50+++maxTinyListLength :: Int+maxTinyListLength = 10+++newtype SmallList a = SmallList { getSmallList :: [a] }+ deriving (Show)+++newtype TinyList a = TinyList { getTinyList :: [a] }+ deriving (Show)+++instance (Arbitrary a) => Arbitrary (SmallList a) where+ arbitrary = sized $ \s -> do+ n <- choose (0,s`min`maxSmallListLength)+ xs <- vector n+ return (SmallList xs)+ shrink (SmallList xs) = shrink1 SmallList xs+++instance (Arbitrary a) => Arbitrary (TinyList a) where+ arbitrary = sized $ \s -> do+ n <- choose (0,s`min`maxTinyListLength)+ xs <- vector n+ return (TinyList xs)+ shrink (TinyList xs) = shrink1 TinyList xs+++instance (Arbitrary a) => Arbitrary (BindEnv LangIdent a) where+ arbitrary = liftArby bindEnvFromList+ shrink (BindEnv x) = shrink1 bindEnvFromList (M.toList x)+++instance (Arbitrary a) => Arbitrary (VarVal a) where+ arbitrary = liftArby2 VarVal+ shrink (VarVal x y) = shrink2 VarVal x y+++instance Arbitrary Scope where+ arbitrary = liftArby3 Scope+ shrink (Scope w x y) = shrink3 Scope w x y+++-- | Extracts a property from monadic Either code, giving+-- a failing property if the result is a Left.+monadicEither :: PropertyM (Either e) a -> Property+monadicEither = monadic (\e -> case e of+ Left _ -> property False+ Right r -> r)+++runExec :: ExecIO a -> IO a+runExec e = do+ x <- runExecIOBasic e+ case x of+ Left _ -> fail "runExec failed"+ Right r -> return r+++runEx :: String -> PropertyM IO LangLit+runEx s = let (Right r) = evalParse s program in run $ runExec $ execStmt r+++instance Arbitrary LangType where+ arbitrary = elements langTypes+ shrink x = filter (/=x) langTypes+++langTypes :: [LangType]+langTypes = [LTStr, LTInt, LTFloat, LTList+ , LTBool, LTRange, LTNull ]+++instance Arbitrary SourceRef where+ arbitrary = do+ start <- arbitrary+ end <- arbitrary+ return $ SourceRef (start, end)+ shrink (SourceRef x) = shrink1 SourceRef x+++instance Arbitrary SourcePos where+ arbitrary = do+ f <- liftArby getPositive+ s <- liftArby getPositive+ t <- liftArby getPositive+ return $ SourcePos (f, s, t)+ shrink (SourcePos x) = shrink1 SourcePos x++assertEqual :: (Monad m, Eq a) => a -> a -> PropertyM m ()+assertEqual x = assert . (==x)+++maxSized :: (Testable prop) => Int -> prop -> Property+maxSized x = mapSize (min x)+++isValidIdent :: String -> Bool+isValidIdent [] = False+isValidIdent xs | xs `elem` keywords = False+isValidIdent (x:xs) = isAlpha x && all isAlphaNum xs
+ tests/TestSuite.hs view
@@ -0,0 +1,37 @@+module Main+ ( main+ ) where++import TestHelper+import qualified Test.Angle.Parse.Helpers as Helpers+import qualified Test.Angle.Parse.Parser as Parser+import qualified Test.Angle.Parse.Token as Token+import qualified Test.Angle.Exec.Operations as Operations+import qualified Test.Angle.Types.Scope as Scope+import qualified Test.Angle.Exec.Exec as Exec+import qualified Test.Angle.Exec.Types as ExecTypes+++main :: IO ()+main = defaultMain allTests+++-- | Convert seconds into microseconds+toMicroSeconds :: Integer -> Integer+toMicroSeconds n = n*10^(6::Integer)+++allTests :: TestTree+allTests = localOption (Timeout (toMicroSeconds 3) "") $+ testGroup "all tests"+ [ testGroup "helpers tests" Helpers.tests+ , localOption (QuickCheckMaxSize 10) $+ testGroup "lexer tests" Parser.tests+ , testGroup "operations tests" Operations.tests+ , localOption (QuickCheckMaxSize 10) $+ testGroup "scope tests" Scope.tests+ , testGroup "token tests" Token.tests+ , localOption (QuickCheckMaxSize 10) $+ testGroup "exec tests" Exec.tests+ , testGroup "exec-types tests" ExecTypes.tests+ ]