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