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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# 🧶🧵🧶 zwirn 🧶🧵🧶 + +zwirn is a live coding language for playing with nested functions of time. + +## Inspiration + +zwirn is an experiment in making the pattern language [TidalCycles](https://tidalcycles.org/) into a small functional language of it's own. while zwirn's internals are quite different from Tidal's, zwirns design owes almost everything to tidals design by [Alex McLean](https://slab.org/). + +the internal representation of signals of time was implemented together (and parallel) with [Julian Rohrhuber](https://wertlos.org/~rohrhuber/), in an effort to port tidal to SuperCollider. This can be found in the seperate haskell library [zwirn-core](https://lab.al0.de/martin/zwirn-core). + +the implementation of the compiler is inspired by the excellent [Write You a Haskell](https://github.com/sdiehl/write-you-a-haskell) by Stephen Diehl. + +## Installing zwirn + +There are currently two ways to play with zwirn: + * [zwirnzi](https://github.com/polymorphicengine/zwirnzi) - the zwirn zompiler-interpreter + * [zwirn-loom](https://github.com/polymorphicengine/zwirn-loom) - a compiler-interpreter for zwirn with an experimental editor interface + +Zwirnzi is meant to serve as a way to play with zwirn in an editor of your choice, currently there are no official editor extensions - but it shouldn't be too hard to implement one. This means that zwirn-loom is the best way to play with zwirn at the moment. + +## Limitations + +due to the representation of signals and the way they are queried, there can only be a limited amount of triggers per cycle, if this number is exceeded zwirn fails to find any triggers. Currently the threshold seems to be at 500 triggers per cycle: + +while ``` fast 499 $ s "bd" ``` works as expected, ``` fast 500 $ s "bd" ``` is silent. if you would like to increase the amount of trigger per *second* (not cycle!), increase the cycles per second, for example by running ``` :cps 1 ```. + +## Documentation + +documentation for zwirn is still in progress and available [here](https://github.com/polymorphicengine/zwirn/wiki), feel free to drop me a message if you have any questions. diff --git a/src/Zwirn/Language.hs b/src/Zwirn/Language.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language.hs @@ -0,0 +1,44 @@ +module Zwirn.Language + ( module Zwirn.Language.Block, + module Zwirn.Language.Compiler, + module Zwirn.Language.Lexer, + module Zwirn.Language.Parser, + module Zwirn.Language.Pretty, + module Zwirn.Language.Simple, + module Zwirn.Language.Syntax, + module Zwirn.Language.TypeCheck.Constraint, + module Zwirn.Language.Environment, + module Zwirn.Language.TypeCheck.Infer, + module Zwirn.Language.TypeCheck.Types, + ) +where + +import Zwirn.Language.Block +import Zwirn.Language.Compiler +import Zwirn.Language.Environment +import Zwirn.Language.Lexer +import Zwirn.Language.Parser +import Zwirn.Language.Pretty +import Zwirn.Language.Simple +import Zwirn.Language.Syntax +import Zwirn.Language.TypeCheck.Constraint +import Zwirn.Language.TypeCheck.Infer +import Zwirn.Language.TypeCheck.Types + +{- + Language.hs - re-exports of all zwirn language modules + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} diff --git a/src/Zwirn/Language/Block.hs b/src/Zwirn/Language/Block.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Block.hs @@ -0,0 +1,44 @@ +module Zwirn.Language.Block + ( Block (..) + , BlockError + , getBlock + , getLn + ) where + +{- + Block.hs - parsing blocks of code and getting blocks at a specific line + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Text as Text (Text, lines) + +data Block = Block {bStart :: Int + ,bEnd :: Int + ,bContent :: Text + } deriving (Show, Eq) + +type BlockError = String + +getBlock :: Int -> [Block] -> Either BlockError Block +getBlock _ [] = Left "no block of code at current line" +getBlock num (block@(Block n1 n2 _):bs) = if n1 <= num && num <= n2 + then Right block + else getBlock num bs + +getLn :: Int -> [Block] -> Either BlockError Text +getLn i bs = do + (Block start _ cont) <- getBlock i bs + return $ (Text.lines cont)!!(i-start) diff --git a/src/Zwirn/Language/Builtin/Internal.hs b/src/Zwirn/Language/Builtin/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Builtin/Internal.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Zwirn.Language.Builtin.Internal where + +import qualified Data.Map as Map +import Data.String +import Data.Text (Text, pack) +import Zwirn.Language.Environment +import Zwirn.Language.Evaluate hiding (insert) +import Zwirn.Language.Parser (parseScheme) +import Zwirn.Language.TypeCheck.Types + +instance IsString Scheme where + fromString s = fromEither $ parseScheme (pack s) + where + fromEither (Right r) = r + fromEither (Left e) = error e + +(===) :: Text -> Expression -> Map.Map Text Expression +(===) = Map.singleton + +(<::) :: Map.Map Text Expression -> Scheme -> Map.Map Text (Expression, Scheme) +(<::) x s = fmap (\l -> (l, s)) x + +(--|) :: Map.Map Text (Expression, Scheme) -> Text -> Map.Map Text AnnotatedExpression +(--|) n t = fmap (\(x, s) -> Annotated x s (Just t)) n + +noDesc :: Map.Map Text (Expression, Scheme) -> Map.Map Text AnnotatedExpression +noDesc = fmap (\(x, s) -> Annotated x s Nothing) diff --git a/src/Zwirn/Language/Builtin/Parameters.hs b/src/Zwirn/Language/Builtin/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Builtin/Parameters.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zwirn.Language.Builtin.Parameters where + +import qualified Data.Map as Map +import Data.Text (Text) +import Zwirn.Core.Map +import Zwirn.Language.Builtin.Internal +import Zwirn.Language.Environment +import Zwirn.Language.Evaluate (Expression, Zwirn, toExp) + +builtinParams :: Map.Map Text AnnotatedExpression +builtinParams = addAliases aliases $ Map.unions [builtinTextParams, builtinNumberParams, builtinIntParams] + +builtinTextParams :: Map.Map Text AnnotatedExpression +builtinTextParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Text -> Zwirn Expression) <:: "Text -> Map") textParams + +builtinNumberParams :: Map.Map Text AnnotatedExpression +builtinNumberParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Double -> Zwirn Expression) <:: "Number -> Map") numberParams + +builtinIntParams :: Map.Map Text AnnotatedExpression +builtinIntParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Int -> Zwirn Expression) <:: "Number -> Map") intParams + +textParams :: [Text] +textParams = ["s", "unit", "vowel", "toArg"] + +intParams :: [Text] +intParams = ["cut", "orbit"] + +numberParams :: [Text] +numberParams = + [ "accelerate", + "amp", + "attack", + "bandf", + "bandq", + "begin", + "binshift", + "ccn", + "ccv", + "channel", + "coarse", + "comb", + "crush", + "cutoff", + "decay", + "delay", + "delaytime", + "detune", + "distort", + "djf", + "dry", + "dur", + "end", + "enhance", + "expression", + "fadeInTime", + "fadeTime", + "freeze", + "freq", + "from", + "fshift", + "gain", + "gate", + "harmonic", + "hbrick", + "hcutoff", + "hold", + "hresonance", + "imag", + "krush", + "lagogo", + "lbrick", + "legato", + "leslie", + "lock", + "midibend", + "miditouch", + "modwheel", + "n", + "note", + "nudge", + "octave", + "octer", + "octersub", + "octersubsub", + "offset", + "overgain", + "overshape", + "pan", + "panorient", + "panspan", + "pansplay", + "panwidth", + "partials", + "phaserdepth", + "phaserrate", + "rate", + "real", + "release", + "resonance", + "ring", + "ringdf", + "ringf", + "room", + "sagogo", + "scram", + "shape", + "size", + "slide", + "smear", + "speed", + "squiz", + "sustain", + "sustainpedal", + "timescale", + "timescalewin", + "to", + "tremolodepth", + "tremolorate", + "triode", + "tsdelay", + "velocity", + "voice", + "waveloss", + "xsdelay" + ] + +aliases :: [(Text, Text)] +aliases = + [ ("sound", "s"), + ("voi", "voice"), + ("up", "n"), + ("tremr", "tremolorate"), + ("tremdp", "tremolodepth"), + ("sz", "size"), + ("sus", "sustain"), + ("sld", "slide"), + ("scr", "scrash"), + ("rel", "release"), + ("por", "portamento"), + ("phasr", "phaserrate"), + ("phasdp", "phaserdepth"), + ("number", "n"), + ("lpq", "resonance"), + ("lpf", "cutoff"), + ("hpq", "hresonance"), + ("hpf", "hcutoff"), + ("gat", "gate"), + ("fadeOutTime", "fadeTime"), + ("dt", "delaytime"), + ("dfb", "delayfeedback"), + ("det", "detune"), + ("delayt", "delaytime"), + ("delayfb", "delayfeedback"), + ("ctf", "cutoff"), + ("bpq", "bandq"), + ("bpf", "bandf"), + ("att", "attack") + ] + +addAliases :: [(Text, Text)] -> Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression +addAliases as x = Map.unions $ map look as ++ [x] + where + look (y, n) = case Map.lookup n x of + Just a -> Map.singleton y a + Nothing -> Map.empty diff --git a/src/Zwirn/Language/Builtin/Prelude.hs b/src/Zwirn/Language/Builtin/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Builtin/Prelude.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Zwirn.Language.Builtin.Prelude where + +{- + Builtin.hs - defines builtin functions + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import qualified Data.Map as Map +import Data.Text (Text) +import Zwirn.Core.Conditional as Z +import Zwirn.Core.Cord as C +import Zwirn.Core.Core as C +import Zwirn.Core.Map as M +import Zwirn.Core.Modulate +import Zwirn.Core.Number as N +import Zwirn.Core.Random +import Zwirn.Core.Structure as S +import Zwirn.Core.Time +import Zwirn.Language.Builtin.Internal +import Zwirn.Language.Builtin.Parameters +import Zwirn.Language.Environment +import Zwirn.Language.Evaluate hiding (insert) +import Zwirn.Language.TypeCheck.Types + +builtinEnvironment :: InterpreterEnv +builtinEnvironment = IEnv builtins instances + +instances :: [Instance] +instances = + [ IsIn "Num" numberT, + IsIn "Num" mapT, + IsIn "Eq" numberT, + IsIn "Eq" mapT, + IsIn "Eq" textT + ] + +builtinNames :: [Text] +builtinNames = Map.keys builtins + +builtins :: Map.Map Text AnnotatedExpression +builtins = + Map.unions + [ coreFunctions, + numberFunctions, + signals, + randomFunctions, + timeFunctions, + structureFunctions, + conditionalFunctions, + cordFunctions, + mapFunctions, + stateFunctions, + builtinParams + ] + +coreFunctions :: Map.Map Text AnnotatedExpression +coreFunctions = + Map.unions + [ "id" + === lambda id + <:: "a -> a" + --| "identity function", + "const" + === lambda (lambda . const) + <:: "a -> b -> a" + --| "constant function - ignore second input", + "scomb" + === lambda (\f -> lambda $ \g -> lambda $ \x -> f ! x ! (g ! x)) + <:: "(a -> b -> c) -> (a -> b) -> a -> c" + --| "S-combinator", + "." + === lambda (\g -> lambda $ \f -> lambda $ \x -> g ! (f ! x)) + <:: "(b -> c) -> (a -> b) -> a -> c" + --| "function composition", + "flip" + === lambda (\f -> lambda $ \y -> lambda $ \x -> f ! x ! y) + <:: "(a -> b -> c) -> b -> a -> c" + --| "flip arguments", + "\'" + === toExp (flip squeezeApply :: Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression) + <:: "a -> (a -> b) -> b" + --| "apply argument to function, results are squeezed", + "$" + === toExp (squeezeApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "(a -> b) -> a -> b" + --| "apply argument to function, results are squeezed", + "|$" + === toExp (outerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "(a -> b) -> a -> b" + --| "apply argument to function", + "$|" + === toExp (innerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "(a -> b) -> a -> b" + --| "apply argument to function", + "map" + === toExp (mapZ :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "(a -> b) -> a -> b" + --| "map a function over the structure of the argument", + "zip" + === toExp (zipApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "(a -> b) -> a -> b" + --| "map a function over the structure of the argument", + "bus" + === toExp (id :: Zwirn Expression -> Zwirn Expression) + <:: "Number -> Bus" + --| "controlbus", + "recv" + === toExp (toExp recv) + <:: "Text -> Number -> Map" + --| "recieve a value from a bus and send it to the given parameter" + ] + +numberFunctions :: Map.Map Text AnnotatedExpression +numberFunctions = + Map.unions + [ "|+" + === toExp ((+) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a -> a" + --| "addition", + "|-" + === toExp ((-) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a -> a" + --| "subtraction", + "|*" + === toExp ((*) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a -> a" + --| "multiplication", + "|/" + === toExp ((/) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a -> a" + --| "division", + "negate" + === toExp (negate :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "negate", + "abs" + === toExp (abs :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "absolute value", + "signum" + === toExp (signum :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "signum", + "recip" + === toExp (recip :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "reciprocal value", + "pi" + === toExp (pi :: Zwirn Expression) + <:: "Number" + --| "pi", + "|**" + === toExp ((**) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a -> a" + --| "exponentiation", + "exp" + === toExp (exp :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "exponential function", + "log" + === toExp (log :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "logarithm base 10", + "sqrt" + === toExp (sqrt :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "square root", + "sin" + === toExp (sin :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "sine function", + "cos" + === toExp (cos :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "cosine function", + "tan" + === toExp (tan :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "tangens", + "asin" + === toExp (asin :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "arc sine function", + "acos" + === toExp (acos :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "arc cosine function", + "atan" + === toExp (atan :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "arc tangens", + "sinh" + === toExp (sinh :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic sine", + "cosh" + === toExp (cosh :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic cosine", + "tanh" + === toExp (tan :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic tangens", + "asinh" + === toExp (asinh :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic arc sine function", + "acosh" + === toExp (acosh :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic arc cosine function", + "atanh" + === toExp (atanh :: Zwirn Expression -> Zwirn Expression) + <:: "Num a => a -> a" + --| "hyperbolic arc tangens", + "mod" + === toExp (N.mod :: Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number" + --| "modulo", + "frac" + === toExp (N.frac :: Zwirn Double -> Zwirn Double) + <:: "Number -> Number" + --| "fractional part of a number", + "trunc" + === toExp (N.trunc :: Zwirn Double -> Zwirn Int) + <:: "Number -> Number" + --| "truncate", + "ceil" + === toExp (N.ceil :: Zwirn Double -> Zwirn Int) + <:: "Number -> Number" + --| "round up", + "floor" + === toExp (N.floor :: Zwirn Double -> Zwirn Int) + <:: "Number -> Number" + --| "round down", + "round" + === toExp (N.round :: Zwirn Double -> Zwirn Int) + <:: "Number -> Number" + --| "round to closest", + "gcd" + === toExp (N.gcd :: Zwirn Int -> Zwirn Int -> Zwirn Int) + <:: "Number -> Number -> Number" + --| "greatest common divisor", + "lcm" + === toExp (N.lcm :: Zwirn Int -> Zwirn Int -> Zwirn Int) + <:: "Number -> Number -> Number" + --| "least common multiple", + "range" + === toExp (range :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number -> Number" + --| "range x y l maps number l linearly into interval (x,y), assuming l is between 0 and 1" + ] + +signals :: Map.Map Text AnnotatedExpression +signals = + Map.unions + [ "sine" + === toExp (sine :: Zwirn Time) + <:: "Number" + --| "sine signal", + "sine2" + === toExp (sine2 :: Zwirn Time) + <:: "Number" + --| "bipolar sine signal", + "saw" + === toExp (saw :: Zwirn Time) + <:: "Number" + --| "saw signal", + "saw2" + === toExp (saw2 :: Zwirn Time) + <:: "Number" + --| "bipolar saw signal", + "cosine" + === toExp (cosine :: Zwirn Time) + <:: "Number" + --| "cosine signal", + "cosine2" + === toExp (cosine2 :: Zwirn Time) + <:: "Number" + --| "bipolar cosine signal", + "isaw" + === toExp (isaw :: Zwirn Time) + <:: "Number" + --| "inverse saw signal", + "isaw2" + === toExp (isaw2 :: Zwirn Time) + <:: "Number" + --| "bipolar inverse saw signal", + "tri" + === toExp (tri :: Zwirn Time) + <:: "Number" + --| "triangle signal", + "tri2" + === toExp (tri2 :: Zwirn Time) + <:: "Number" + --| "bipolar triangle signal", + "square" + === toExp (square :: Zwirn Time) + <:: "Number" + --| "square signal", + "square2" + === toExp (square2 :: Zwirn Time) + <:: "Number" + --| "bipolar square signal" + ] + +randomFunctions :: Map.Map Text AnnotatedExpression +randomFunctions = + Map.unions + [ "noise" + === toExp (noise :: Zwirn Double) + <:: "Number" + --| "random stream of values between 0 and 1", + "irand" + === toExp (irand :: Zwirn Int -> Zwirn Int) + <:: "Number -> Number" + --| "random integer values between 0 and given input", + "chooseFromTo" + === toExp (enumFromToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number" + --| "```chooseFromTo x y == [x | .. y]```", + "chooseFromThenTo" + === toExp (enumFromThenToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number -> Number" + --| "```chooseFromTo x y z == [x | y .. z]```" + ] + +timeFunctions :: Map.Map Text AnnotatedExpression +timeFunctions = + Map.unions + [ "*" + === toExp (flip fast :: Zwirn Expression -> Zwirn Time -> Zwirn Expression) + <:: "a -> Number -> a" + --| "multiply time, making it faster", + "fast" + === toExp (fast :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "multiply time, making it faster", + "/" + === toExp (flip slow :: Zwirn Expression -> Zwirn Time -> Zwirn Expression) + <:: "a -> Number -> a" + --| "divide time, making it slower", + "slow" + === toExp (slow :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "divide time, making it slower", + "+" + === toExp (flip shift :: Zwirn Expression -> Zwirn Time -> Zwirn Expression) + <:: "a -> Number -> a" + --| "shift time to the right", + "-" + === toExp (flip (shift . fmap negate) :: Zwirn Expression -> Zwirn Time -> Zwirn Expression) + <:: "a -> Number -> a" + --| "shift time to the left", + "shift" + === toExp (shift :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "shift time", + "revBy" + === toExp (revBy :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "reverse time, piecewise", + "rev" + === toExp (rev :: Zwirn Expression -> Zwirn Expression) + <:: "a -> a" + --| "reverse time completely", + "ply" + === toExp (ply :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "speed up time inside", + "timeloop" + === toExp (timeloop :: Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "loop time from 0 to the given number", + "zoom" + === toExp (zoom :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> Number -> a -> a" + --| "zoom and loop a part of a zwirn" + ] + +structureFunctions :: Map.Map Text AnnotatedExpression +structureFunctions = + Map.unions + [ "euclidOff" + === toExp (euclidOff :: Zwirn Int -> Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> Number -> Number -> a -> a" + --| "shifted euclidean rhythm", + "euclid" + === toExp (euclid :: Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> Number -> a -> a" + --| "euclidean rhythm", + "segment" + === toExp (segment :: Zwirn Int -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "divide structure into equal pieces", + "struct" + === toExp (struct :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "a -> b -> b" + --| "copy the structure from first value", + "run" + === toExp (run :: Zwirn Int -> Zwirn Int) + <:: "Number -> Number" + --| "```run n == [0 .. n-1]```", + "runFromTo" + === toExp (runFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number" + --| "```runFromTo x y == [x .. y]```", + "runFromThenTo" + === toExp (runFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number -> Number" + --| "```runFromTo x y z == [x y .. z]```", + "slowrun" + === toExp (slowrun :: Zwirn Int -> Zwirn Int) + <:: "Number -> Number" + --| "```run n == <0 .. n-1>```", + "slowrunFromTo" + === toExp (slowrunFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number" + --| "```slowrunFromTo x y == ```", + "slowrunFromThenTo" + === toExp (slowrunFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number -> Number" + --| "```slowrunFromTo x y z == ```" + ] + +conditionalFunctions :: Map.Map Text AnnotatedExpression +conditionalFunctions = + Map.unions + [ "==" + === toExp (eq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool) + <:: "Eq a => a -> a -> Number" + --| "equality", + ">=" + === toExp (geq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "greater or equal", + "<=" + === toExp (leq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "less or equal", + "<" + === toExp (ge :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "less", + ">" + === toExp (le :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "greater", + "not" + === toExp (Z.not :: Zwirn Bool -> Zwirn Bool) + <:: "Number -> Number" + --| "logical not", + "&&" + === toExp (Z.and :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "logical and", + "||" + === toExp (Z.or :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool) + <:: "Number -> Number -> Number" + --| "logical or", + "ifthen" + === toExp (ifthen :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a -> a" + --| "choose between two expressions based on a condition", + "if" + === toExp (iff :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "if condition is true produce the value, silence otherwise", + "while" + === toExp (while :: Zwirn Bool -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> (a -> a) -> a -> a" + --| "apply function while condition is true", + "everyFor" + === toExp (everyFor :: Zwirn Time -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> Number -> (a -> a) -> a -> a" + --| "apply function periodically for a given amount of time", + "every" + === toExp (every :: Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> (a -> a) -> a -> a" + --| "apply function periodically for one cycle" + ] + +cordFunctions :: Map.Map Text AnnotatedExpression +cordFunctions = + Map.unions + [ "project" + === toExp (project :: Zwirn Int -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "project to a certain layer of a cord", + "insert" + === toExp (C.insert :: Zwirn Int -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a -> a" + --| "insert into a specific layer of a cord", + "remove" + === toExp (remove :: Zwirn Int -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> a -> a" + --| "remove a specific layer of a cord", + "arp" + === toExp (arp :: Zwirn Expression -> Zwirn Expression) + <:: "a -> a" + --| "arpeggiate", + "reverse" + === toExp (reverseC :: Zwirn Expression -> Zwirn Expression) + <:: "a -> a" + --| "reverse order of cord", + "invert" + === toExp (invertC :: Zwirn Expression -> Zwirn Expression) + <:: "Number -> Number" + --| "chord inversion", + "rotate" + === toExp (rotateC :: Zwirn Expression -> Zwirn Expression) + <:: "a -> a" + --| "cord rotation", + "at" + === toExp (at :: Zwirn Int -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression) + <:: "Number -> (a -> a) -> a -> a" + --| "apply a function to a specific layer of a cord", + "cordFromTo" + === toExp (enumFromToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number" + --| "```cordFromTo x y == [x, .. y]```", + "cordFromThenTo" + === toExp (enumFromThenToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double) + <:: "Number -> Number -> Number -> Number" + --| "```cordFromThenTo x y z == [x, y .. z]```" + ] + +mapFunctions :: Map.Map Text AnnotatedExpression +mapFunctions = + Map.unions + [ "pN" + === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Double -> Zwirn Expression) + <:: "Text -> Number -> Map" + --| "number singleton with specific key", + "pT" + === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Text -> Zwirn Expression) + <:: "Text -> Text -> Map" + --| "text singleton with specific key", + "#" + === toExp (union :: Zwirn ExpressionMap -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Map -> Map -> Map" + --| "union of two maps - structure from the left", + "lookupN" + === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression) + <:: "Text -> Map -> Number" + --| "retrieve number at given key or silence if key is missing or it's value not a number", + "lookupT" + === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression) + <:: "Text -> Map -> Text" + --| "retrieve text at given key or silence if key is missing or it's value not a text", + "fix" + === toExp (M.fix :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Text -> (Map -> Map) -> Map -> Map" + --| "apply a function to a specific key", + "loopAt" + === toExp (loopAt :: Zwirn Time -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Number -> Map -> Map" + --| "", + "slice" + === toExp (slice :: Zwirn Int -> Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Number -> Number -> Map -> Map" + --| "slice a sample into equal btis and index into them", + "chop" + === toExp (chop :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Number -> Map -> Map" + --| "", + "striate" + === toExp (striate :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Number -> Map -> Map" + --| "", + "striateBy" + === toExp (striateBy :: Zwirn Int -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn ExpressionMap) + <:: "Number -> Number -> Map -> Map" + --| "" + ] + +stateFunctions :: Map.Map Text AnnotatedExpression +stateFunctions = + Map.unions + [ "getN" + === toExp getStateN + <:: "Text -> Number" + --| "retrieve number from state at given key or silence if key is missing or it's value not a number", + "getT" + === toExp getStateT + <:: "Text -> Text" + --| "retrieve text from state at given key or silence if key is missing or it's value not a text", + "getM" + === toExp getStateM + <:: "Text -> Map" + --| "retrieve map from state at given key or silence if key is missing or it's value not a map", + "set" + === toExp setState + <:: "Text -> a -> b -> b" + --| "set state at key to given value", + "modify" + === toExp modifyState + <:: "Text -> (a -> a) -> b -> b" + --| "modify state at given key with function" + ] diff --git a/src/Zwirn/Language/Compiler.hs b/src/Zwirn/Language/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Compiler.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Zwirn.Language.Compiler where + +{- + Compiler.hs - implementation of a compiler-interpreter for zwirn + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Control.Concurrent (readMVar) +import Control.Exception (SomeException, try) +import Control.Monad +import Control.Monad.Except +import Control.Monad.State +import Data.List (sortOn) +import Data.Text (Text, unpack) +import Data.Text.IO (readFile) +import Text.Read (readMaybe) +import Zwirn.Core.Types (silence) +import Zwirn.Language.Block +import Zwirn.Language.Builtin.Prelude (builtinNames) +import Zwirn.Language.Environment +import Zwirn.Language.Evaluate +import Zwirn.Language.Parser +import Zwirn.Language.Pretty +import qualified Zwirn.Language.Rotate as R +import Zwirn.Language.Simple +import Zwirn.Language.Syntax +import Zwirn.Language.TypeCheck.Constraint (runSolve) +import Zwirn.Language.TypeCheck.Infer +import Zwirn.Language.TypeCheck.Types +import Zwirn.Stream +import Prelude hiding (readFile) + +newtype CIMessage + = CIMessage Text + deriving (Show, Eq) + +data CurrentBlock + = CurrentBlock Int Int + deriving (Eq, Show) + +data ConfigEnv + = ConfigEnv + { cConfigPath :: IO String, + cResetConfig :: IO String + } + +data CiConfig = CiConfig + { ciConfigOverwriteBuiltin :: Bool, + ciConfigDynamicTypes :: Bool + } + +data Environment + = Environment + { tStream :: Stream, + intEnv :: InterpreterEnv, + confEnv :: Maybe ConfigEnv, + currBlock :: Maybe CurrentBlock, + ciConfig :: CiConfig + } + +data CIError + = CIError + { eError :: String, + eEnv :: Environment + } + +instance Show CIError where + show (CIError err _) = err + +type CI = StateT Environment (ExceptT CIError IO) + +runCI :: Environment -> CI a -> IO (Either CIError a) +runCI env m = runExceptT $ evalStateT m env + +compilerInterpreterBasic :: Text -> CI String +compilerInterpreterBasic input = do + as <- runParser input + runActions True as + +compilerInterpreterBlock :: Int -> Int -> Text -> CI (String, Environment, Int, Int) +compilerInterpreterBlock line editor input = do + blocks <- runBlocks 0 input + (Block strt end content) <- runGetBlock line blocks + setCurrentBlock strt end + as <- runParserWithPos strt editor content + r <- runActions True as + e <- get + return (r, e, strt, end) + +compilerInterpreterLine :: Int -> Int -> Text -> CI (String, Environment, Int, Int) +compilerInterpreterLine line editor input = do + setCurrentBlock line line + blocks <- runBlocks 0 input + content <- runGetLine line blocks + as <- runParserWithPos line editor content + r <- runActions True as + e <- get + return (r, e, line, line) + +compilerInterpreterWhole :: Int -> Text -> CI (String, Environment, Int, Int) +compilerInterpreterWhole editor input = do + blocks <- runBlocks 0 input + let sorted = sortOn (\(Block x _ _) -> x) blocks + (Block strt _ _) = head sorted + (Block _ end _) = last sorted + liftIO $ print sorted + setCurrentBlock strt end + let parseBlock (Block s _ c) = runParserWithPos s editor c + ass <- mapM parseBlock sorted + rs <- mapM (runActions True) ass + e <- get + return (last rs, e, strt, end) + +compilerInterpreterBoot :: [Text] -> CI Environment +compilerInterpreterBoot ps = runActions False (map Load ps) >> get + +----------------------------------------------------- +----------------- Throwing Errors ------------------- +----------------------------------------------------- + +throw :: String -> CI a +throw err = do + env <- get + throwError $ CIError err env + +setCurrentBlock :: Int -> Int -> CI () +setCurrentBlock st en = modify (\env -> env {currBlock = Just $ CurrentBlock st en}) + +----------------------------------------------------- +---------------------- Parser ----------------------- +----------------------------------------------------- + +runParserWithPos :: Int -> Int -> Text -> CI [Action] +runParserWithPos ln ed t = case parseActionsWithPos ln ed t of + Left err -> throw err + Right as -> return as + +runParser :: Text -> CI [Action] +runParser t = case parseActions t of + Left err -> throw err + Right as -> return as + +runBlocks :: Int -> Text -> CI [Block] +runBlocks ln t = case parseBlocks ln t of + Left err -> throw err + Right bs -> return bs + +runGetBlock :: Int -> [Block] -> CI Block +runGetBlock i bs = case getBlock i bs of + Left err -> throw err + Right b -> return b + +runGetLine :: Int -> [Block] -> CI Text +runGetLine i bs = case getLn i bs of + Left err -> throw err + Right b -> return b + +----------------------------------------------------- +---------------------- Desugar ---------------------- +----------------------------------------------------- + +runSimplify :: Term -> CI SimpleTerm +runSimplify t = return $ simplify t + +runSimplifyDef :: Def -> CI SimpleDef +runSimplifyDef d = return $ simplifyDef d + +----------------------------------------------------- +------------------- AST Rotation -------------------- +----------------------------------------------------- + +runRotate :: SimpleTerm -> CI SimpleTerm +runRotate s = case R.runRotate s of + Left err -> throw err + Right t -> return t + +----------------------------------------------------- +-------------------- Type Check --------------------- +----------------------------------------------------- + +runTypeCheck :: SimpleTerm -> CI Scheme +runTypeCheck s = do + Environment {intEnv = env} <- get + case inferTerm env s of + Left err -> throw $ show err + Right t -> return t + +----------------------------------------------------- +-------------------- Interpreter -------------------- +----------------------------------------------------- + +interpret :: SimpleTerm -> CI Expression +interpret input = do + env <- gets intEnv + return $ evaluate env input + +-- if ctx is false, highlighting should be disabled +checkHighlight :: Bool -> Expression -> CI Expression +checkHighlight True x = return x +checkHighlight False x = return $ removePosExp x + +----------------------------------------------------- +----------------- Compiling Actions ----------------- +----------------------------------------------------- + +defAction :: Bool -> Def -> CI () +defAction ctx d = do + (LetS x st) <- runSimplifyDef d + rot <- runRotate st + ty@(Forall _ (Qual _ typ)) <- runTypeCheck rot + ex <- interpret rot + exCtx <- checkHighlight ctx ex + dynamic <- gets (ciConfigDynamicTypes . ciConfig) + + if dynamic + then checkAndDefine x ty exCtx + else do + mayty <- gets (lookupType x . intEnv) + case mayty of + Just (Forall _ (Qual _ oldType)) -> case runSolve [(oldType, typ)] of + Left _ -> throw "Cannot overwrite definition with new type. Please use DynamicTypes." + Right _ -> checkAndDefine x ty exCtx + Nothing -> checkAndDefine x ty exCtx + +checkAndDefine :: Text -> Scheme -> Expression -> CI () +checkAndDefine x ty exCtx = do + overwrite <- gets (ciConfigOverwriteBuiltin . ciConfig) + if overwrite + then modify (\env -> env {intEnv = extend (x, exCtx, ty) (intEnv env)}) + else + if x `elem` builtinNames + then throw "Failed to overwrite builtin function. Please enable OverwriteBuiltin." + else modify (\env -> env {intEnv = extend (x, exCtx, ty) (intEnv env)}) + +showAction :: Term -> CI String +showAction t = do + s <- runSimplify t + rot <- runRotate s + ty <- runTypeCheck rot + if isBasicType ty + then do + ex <- interpret rot + stmv <- gets (sState . tStream) + st <- liftIO $ readMVar stmv + return $ showWithState st ex + else throw $ "Can not show expressions of type: " ++ ppscheme ty + +typeAction :: Term -> CI String +typeAction t = do + s <- runSimplify t + rot <- runRotate s + ty <- runTypeCheck rot + return $ ppTermHasType (t, ty) + +loadAction :: Text -> CI () +loadAction path = do + mayfile <- liftIO ((try $ readFile $ unpack path) :: IO (Either SomeException Text)) + case mayfile of + Left _ -> throw "file not found" + Right input -> do + blocks <- runBlocks 0 input + let sorted = sortOn (\(Block x _ _) -> x) blocks + ass <- mapM (runParser . bContent) sorted + mapM_ (runActions False) ass + +infoAction :: Text -> CI String +infoAction n = do + env <- gets intEnv + case lookupFull n env of + Just (Annotated _ t (Just d)) -> return $ unpack n ++ " :: " ++ ppscheme t ++ "\n" ++ unpack d + Just (Annotated _ t Nothing) -> return $ unpack n ++ " :: " ++ ppscheme t + Nothing -> throw $ "couldn't find information about " ++ unpack n + +streamAction :: Bool -> Text -> Term -> CI () +streamAction ctx key t = do + s <- runSimplify t + rot <- runRotate s + ty <- runTypeCheck rot + ex <- interpret rot + exCtx <- checkHighlight ctx ex + if isBasicType ty + then + ( do + str <- gets tStream + liftIO $ streamReplace str key (fromExp exCtx) + ) + else + if isBus ty + then + ( do + str <- gets tStream + let mayindex = readMaybe $ unpack key + case mayindex of + Just ind -> liftIO $ streamReplaceBus str ind (fromExp exCtx) + Nothing -> throw "Please use an integer as bus index." + ) + else throw "Can only stream base types!" + +streamSetAction :: Bool -> Text -> Term -> CI () +streamSetAction ctx x t = do + s <- runSimplify t + rot <- runRotate s + ty@(Forall _ (Qual _ typ)) <- runTypeCheck rot + ex <- interpret rot + exCtx <- checkHighlight ctx ex + + dynamic <- gets (ciConfigDynamicTypes . ciConfig) + + if dynamic + then checkAndSet x ty exCtx + else do + mayty <- gets (lookupType x . intEnv) + case mayty of + Just (Forall _ (Qual _ oldType)) -> case runSolve [(oldType, typ)] of + Left _ -> throw "Cannot overwrite definition with new type. Please use DynamicTypes." + Right _ -> checkAndSet x ty exCtx + Nothing -> checkAndSet x ty exCtx + +checkAndSet :: Text -> Scheme -> Expression -> CI () +checkAndSet x ty exCtx = + if isBasicType ty + then + ( do + overwrite <- gets (ciConfigOverwriteBuiltin . ciConfig) + if overwrite + then setExpression x ty exCtx + else + if x `elem` builtinNames + then throw "Failed to overwrite builtin function. Please enable OverwriteBuiltin." + else setExpression x ty exCtx + ) + else throw "Can only set basic types!" + +setExpression :: Text -> Scheme -> Expression -> CI () +setExpression x ty exCtx = do + modify (\env -> env {intEnv = extend (x, newEx, ty) (intEnv env)}) + str <- gets tStream + liftIO $ streamSet str x exCtx + where + newEx + | isNumberT ty = EZwirn $ getStateN (pure x) + | isTextT ty = EZwirn $ getStateT (pure x) + | isMapT ty = EZwirn $ getStateM (pure x) + | otherwise = EZwirn silence + +streamOnceAction :: Bool -> Term -> CI () +streamOnceAction ctx t = do + s <- runSimplify t + rot <- runRotate s + ty <- runTypeCheck rot + ex <- interpret rot + exCtx <- checkHighlight ctx ex + if isBasicType ty + then + ( do + str <- gets tStream + liftIO $ streamFirst str (fromExp exCtx) + ) + else throw "Can only stream base types!" + +streamSetTempoAction :: Tempo -> Text -> CI () +streamSetTempoAction CPS t = gets tStream >>= \str -> liftIO $ streamSetCPS str (toRational (read $ unpack t :: Double)) +streamSetTempoAction BPM t = gets tStream >>= \str -> liftIO $ streamSetBPM str (toRational (read $ unpack t :: Double)) + +resetConfigAction :: CI String +resetConfigAction = do + (Environment {confEnv = mayEnv}) <- get + case mayEnv of + Nothing -> throw "Configuration not available." + Just (ConfigEnv _ reset) -> liftIO reset + +getConfigPathAction :: CI String +getConfigPathAction = do + (Environment {confEnv = mayEnv}) <- get + case mayEnv of + Nothing -> throw "Configuration not available." + Just (ConfigEnv path _) -> liftIO path + +runAction :: Bool -> Action -> CI String +runAction b (StreamAction i t) = streamAction b i t >> return "" +runAction b (StreamSet i t) = streamSetAction b i t >> return "" +runAction b (StreamOnce t) = streamOnceAction b t >> return "" +runAction _ (StreamSetTempo mode t) = streamSetTempoAction mode t >> return "" +runAction _ (Show t) = showAction t +runAction b (Def d) = defAction b d >> return "" +runAction _ (Type t) = typeAction t +runAction _ (Load p) = loadAction p >> return "" +runAction _ (Info p) = infoAction p +runAction _ ConfigPath = getConfigPathAction +runAction _ ResetConfig = resetConfigAction + +runActions :: Bool -> [Action] -> CI String +runActions b as = last <$> mapM (runAction b) as + +isNumberT :: Scheme -> Bool +isNumberT (Forall _ (Qual _ (TypeCon "Number"))) = True +isNumberT _ = False + +isTextT :: Scheme -> Bool +isTextT (Forall _ (Qual _ (TypeCon "Text"))) = True +isTextT _ = False + +isMapT :: Scheme -> Bool +isMapT (Forall _ (Qual _ (TypeCon "Map"))) = True +isMapT _ = False diff --git a/src/Zwirn/Language/Environment.hs b/src/Zwirn/Language/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Environment.hs @@ -0,0 +1,44 @@ +module Zwirn.Language.Environment where + +import qualified Data.Map as Map +import Data.Text (Text) +import Zwirn.Core.Types (silence) +import Zwirn.Language.Evaluate.Expression +import Zwirn.Language.TypeCheck.Types + +data AnnotatedExpression + = Annotated + { aExp :: Expression, + aType :: Scheme, + aDesc :: Maybe Text + } + +data InterpreterEnv = IEnv + { eExpressions :: Map.Map Text AnnotatedExpression, + eInstances :: [Instance] + } + +withExpressions :: (Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression) -> InterpreterEnv -> InterpreterEnv +withExpressions f (IEnv l i) = IEnv (f l) i + +extend :: (Text, Expression, Scheme) -> InterpreterEnv -> InterpreterEnv +extend (n, x, s) = withExpressions (Map.insert n (Annotated x s Nothing)) + +lookupType :: Text -> InterpreterEnv -> Maybe Scheme +lookupType k (IEnv l _) = aType <$> Map.lookup k l + +insertType :: Text -> Scheme -> InterpreterEnv -> InterpreterEnv +insertType t s = withExpressions (Map.alter alt t) + where + dummy = EZwirn silence + alt Nothing = Just $ Annotated dummy s Nothing + alt (Just (Annotated x _ i)) = Just $ Annotated x s i + +lookupDescription :: Text -> InterpreterEnv -> Maybe Text +lookupDescription k (IEnv l _) = aDesc =<< Map.lookup k l + +lookupExp :: Text -> InterpreterEnv -> Maybe Expression +lookupExp k (IEnv l _) = aExp <$> Map.lookup k l + +lookupFull :: Text -> InterpreterEnv -> Maybe AnnotatedExpression +lookupFull k (IEnv l _) = Map.lookup k l diff --git a/src/Zwirn/Language/Evaluate.hs b/src/Zwirn/Language/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Evaluate.hs @@ -0,0 +1,12 @@ +module Zwirn.Language.Evaluate + ( module Zwirn.Language.Evaluate.Expression, + module Zwirn.Language.Evaluate.Internal, + module Zwirn.Language.Evaluate.Convert, + module Zwirn.Language.Evaluate.SKI, + ) +where + +import Zwirn.Language.Evaluate.Convert +import Zwirn.Language.Evaluate.Expression +import Zwirn.Language.Evaluate.Internal +import Zwirn.Language.Evaluate.SKI diff --git a/src/Zwirn/Language/Evaluate/Convert.hs b/src/Zwirn/Language/Evaluate/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Evaluate/Convert.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Zwirn.Language.Evaluate.Convert where + +{- + Convert.hs - convert from and to Expressions + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import qualified Data.Map as Map +import Data.String (IsString, fromString) +import Data.Text (Text, pack) +import Zwirn.Core.Time (Time (..)) +import Zwirn.Core.Types +import Zwirn.Language.Evaluate.Expression + +fromZwirn :: Zwirn Expression -> Expression +fromZwirn = EZwirn + +toZwirn :: Expression -> Zwirn Expression +toZwirn (EZwirn x) = x +toZwirn _ = silence + +class FromExpression a where + fromExp :: Expression -> Zwirn a + +class ToExpression a where + toExp :: a -> Expression + +instance FromExpression Time where + fromExp (EZwirn tz) = fmap (\(ENum t) -> Time (toRational t) 0) tz + fromExp _ = silence + +instance FromExpression Double where + fromExp (EZwirn tz) = fmap (\(ENum t) -> t) tz + fromExp _ = silence + +instance FromExpression Int where + fromExp (EZwirn tz) = fmap (\(ENum t) -> floor t) tz + fromExp _ = silence + +instance FromExpression Expression where + fromExp (EZwirn z) = z + fromExp _ = silence + +instance FromExpression Text where + fromExp (EZwirn z) = fmap (\(EText t) -> t) z + fromExp _ = silence + +instance FromExpression Bool where + fromExp (EZwirn z) = fmap (\(ENum x) -> x >= 1) z + fromExp _ = silence + +instance FromExpression ExpressionMap where + fromExp (EZwirn z) = fmap (\(EMap m) -> m) z + fromExp _ = silence + +instance (ToExpression a, FromExpression b) => FromExpression (Zwirn a -> Zwirn b) where + fromExp (EZwirn z) = fmap (\(ELam f) -> fromExp . f . toExp) z + fromExp _ = silence + +instance (FromExpression a) => FromExpression (Zwirn a) where + fromExp (EZwirn z) = fmap fromExp z + fromExp _ = silence + +instance ToExpression Expression where + toExp = id + +instance ToExpression Double where + toExp = ENum + +instance ToExpression Time where + toExp (Time t _) = ENum $ fromRational t + +instance ToExpression Int where + toExp i = ENum $ fromIntegral i + +instance ToExpression Bool where + toExp True = ENum 1 + toExp False = ENum 0 + +instance ToExpression Text where + toExp = EText + +instance (ToExpression a) => ToExpression (Map.Map Text a) where + toExp m = EMap $ toExp <$> m + +instance (ToExpression a) => ToExpression (Zwirn a) where + toExp a = EZwirn $ fmap toExp a + +instance (FromExpression a, ToExpression b) => ToExpression (Zwirn a -> b) where + toExp f = lambda $ \x -> toExp $ f (fromExp x) + +instance Num Expression where + (+) = pervasive2 ((+) @Double) + (*) = pervasive2 ((*) @Double) + abs = pervasive (abs @Double) + signum = pervasive (signum @Double) + fromInteger i = ENum $ fromInteger i + negate = pervasive (negate @Double) + +instance Fractional Expression where + fromRational r = ENum $ fromRational r + (/) = pervasive2 ((/) @Double) + +instance Floating Expression where + pi = EZwirn $ pure $ ENum pi + exp = pervasive (exp :: Double -> Double) + log = pervasive (log :: Double -> Double) + sin = pervasive (sin :: Double -> Double) + cos = pervasive (cos :: Double -> Double) + asin = pervasive (asin :: Double -> Double) + acos = pervasive (acos :: Double -> Double) + atan = pervasive (atan :: Double -> Double) + sinh = pervasive (sinh :: Double -> Double) + cosh = pervasive (cosh :: Double -> Double) + asinh = pervasive (asinh :: Double -> Double) + acosh = pervasive (acosh :: Double -> Double) + atanh = pervasive (atanh :: Double -> Double) + +instance IsString Expression where + fromString = EText . pack + +class Pervasive a where + pervasive :: (a -> a) -> Expression -> Expression + pervasive2 :: (a -> a -> a) -> Expression -> Expression -> Expression + +instance Pervasive Double where + pervasive f (ENum d) = ENum $ f d + pervasive f (EMap m) = EMap $ fmap (pervasive f) m + pervasive _ e = e + pervasive2 f (ENum d) (ENum e) = ENum $ f d e + pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n + pervasive2 _ e _ = e + +instance Pervasive Bool where + pervasive f (ENum d) = toExp $ f (d >= 1) + pervasive f (EMap m) = EMap $ fmap (pervasive f) m + pervasive _ e = e + pervasive2 f (ENum d) (ENum e) = toExp $ f (d >= 1) (e >= 1) + pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n + pervasive2 _ e _ = e + +instance Pervasive Text where + pervasive f (EText d) = EText $ f d + pervasive f (EMap m) = EMap $ fmap (pervasive f) m + pervasive _ e = e + pervasive2 f (EText d) (EText e) = EText $ f d e + pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n + pervasive2 _ e _ = e + +instance Pervasive (Either Double Text) where + pervasive f (EText d) = EText $ (\(Right t) -> t) $ f (Right d) + pervasive f (ENum d) = ENum $ (\(Left t) -> t) $ f (Left d) + pervasive f (EMap m) = EMap $ fmap (pervasive f) m + pervasive _ e = e + pervasive2 f (EText d) (EText e) = EText $ (\(Right t) -> t) $ f (Right d) (Right e) + pervasive2 f (ENum d) (ENum e) = ENum $ (\(Left t) -> t) $ f (Left d) (Left e) + pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n + pervasive2 _ e _ = e diff --git a/src/Zwirn/Language/Evaluate/Expression.hs b/src/Zwirn/Language/Evaluate/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Evaluate/Expression.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Zwirn.Language.Evaluate.Expression where + +{- + Expression.hs - Abstract Expressions + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.List +import qualified Data.Map as Map +import Data.Text (Text, unpack) +import Zwirn.Core.Cord +import Zwirn.Core.Query +import Zwirn.Core.Time (Time (..)) +import Zwirn.Language.Syntax +import Zwirn.Language.TypeCheck.Types + +type ExpressionMap = Map.Map Text Expression + +type Zwirn = Cord ExpressionMap Position + +data Expression + = EVar (Maybe Position) Name + | EApp Expression Expression + | ELam (Expression -> Expression) + | ENum Double + | EText Text + | EMap ExpressionMap + | ESeq [Expression] + | EStack [Expression] + | EChoice Int [Expression] + | EZwirn (Zwirn Expression) + +showWithState :: ExpressionMap -> Expression -> String +showWithState st (EZwirn x) = intercalate "\n" $ (\(t, y) -> show t ++ ":" ++ showWithState st y) <$> findAllValuesWithTime (Time 0 1, Time 1 1) st x +showWithState _ (ENum x) = take 5 $ show x +showWithState _ (EText x) = unpack x +showWithState st (EMap m) = show $ Map.toList $ showWithState st <$> m +showWithState _ _ = "can't show" + +instance Show Expression where + show = showWithState Map.empty + +instance Eq Expression where + (==) (ENum n) (ENum m) = n == m + (==) (EText n) (EText m) = n == m + (==) (EMap n) (EMap m) = n == m + (==) _ _ = False + +instance Ord Expression where + (<=) (ENum n) (ENum m) = n <= m + (<=) _ _ = False + +lambda :: (Expression -> Expression) -> Expression +lambda f = EZwirn $ pure $ ELam f diff --git a/src/Zwirn/Language/Evaluate/Internal.hs b/src/Zwirn/Language/Evaluate/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Evaluate/Internal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Zwirn.Language.Evaluate.Internal where + +{- + Internal.hs - internal functions, specific to Expressions + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import qualified Data.Map as Map +import Data.Text (Text, pack) +import Zwirn.Core.Core (withState, (<$$>)) +import Zwirn.Core.Map +import Zwirn.Core.State +import Zwirn.Core.Types +import Zwirn.Language.Evaluate.Convert +import Zwirn.Language.Evaluate.Expression + +-- helper + +insert :: (Text, Expression) -> ExpressionMap -> ExpressionMap +insert (k, x) = Map.insert k x + +getStateN :: Zwirn Text -> Zwirn Expression +getStateN xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ())) + where + fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x + fromLookup _ = silence + fromNum (ENum n) = pure $ ENum n + fromNum _ = silence + +getStateT :: Zwirn Text -> Zwirn Expression +getStateT xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ())) + where + fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromText x + fromLookup _ = silence + fromText (EText n) = pure $ EText n + fromText _ = silence + +getStateM :: Zwirn Text -> Zwirn Expression +getStateM xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ())) + where + fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromMap x + fromLookup _ = silence + fromMap (EMap n) = pure $ EMap n + fromMap _ = silence + +modifyState :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression +modifyState kz fz xz = modifyState' <$> kz <*> fz <$$> xz + where + modifyState' :: Text -> (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression + modifyState' key f = withState (Map.update (Just . toExp . f . fromExp) key) + +setState :: Zwirn Text -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression +setState t x = setMap t (pure $ EZwirn x) + +recv :: Zwirn Text -> Zwirn Int -> Zwirn ExpressionMap +recv t i = singleton t (fmap (toExp . (\x -> pack $ "c" ++ show x)) i) diff --git a/src/Zwirn/Language/Evaluate/SKI.hs b/src/Zwirn/Language/Evaluate/SKI.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Evaluate/SKI.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Zwirn.Language.Evaluate.SKI + ( evaluate, + (!), + removePosExp, + ) +where + +{- + SKI.hs - evaluate epxressions via the SKI combinator calculus, + code adapted from https://kseo.github.io/posts/2016-12-30-write-you-an-interpreter.html + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Maybe (fromJust) +import Data.Text (unpack) +import Zwirn.Core.Cord +import Zwirn.Core.Core +import Zwirn.Core.Modulate +import Zwirn.Core.Random (chooseWithSeed) +import Zwirn.Core.Types +import Zwirn.Language.Environment +import Zwirn.Language.Evaluate.Convert +import Zwirn.Language.Evaluate.Expression +import Zwirn.Language.Simple +import Zwirn.Language.TypeCheck.Types + +compile :: SimpleTerm -> Expression +compile (SVar p n) = EVar p n +compile (SApp fun arg) = EApp (compile fun) (compile arg) +compile (SLambda x body) = abstract x (compile body) +compile (SNum (Just p) x) = EZwirn $ addInfo p $ pure $ ENum $ read $ unpack x +compile (SNum Nothing x) = EZwirn $ pure $ ENum $ read $ unpack x +compile (SText p x) = EZwirn $ addInfo p $ pure $ EText x +compile (SSeq xs) = ESeq $ map compile xs +compile (SStack xs) = EStack $ map compile xs +compile (SChoice i xs) = EChoice i $ map compile xs +compile (SInfix s1 n s2) = EApp (EApp (EVar Nothing n) (compile s1)) (compile s2) +compile (SBracket s) = compile s +compile SRest = EZwirn silence + +abstract :: Name -> Expression -> Expression +abstract x (EVar _ n) | x == n = combI +abstract x (EApp fun arg) = combS (abstract x fun) (abstract x arg) +abstract x (ESeq xs) = ESeq $ map (abstract x) xs +abstract x (EStack xs) = EStack $ map (abstract x) xs +abstract x (EChoice i xs) = EChoice i $ map (abstract x) xs +abstract _ k = combK k + +combS :: Expression -> Expression -> Expression +combS f = EApp (EApp (EVar Nothing "scomb") f) + +combK :: Expression -> Expression +combK = EApp (EVar Nothing "const") + +combI :: Expression +combI = EVar Nothing "id" + +infixl 0 ! + +(!) :: Expression -> Expression -> Expression +(EZwirn fp) ! (EZwirn x) = EZwirn $ squeezeApply (fmap (\(ELam f) -> toZwirn . f . fromZwirn) fp) x +_ ! _ = error "Error in (!)" + +link :: InterpreterEnv -> Expression -> Expression +link bs (EVar (Just p) n) = addPosExp p $ fromJust (lookupExp n bs) +link bs (EVar Nothing n) = fromJust (lookupExp n bs) +link bs (EApp f x) = link bs f ! link bs x +link bs (ESeq xs) = EZwirn $ fastcat $ map (toZwirn . link bs) xs +link bs (EStack xs) = EZwirn $ stack $ map (toZwirn . link bs) xs +link bs (EChoice i xs) = EZwirn $ chooseWithSeed i $ map (toZwirn . link bs) xs +link _ e = e + +evaluate :: InterpreterEnv -> SimpleTerm -> Expression +evaluate bs = link bs . compile + +addPosExp :: Position -> Expression -> Expression +addPosExp p (EZwirn x) = EZwirn $ withInfos (p :) x +addPosExp _ x = x + +removePosExp :: Expression -> Expression +removePosExp (EZwirn z) = EZwirn $ removeInfo z +removePosExp x = x diff --git a/src/Zwirn/Language/Lexer.x b/src/Zwirn/Language/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Lexer.x @@ -0,0 +1,395 @@ +{ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Zwirn.Language.Lexer + ( -- * Invoking Alex + Alex + , AlexPosn (..) + , alexGetInput + , alexError + , runAlex + , alexMonadScan + + , Range (..) + , RangedToken (..) + , Token (..) + , scanMany + , increaseChoice + , setEditorNum + , getEditorNum + , setInitialLineNum + , lineLexer + , typeLexer + ) where + +{- + Lexer.hs - lexer for zwirn, code adapted from + https://serokell.io/blog/lexing-with-alex + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Text (Text) +import qualified Data.Text as Text +import Control.Monad (when) +} + +%wrapper "monadUserState-strict-text" + +$digit = [0-9] +$alphasmall = [a-z] +$alpha = [a-zA-Z] + +@id = ($alphasmall) ($alpha | $digit | \_ )* +@singles = ("&" | "$" | "?" | "#" | "." | "^") +@otherops = ("|" | "=" | "~" | "<" | ">" | "%") +@specialop = ("*" | "/" | "'" | "+" | "-") +@op = ((@singles (@singles | @otherops | @specialop)*) | ((@otherops | @specialop) (@singles | @otherops | @specialop)+)) +@num = ("-")? ($digit)+ ("." ($digit)+)? +@path = $white ($alpha | "/" | ".")+ + +tokens :- + +<0> $white+ ; + + (.+ (\n?) | \n) { mkLine } + + $white+ ; + $alpha+ "." ; + "=>" { tok Context } + "->" { tok Arrow } + "(" { tok LPar } + ")" { tok RPar } + "," { tok Comma } + "Text" { tok TextToken } + "Number" { tok NumberToken } + "Map" { tok MapToken } + "Bus" { tok BusToken } + @id { tokText VarToken } + [A-Z] $alphasmall+ { tokText TypeClass } + @id { tokText Identifier } + @op { tokText Operator } + @specialop { tokText SpecialOp } + +-- Multi Line Comments + +<0> "{-" { nestComment `andBegin` comment } +<0> "-}" { \_ _ -> alexError "Error: unexpected closing comment" } + "{-" { nestComment } + "-}" { unnestComment } + . ; + \n ; + +-- Single Line Comments + +<0> "--" .* ; + +-- Repeat +<0> "!" { tok Repeat } +<0> "!"($digit+) { tokText (\t -> RepeatNum $ Text.drop 1 t) } + +-- Parenthesis +<0> "(" { tok LPar } +<0> ")" { tok RPar } + +-- Sequences +<0> "[" { tok LBrack } +<0> "]" { tok RBrack } + +-- Stacks +<0> "," { tok Comma } + +-- Choice +<0> "|" { tok Pipe } + +-- Enum +<0> ".." { tok Enum } + +-- Polyrhythm +<0> "%" { tok Poly } + +-- Euclid +<0> "{" { tok LBraces } +<0> "}" { tok RBraces } + +-- Lambda +<0> "\" { tok Lambda } +<0> "->" { tok Arrow } + +-- Actions +<0> ";" { tok Colon } +<0> "<-" { tok StreamA } +<0> ":cps" { tok TempoCps } +<0> ":bpm" { tok TempoBpm } +<0> ":t" { tok TypeA } +<0> "=" { tok Assign } +<0> ":show" { tok ShowA } +<0> ":config" { tok ConfigA } +<0> ":resetconfig" { tok ResetConfigA } +<0> ":info" { tok InfoA } +<0> (":load") @path { tokText (\t -> LoadA $ Text.drop 6 t) } + +-- Identifiers +<0> @id { tokText Identifier } + +-- Operator Identifier +<0> \( @op \) { tokText (Identifier . rmFirstLast) } + +-- Constants +<0> @num { tokText Number } +<0> \"[^\"]*\" { tokText String } +<0> "~" { tok Rest } + +-- Operators +<0> @op { tokText Operator } +<0> @specialop { tokText SpecialOp } + +-- Alternations +<0> "<" { tok LAngle } +<0> ">" { tok RAngle } + +{ +data AlexUserState = AlexUserState + { nestLevel :: Int + , choiceNum :: Int + , editorNum :: Int + } + +alexInitUserState :: AlexUserState +alexInitUserState = AlexUserState { nestLevel = 0, choiceNum = 0, editorNum = 0} + +get :: Alex AlexUserState +get = Alex $ \s -> Right (s, alex_ust s) + +put :: AlexUserState -> Alex () +put s' = Alex $ \s -> Right (s{alex_ust = s'}, ()) + +modify :: (AlexUserState -> AlexUserState) -> Alex () +modify f = Alex $ \s -> Right (s{alex_ust = f (alex_ust s)}, ()) + +alexEOF :: Alex RangedToken +alexEOF = do + startCode <- alexGetStartCode + when (startCode == comment) $ + alexError "Error: unclosed comment" + (pos, _, _, _) <- alexGetInput + pure $ RangedToken EOF (Range pos pos) + +data Range = Range + { start :: AlexPosn + , stop :: AlexPosn + } deriving (Eq, Show) + +data RangedToken = RangedToken + { rtToken :: Token + , rtRange :: Range + } deriving (Eq, Show) + +data Token + -- Identifiers + = Identifier Text + -- Constants + | String Text + | Number Text + | Rest + -- Operators + | Operator Text + | SpecialOp Text + -- Repeat + | Repeat + | RepeatNum Text + -- Parenthesis + | LPar + | RPar + -- Sequences + | LBrack + | RBrack + -- Stacks + | Comma + -- Alternations + | LAngle + | RAngle + -- Choice + | Pipe + -- Polyrhythm + | Poly + -- Euclid + | LBraces + | RBraces + -- Lambda + | Lambda + | Arrow + -- Enum + | Enum + -- Actions + | Colon + | StreamA + | TempoCps + | TempoBpm + | TypeA + | ShowA + | ConfigA + | ResetConfigA + | Assign + | LoadA Text + | InfoA + -- Line & Block Tokens + | LineT Text + | BlockSep + -- Type Tokens + | Context + | TextToken + | NumberToken + | MapToken + | BusToken + | VarToken Text + | TypeClass Text + -- EOF + | EOF + deriving (Eq) + +instance Show Token where + show (Identifier s) = show s + show (String s) = show s + show (Number d) = show d + show Rest = quoted "~" + show (Operator o) = show o + show (SpecialOp o) = show o + show Repeat = quoted "!" + show (RepeatNum x) = quoted "!" ++ show x + show LPar = quoted "(" + show RPar = quoted ")" + show LBrack = quoted "[" + show RBrack = quoted "]" + show Comma = quoted "," + show LAngle = quoted "<" + show RAngle = quoted ">" + show Pipe = quoted "|" + show Poly = quoted "%" + show LBraces = quoted "{" + show RBraces = quoted "}" + show Lambda = quoted "\\" + show Arrow = quoted "->" + show Colon = quoted ";" + show Enum = quoted ".." + show StreamA = quoted "<-" + show TempoCps = ":cps" + show TempoBpm = ":bpm" + show TypeA = quoted ":t" + show ShowA = quoted ":show" + show ConfigA = quoted ":config" + show ResetConfigA = quoted ":resetconfig" + show Assign = quoted "=" + show (LoadA x) = ":load " <> show x + show InfoA = quoted ":info" + show (LineT t) = "line " <> show t + show BlockSep = "block" + show Context = "=>" + show TextToken = "Text" + show NumberToken = "Number" + show MapToken = "Map" + show BusToken = "Bus" + show (VarToken t) = show t + show (TypeClass c) = show c + show EOF = "end of file" + +quoted :: String -> String +quoted s = "'" ++ s ++ "'" + +mkRange :: AlexInput -> Int -> Range +mkRange (st, _, _, str) len = Range{start = st, stop = end} + where + end = Text.foldl' alexMove st $ Text.take len str + +mkLine :: AlexAction RangedToken +mkLine inp@(_, _, _, str) len = case Text.all (\c -> elem c ("\n\t " :: String)) (Text.take len str) of + True -> tok BlockSep inp len + False -> pure RangedToken + { rtToken = LineT $ Text.map replaceTab (Text.take len str) + , rtRange = mkRange inp len + } + +-- | replace all tabs with a single space, since codemirror sees tabs as one column +replaceTab :: Char -> Char +replaceTab '\t' = ' ' +replaceTab x = x + +rmFirstLast :: Text -> Text +rmFirstLast t = Text.init (Text.tail t) + +tok :: Token -> AlexAction RangedToken +tok ctor inp len = + pure RangedToken + { rtToken = ctor + , rtRange = mkRange inp len + } + +tokText :: (Text -> Token) -> AlexAction RangedToken +tokText f inp@(_, _, _, str) len = + pure RangedToken + { rtToken = f $ Text.take len str + , rtRange = mkRange inp len + } + +nestComment :: AlexAction RangedToken +nestComment input len = do + modify $ \s -> s{nestLevel = nestLevel s + 1} + skip input len + +unnestComment :: AlexAction RangedToken +unnestComment input len = do + state <- get + let level = nestLevel state - 1 + put state{nestLevel = level} + when (level == 0) $ + alexSetStartCode 0 + skip input len + +increaseChoice :: Alex Int +increaseChoice = do + (AlexUserState c x e) <- get + put $ AlexUserState c (x+1) e + return x + +getEditorNum :: Alex Int +getEditorNum = do + (AlexUserState _ _ e) <- get + return e + +setEditorNum :: Int -> Alex () +setEditorNum i = do + (AlexUserState c x _) <- get + put $ AlexUserState c x i + +setInitialLineNum :: Int -> Alex () +setInitialLineNum i = Alex alex + where alex s = Right (s {alex_pos = AlexPn x i c }, ()) + where AlexPn x _ c = alex_pos s + +lineLexer :: Alex () +lineLexer = alexSetStartCode line + +typeLexer :: Alex () +typeLexer = alexSetStartCode ty + +scanMany :: Text -> Either String [RangedToken] +scanMany input = runAlex input go + where + go = do + output <- lineLexer >> alexMonadScan + if rtToken output == EOF + then pure [output] + else ((output) :) <$> go +} diff --git a/src/Zwirn/Language/Parser.y b/src/Zwirn/Language/Parser.y new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Parser.y @@ -0,0 +1,375 @@ +{ +{-# LANGUAGE OverloadedStrings #-} +module Zwirn.Language.Parser + ( parseActionsWithPos + , parseActions + , parseBlocks + , parseScheme + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Maybe (fromJust) +import Data.Monoid (First (..)) +import Data.List (intercalate, sortOn) + +import qualified Zwirn.Language.Lexer as L +import Zwirn.Language.Syntax +import Zwirn.Language.TypeCheck.Types +import Zwirn.Language.TypeCheck.Infer +import Zwirn.Language.Block + +{- + Parser.hs - parser for zwirn, code adapted from + https://serokell.io/blog/parsing-with-happy + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + + +} + +%name parse term +%name pActions actions +%name pBlocks blocks +%name pScheme scheme +%tokentype { L.RangedToken } +%errorhandlertype explist +%error { parseError } +%monad { L.Alex } { >>= } { pure } +%lexer { lexer } { L.RangedToken L.EOF _ } +%expect 0 + +%token + -- Identifiers + identifier { L.RangedToken (L.Identifier _) _ } + -- Operators + operator { L.RangedToken (L.Operator _) _ } + specop { L.RangedToken (L.SpecialOp _) _ } + -- Constants + string { L.RangedToken (L.String _) _ } + number { L.RangedToken (L.Number _) _ } + line { L.RangedToken (L.LineT _) _ } + bsep { L.RangedToken (L.BlockSep) _ } + '~' { L.RangedToken L.Rest _ } + -- Repeat + '!' { L.RangedToken L.Repeat _ } + repnum { L.RangedToken (L.RepeatNum _) _} + -- Parenthesis + '(' { L.RangedToken L.LPar _ } + ')' { L.RangedToken L.RPar _ } + -- Sequences + '[' { L.RangedToken L.LBrack _ } + ']' { L.RangedToken L.RBrack _ } + -- Stacks + ',' { L.RangedToken L.Comma _ } + -- Alternations + '<' { L.RangedToken L.LAngle _ } + '>' { L.RangedToken L.RAngle _ } + -- Choice + '|' { L.RangedToken L.Pipe _ } + -- Enum + '..' { L.RangedToken L.Enum _ } + -- Polyrhythm + '%' { L.RangedToken L.Poly _ } + -- Lambda + '\\' { L.RangedToken L.Lambda _ } + '->' { L.RangedToken L.Arrow _ } + -- Actions + ';' { L.RangedToken L.Colon _ } + '<-' { L.RangedToken L.StreamA _ } + ':cps' { L.RangedToken L.TempoCps _ } + ':bpm' { L.RangedToken L.TempoBpm _ } + ':t' { L.RangedToken L.TypeA _ } + ':show' { L.RangedToken L.ShowA _ } + ':config' { L.RangedToken L.ConfigA _ } + ':resetconfig' { L.RangedToken L.ResetConfigA _ } + '=' { L.RangedToken L.Assign _ } + ':load' { L.RangedToken (L.LoadA _ ) _} + ':info' { L.RangedToken L.InfoA _ } + -- Type Tokens + '=>' { L.RangedToken L.Context _ } + textT { L.RangedToken L.TextToken _ } + numT { L.RangedToken L.NumberToken _ } + mapT { L.RangedToken L.MapToken _ } + busT { L.RangedToken L.BusToken _ } + varT { L.RangedToken (L.VarToken _) _ } + classT { L.RangedToken (L.TypeClass _) _ } + +%% + +------------------------------------------------------------- +------------------------- utilities ------------------------- +------------------------------------------------------------- + +optional(p) + : { Nothing } + | p { Just $1 } + +many_rev(p) + : { [] } + | many_rev(p) p { $2 : $1 } + +many(p) + : many_rev(p) { reverse $1 } + +some_rev(p) + : p { [$1] } + | some_rev(p) p { $2 : $1 } + +some(p) + : some_rev(p) { reverse $1 } + +sepBy_rev(p, sep) + : p { [$1] } + | sepBy_rev(p, sep) sep p { $3 : $1 } + +sepBy(p, sep) + : sepBy_rev(p, sep) { reverse $1 } + +sepBy_rev2(p, sep) + : p sep p { [$3, $1] } + | sepBy_rev2(p, sep) sep p { $3 : $1 } + +sepBy2(p, sep) + : sepBy_rev2(p, sep) { reverse $1 } + +------------------------------------------------------------- +----------------------- parsing terms ----------------------- +------------------------------------------------------------- + +atom :: { Term } + : identifier { % (mkAtom TVar) $1 } + | number { % (mkAtom TNum) $1 } + | string { % (mkAtom TText) $1 } + | '~' { TRest } + +simpleseq :: { [Term] } + : infix %shift { [$1] } + | infix simpleseq { $1: $2 } + +seq :: { Term } + : simpleseq { TSeq $1 } + | infix '..' infix { TEnum Run $1 $3 } + | infix infix '..' infix { TEnumThen Run $1 $2 $4 } + | { TRest } + +sequence :: { Term } + : '[' seq ']' { $2 } + +choice :: { Term } + : '[' sepBy2(simpleseq, '|') ']' { % L.increaseChoice >>= \x -> return $ TChoice x (map TSeq $2) } + | '[' simpleseq '|' '..' simpleseq ']' { TEnum Choice (TSeq $2) (TSeq $5) } + | '[' simpleseq '|' simpleseq '..' simpleseq ']' { TEnumThen Choice (TSeq $2) (TSeq $4) (TSeq $6) } + +lambda :: { Term } + : '\\' some(identifier) '->' term %shift { TLambda (map unTok $2) $4 } + +polyrhythm :: { Term } + : simple '%' simple %shift { TPoly $1 $3 } + +repeat :: { Term } + : simple repnum { TRepeat $1 (Just $ read $ Text.unpack $ unTok $2) } + | simple '!' { TRepeat $1 Nothing } + +stack :: { Term } + : '[' sepBy2(simpleseq, ',') ']' { TStack (map TSeq $2) } + | '[' simpleseq ',' '..' simpleseq ']' { TEnum Cord (TSeq $2) (TSeq $5) } + | '[' simpleseq ',' simpleseq '..' simpleseq ']' { TEnumThen Cord (TSeq $2) (TSeq $4) (TSeq $6) } + +alt :: { Term } + : simpleseq { TAlt $1 } + | infix '..' infix { TEnum Alt $1 $3 } + | infix infix '..' infix { TEnumThen Alt $1 $2 $4 } + +alternation :: { Term } + : '<' alt '>' { $2 } + +bracket :: { Term } + : '(' term ')' { TBracket $2 } + +simple :: { Term } + : atom { $1 } + | alternation { $1 } + | sequence { $1 } + | choice { $1 } + | stack { $1 } + | lambda { $1 } + | polyrhythm { $1 } + | repeat { $1 } + | bracket { $1 } + +-- special operators are left-associative +specialinfix :: { Term } + : specialinfix specop simple %shift { TInfix $1 (unTok $2) $3 } + | simple %shift { $1 } + +-- all other operators are assumed to be right-associative, AST rotation will fix it +-- this definition is for use inside of sequences +infix :: { Term } + : specialinfix operator infix %shift { TInfix $1 (unTok $2) $3 } + | specialinfix %shift { $1 } + +-- application is left-associative, binds stronger than operators +-- outside of sequences +app :: { Term } + : app specialinfix %shift { TApp $1 $2 } + | specialinfix %shift {$1} + +sectionR :: { Term } + : operator app %shift { TSectionR (unTok $1) $2 } + +sectionL :: { Term } + : app operator %shift { TSectionL $1 (unTok $2) } + +-- operators outside of sequences have the weakest binding +term :: { Term } + : app operator term %shift { TInfix $1 (unTok $2) $3 } + | app %shift { $1 } + | sectionR %shift { $1 } + | sectionL %shift { $1 } + +------------------------------------------------------------- +---------------------- parsing actions ---------------------- +------------------------------------------------------------- + +def :: { Def } + : identifier many(identifier) '=' term { Let (unTok $1) (map unTok $2) $4 } + +action :: { Action } + : string '<-' term { StreamAction (unTok $1) $3 } + | number '<-' term { StreamAction (unTok $1) $3 } + | identifier '<-' term { StreamSet (unTok $1) $3 } + | ':cps' number { StreamSetTempo CPS (unTok $2) } + | ':bpm' number { StreamSetTempo BPM (unTok $2) } + | '!' term { StreamOnce $2 } + | ':config' { ConfigPath } + | ':resetconfig' { ResetConfig } + | def { Def $1 } + | ':t' term { Type $2 } + | ':show' term { Show $2 } + | ':load' { Load $ unTok $1 } + | ':info' identifier { Info $ unTok $2 } + +actionsrecrev :: { [Action] } + : actionsrecrev ';' action { $3:$1 } + | action { [$1] } + +actions :: { [Action] } + : actionsrecrev ';' { reverse $1 } + | actionsrecrev { reverse $1 } + | { [] } + +------------------------------------------------------------- +----------------------- parsing blocks ---------------------- +------------------------------------------------------------- + +block :: { Block } + : some(line) { toBlock $1 } + +blocksrec :: { [Block] } + : blocksrec some(bsep) block { $3:$1 } + | block { [$1] } + +blocks :: { [Block] } + : some(bsep) blocksrec some(bsep) { $2 } + | some(bsep) blocksrec { $2 } + | blocksrec some(bsep) { $1 } + | blocksrec { $1 } + +------------------------------------------------------------- +----------------------- parsing types ----------------------- +------------------------------------------------------------- + +atomType :: { Type } + : textT { TypeCon "Text" } + | numT { TypeCon "Number" } + | mapT { TypeCon "Map" } + | busT { TypeCon "Bus" } + | varT { TypeVar (unTok $1) } + +fullType :: { Type } + : atomType { $1 } + | fullType '->' fullType %shift { TypeArr $1 $3 } + | '(' fullType ')' { $2 } + +predicate :: { Predicate } + : classT varT { IsIn (unTok $1) (TypeVar (unTok $2))} + +predicates :: { [Predicate] } + : predicate '=>' { [$1] } + | { [] } + +scheme :: { Scheme } + : predicates fullType %shift { generalize $1 $2 } + + +{ + +parseError :: (L.RangedToken, [String]) -> L.Alex a +parseError (L.RangedToken t _,poss) = do + (L.AlexPn _ ln column, _, _, _) <- L.alexGetInput + L.alexError $ "Parse error at line " <> show ln <> ", column " <> show column + <> "\n\tunexpected " <> show t + <> "\n\texpecting " <> (intercalate "," poss) + +lexer :: (L.RangedToken -> L.Alex a) -> L.Alex a +lexer = (=<< L.alexMonadScan) + +unTok :: L.RangedToken -> Text +unTok (L.RangedToken (L.Identifier x) _) = x +unTok (L.RangedToken (L.Number x) _ ) = x +unTok (L.RangedToken (L.String x) _ )= x +unTok (L.RangedToken (L.Operator x) _) = x +unTok (L.RangedToken (L.SpecialOp x) _) = x +unTok (L.RangedToken (L.LoadA x) _) = x +unTok (L.RangedToken (L.LineT x) _) = x +unTok (L.RangedToken (L.VarToken x) _) = x +unTok (L.RangedToken (L.TypeClass x) _) = x +unTok (L.RangedToken (L.RepeatNum x) _) = x +unTok _ = error "can't untok" + + +mkAtom :: (Position -> Text -> Term) -> L.RangedToken -> L.Alex Term +mkAtom constr tok@(L.RangedToken _ range) = do + ed <- L.getEditorNum + return $ constr (toPosition ed range) (unTok tok) + +toPosition :: Int -> L.Range -> Position +toPosition ed (L.Range (L.AlexPn _ line start) (L.AlexPn _ _ end)) = Pos line start end ed + +toBlock :: [L.RangedToken] -> Block +toBlock [] = error "Can't happen" +toBlock xs = Block start end content + where ls = sortOn (\(x,_) -> x) $ map (\r -> (getLn r,unTok r)) xs + (start, _) = head ls + (end, _) = last ls + content = Text.concat $ map snd ls + getLn (L.RangedToken _ (L.Range (L.AlexPn _ l _) _)) = l + + +parseActionsWithPos :: Int -> Int -> Text -> Either String [Action] +parseActionsWithPos ln ed input = L.runAlex input (L.setEditorNum ed >> L.setInitialLineNum ln >> pActions) + +parseActions :: Text -> Either String [Action] +parseActions input = L.runAlex input pActions + +parseBlocks :: Int -> Text -> Either String [Block] +parseBlocks line input = L.runAlex input (L.lineLexer >> L.setInitialLineNum line >> pBlocks) + +parseScheme :: Text -> Either String Scheme +parseScheme input = L.runAlex input (L.typeLexer >> pScheme) + +} diff --git a/src/Zwirn/Language/Pretty.hs b/src/Zwirn/Language/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Pretty.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Zwirn.Language.Pretty + ( ppterm, + ppscheme, + ppTermHasType, + ) +where + +{- + Pretty.hs - pretty printer for the AST and the types + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.List (intercalate) +import Data.Text (unpack) +import Text.PrettyPrint +import Zwirn.Language.Syntax +import Zwirn.Language.TypeCheck.Constraint +import Zwirn.Language.TypeCheck.Types +import Prelude hiding ((<>)) + +parensIf :: Bool -> Doc -> Doc +parensIf True = parens +parensIf False = id + +class Pretty p where + ppr :: Int -> p -> Doc + +instance Pretty Name where + ppr _ x = text $ unpack x + +instance Pretty Type where + ppr p (TypeArr a b) = parensIf (isArrow a) (ppr p a) <+> text "->" <+> ppr p b + where + isArrow TypeArr {} = True + isArrow _ = False + ppr p (TypeVar a) = ppr p a + ppr _ (TypeCon a) = text $ unpack a + +instance Pretty Predicate where + ppr p (IsIn c t) = text (unpack c) <+> ppr p t + +instance Pretty [Predicate] where + ppr p ps = parensIf (length ps > 1) (hcat (punctuate comma (map (ppr p) ps))) + +instance Pretty (Qualified Type) where + ppr p (Qual [] t) = ppr p t + ppr p (Qual ps t) = ppr p ps <+> text "=>" <+> ppr p t + +instance Pretty Scheme where + ppr p (Forall _ t) = ppr p t + +instance Pretty Term where + ppr _ (TVar _ x) = text $ unpack x + ppr _ TRest = text "~" + ppr _ (TText _ x) = text $ unpack x + ppr _ (TNum _ x) = double $ read $ unpack x + ppr p (TRepeat t (Just i)) = ppr p t <> text "!" <> int i + ppr p (TRepeat t Nothing) = ppr p t <> text "!" + ppr p (TSeq [t]) = ppr p t + ppr p (TSeq ts) = brackets (hcat (punctuate space (map (ppr p) ts))) + ppr p (TAlt ts) = text "<" <> hcat (punctuate space (map (ppr p) ts)) <> text ">" + ppr p (TChoice _ ts) = brackets (hcat $ punctuate (text "|") (map (ppr p) ts)) + ppr p (TStack ts) = brackets (hcat $ punctuate comma (map (ppr p) ts)) + ppr p (TPoly t1 t2) = ppr p t1 <> text "%" <> ppr p t2 + ppr p (TApp t1 t2) = parensIf (p > 0) (ppr (p + 1) t1 <+> ppr p t2) + ppr p (TInfix t1 n t2) = ppr p t1 <+> text (unpack n) <+> ppr p t2 + ppr p (TBracket t) = parens (ppr p t) + ppr p (TLambda vs t) = text "\\" <> hcat (punctuate space $ map (text . unpack) vs) <+> text "->" <+> ppr p t + ppr p (TSectionL t n) = ppr p t <+> text (unpack n) + ppr p (TSectionR n t) = text (unpack n) <+> ppr p t + ppr p (TEnum Run x y) = brackets (ppr p x <+> text ".." <+> ppr p y) + ppr p (TEnumThen Alt x y z) = text "<" <> (ppr p x <+> ppr p y <+> text ".." <+> ppr p z) <> text ">" + ppr p (TEnum Alt x y) = text "<" <> (ppr p x <+> text ".." <+> ppr p y) <> text ">" + ppr p (TEnumThen Run x y z) = brackets (ppr p x <+> ppr p y <+> text ".." <+> ppr p z) + ppr p (TEnum Cord x y) = brackets (ppr p x <+> text ", .." <+> ppr p y) + ppr p (TEnumThen Cord x y z) = brackets (ppr p x <+> text "," <+> ppr p y <+> text ".." <+> ppr p z) + ppr p (TEnum Choice x y) = brackets (ppr p x <+> text "| .. " <+> ppr p y) + ppr p (TEnumThen Choice x y z) = brackets (ppr p x <+> text "|" <+> ppr p y <+> text ".." <+> ppr p z) + +instance Pretty (Term, Scheme) where + ppr p (t, s) = ppr p t <+> text "::" <+> ppr p s + +pptype :: Type -> String +pptype = render . ppr 0 + +ppscheme :: Scheme -> String +ppscheme = render . ppr 0 + +ppterm :: Term -> String +ppterm = render . ppr 0 + +ppTermHasType :: (Term, Scheme) -> String +ppTermHasType = render . ppr 0 + +instance Show TypeError where + show (UnificationFail a b) = + concat ["Cannot unify types: \n\t", pptype a, " ~ ", pptype b] + show (UnificationMismatch as bs) = + concat ["Cannot unify types: \n\t", intercalate "," $ map pptype as, " ~ ", intercalate "," $ map pptype bs] + show (InfiniteType a b) = + concat ["Cannot construct the infinite type: ", unpack a, " = ", pptype b] + show (Ambigious cs) = + concat ["Cannot not match expected type: '" ++ pptype a ++ "' with actual type: '" ++ pptype b ++ "'\n" | (a, b) <- cs] + show (UnboundVariable a) = "Not in scope: " ++ unpack a + show (NoInstance (IsIn c x)) = "No instance for " ++ unpack c ++ " " ++ pptype x diff --git a/src/Zwirn/Language/Rotate.hs b/src/Zwirn/Language/Rotate.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Rotate.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zwirn.Language.Rotate + ( runRotate, + runRotateUnsafe, + RotationError, + ) +where + +{- + Rotate.hs - syntax tree rotation, code adapted from + https://gist.github.com/heitor-lassarote/b20d6da0a9042d31e439befb8c236a4e + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Control.Monad.Except +import Control.Monad.Identity +import Zwirn.Language.Simple +import Zwirn.Language.Syntax + +ops :: [Declaration] +ops = + [ ("*", Fixity LeftA 9), + ("/", Fixity LeftA 9), + ("$", Fixity RightA 0), + ("$|", Fixity RightA 0), + ("|$", Fixity RightA 0), + (".", Fixity RightA 9), + ("#", Fixity RightA 3), + ("++", Fixity RightA 4), + ("+", Fixity LeftA 6), + ("|+", Fixity LeftA 6), + ("+|", Fixity LeftA 6), + ("|*", Fixity LeftA 7), + ("*|", Fixity LeftA 7), + ("//", Fixity LeftA 7), + ("|/", Fixity LeftA 7), + ("/|", Fixity LeftA 7) + ] + +defaultFixity :: Fixity +defaultFixity = Fixity LeftA 8 + +type RotationError = String + +type Rotate a = ExceptT RotationError Identity a + +-- | Describes which action the rotation algorithm should use. +data Rotation + = -- | Fail due to the mixing of incompatible operators. + Fail + | -- | Keep the tree as it is. + Keep + | -- | Balance the tree to the left. + Rotate + +runRotate :: SimpleTerm -> Either RotationError SimpleTerm +runRotate t = runIdentity $ runExceptT $ rotate t + +runRotateUnsafe :: SimpleTerm -> SimpleTerm +runRotateUnsafe t = case runRotate t of + Left err -> error $ show err + Right r -> r + +-- | The Happy parser is written in a way so that it will always create a right-balanced AST. +-- We compare the operators and indicate how to rotate the tree. +shouldRotate :: Fixity -> Fixity -> Rotation +shouldRotate (Fixity a p) (Fixity a' p') = case compare p p' of + LT -> Keep + EQ -> case (a, a') of + (LeftA, LeftA) -> Rotate + (RightA, RightA) -> Keep + (_, _) -> Fail + GT -> Rotate + +-- | Rebalances the tree to respect the associativity and precedence of the +-- parsed operators. + +-- Not very efficient, but enough for demonstration purposes. +findOp :: OperatorSymbol -> Rotate Fixity +findOp o = case lookup o ops of + Just d -> return d + Nothing -> return defaultFixity + +rotate :: SimpleTerm -> Rotate SimpleTerm +rotate (SInfix l op r) = do + -- Rotating the left side is unneeded since this grammar is very simple. + -- This is because trees are always right-balanced and the left side is + -- always an atom. + lRotated <- rotate l + rRotated <- rotate r + case rRotated of + SInfix l' op' r' -> do + opDec <- findOp op + opDec' <- findOp op' + case shouldRotate opDec opDec' of + Fail -> throwError "can't handle precedence of operators" + Keep -> return $ SInfix lRotated op rRotated + Rotate -> return $ SInfix (SInfix lRotated op l') op' r' + _ -> return $ SInfix lRotated op rRotated +rotate (SApp l r) = do + lRotated <- rotate l + rRotated <- rotate r + return $ SApp lRotated rRotated +rotate e@(SVar _ _) = return e +rotate e@(SText _ _) = return e +rotate e@(SNum _ _) = return e +rotate SRest = return SRest +rotate (SSeq ts) = fmap SSeq (mapM rotate ts) +rotate (SStack ts) = fmap SStack (mapM rotate ts) +rotate (SChoice n ts) = fmap (SChoice n) (mapM rotate ts) +rotate (SLambda vs t) = SLambda vs <$> rotate t +rotate (SBracket t) = fmap SBracket (rotate t) diff --git a/src/Zwirn/Language/Simple.hs b/src/Zwirn/Language/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Simple.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zwirn.Language.Simple + ( simplify, + simplifyDef, + SimpleTerm (..), + SimpleDef (..), + Position (..), + ) +where + +{- + Simple.hs - desugaring of the zwirn AST + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Text as Text (Text, filter, pack) +import Zwirn.Language.Syntax + +-- simple representation of patterns +data SimpleTerm + = SVar (Maybe Position) Var + | SText Position Text + | SNum (Maybe Position) Text + | SRest + | SSeq [SimpleTerm] + | SStack [SimpleTerm] + | SChoice Int [SimpleTerm] + | SLambda Var SimpleTerm + | SApp SimpleTerm SimpleTerm + | SInfix SimpleTerm OperatorSymbol SimpleTerm + | SBracket SimpleTerm + deriving (Eq, Show) + +data SimpleDef + = LetS Var SimpleTerm + deriving (Eq, Show) + +simplify :: Term -> SimpleTerm +simplify (TVar p x) = SVar (Just p) x +simplify (TText p x) = SText p $ stripText x + where + stripText = Text.filter (/= '\"') +simplify (TNum p x) = SNum (Just p) x +simplify TRest = SRest +simplify x@(TRepeat _ _) = SSeq $ map simplify $ resolveRepeat x +simplify (TSeq ts) = SSeq (map simplify $ concatMap resolveRepeat ts) +simplify (TStack ts) = SStack (map simplify ts) +simplify (TChoice i ts) = SChoice i (map simplify ts) +simplify (TAlt ts) = SBracket $ SInfix (SSeq ss) "/" (SNum Nothing (pack $ show $ length ss)) + where + ss = map simplify $ concatMap resolveRepeat ts +simplify (TPoly (TSeq ts) n) = SBracket $ SInfix (SInfix (SSeq ss) "/" (SNum Nothing (pack $ show $ length ss))) "*" (simplify n) + where + ss = map simplify $ concatMap resolveRepeat ts +simplify (TPoly x n) = SInfix (simplify x) "*" (simplify n) +simplify (TLambda [] t) = simplify t +simplify (TLambda (x : xs) t) = SLambda x (simplify $ TLambda xs t) +simplify (TApp x y) = SApp (simplify x) (simplify y) +simplify (TInfix x op y) = SInfix (simplify x) op (simplify y) +simplify (TSectionR op y) = SLambda "_x" (SInfix (SVar Nothing "_x") op (simplify y)) +simplify (TSectionL x op) = SLambda "_x" (SInfix (simplify x) op (SVar Nothing "_x")) +simplify (TBracket x) = SBracket (simplify x) +simplify (TEnum Run x y) = SApp (SApp (SVar Nothing "runFromTo") (simplify x)) (simplify y) +simplify (TEnumThen Run x y z) = SApp (SApp (SApp (SVar Nothing "runFromThenTo") (simplify x)) (simplify y)) (simplify z) +simplify (TEnum Alt x y) = SApp (SApp (SVar Nothing "slowrunFromTo") (simplify x)) (simplify y) +simplify (TEnumThen Alt x y z) = SApp (SApp (SApp (SVar Nothing "slowrunFromThenTo") (simplify x)) (simplify y)) (simplify z) +simplify (TEnum Cord x y) = SApp (SApp (SVar Nothing "cordFromTo") (simplify x)) (simplify y) +simplify (TEnumThen Cord x y z) = SApp (SApp (SApp (SVar Nothing "cordFromThenTo") (simplify x)) (simplify y)) (simplify z) +simplify (TEnum Choice x y) = SApp (SApp (SVar Nothing "chooseFromTo") (simplify x)) (simplify y) +simplify (TEnumThen Choice x y z) = SApp (SApp (SApp (SVar Nothing "chooseFromThenTo") (simplify x)) (simplify y)) (simplify z) + +simplifyDef :: Def -> SimpleDef +simplifyDef (Let x vs t) = LetS x (simplify $ TLambda vs t) + +resolveRepeat :: Term -> [Term] +resolveRepeat t = case getTotalRepeat t of + TRepeat x (Just i) -> replicate i x + TRepeat x Nothing -> [x, x] + x -> [x] + +-- TODO : not completely right when Nothing followed by Just... +getRepeat :: (Term, Int) -> Term +getRepeat (TRepeat x (Just j), k) = getRepeat (x, j * k) +getRepeat (TRepeat x Nothing, k) = getRepeat (x, k + 1) +getRepeat (x, j) = TRepeat x (Just j) + +getTotalRepeat :: Term -> Term +getTotalRepeat (TRepeat t (Just i)) = getRepeat (t, i) +getTotalRepeat (TRepeat t Nothing) = getRepeat (t, 2) +getTotalRepeat t = t diff --git a/src/Zwirn/Language/Syntax.hs b/src/Zwirn/Language/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/Syntax.hs @@ -0,0 +1,95 @@ +module Zwirn.Language.Syntax where + +{- + Syntax.hs - definition of the zwirn language, + inspired by tidals mini-notation + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Text (Text) + +type Var = Text + +type OperatorSymbol = Text + +data Position = Pos + { pLine :: Int, + pStart :: Int, + pEnd :: Int, + pEditor :: Int + } + deriving (Eq, Show) + +data EnumKind = Cord | Choice | Run | Alt deriving (Eq, Show) + +-- sugary representation of patterns +data Term + = TVar Position Text + | TText Position Text + | TNum Position Text + | TRest + | TRepeat Term (Maybe Int) + | TSeq [Term] + | TStack [Term] + | TAlt [Term] + | TChoice Int [Term] + | TPoly Term Term + | TLambda [Text] Term + | TApp Term Term + | TInfix Term Text Term + | TSectionR Text Term + | TSectionL Term Text + | TBracket Term + | TEnum EnumKind Term Term + | TEnumThen EnumKind Term Term Term + deriving (Eq, Show) + +data Def + = Let Text [Text] Term + deriving (Eq, Show) + +data Tempo + = CPS + | BPM + deriving (Eq, Show) + +data Action + = StreamAction Text Term + | StreamSet Text Term + | StreamOnce Term + | StreamSetTempo Tempo Text + | ConfigPath + | ResetConfig + | Def Def + | Type Term + | Show Term + | Load Text + | Info Text + deriving (Eq, Show) + +data Associativity + = NonA + | LeftA + | RightA + deriving (Eq, Show) + +type Precedence = Int + +data Fixity + = Fixity Associativity Precedence + deriving (Eq, Show) + +type Declaration = (OperatorSymbol, Fixity) diff --git a/src/Zwirn/Language/TypeCheck/Constraint.hs b/src/Zwirn/Language/TypeCheck/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/TypeCheck/Constraint.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Zwirn.Language.TypeCheck.Constraint + ( Substitutable (..), + Subst (..), + TypeError (..), + Constraint, + runSolve, + ) +where + +{- + Constraint.hs - unification constraint solver adapted from + https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Control.Monad.Except +import Control.Monad.Identity +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (Text) +import Zwirn.Language.Environment +import Zwirn.Language.TypeCheck.Types + +data TypeError + = UnificationFail Type Type + | InfiniteType TypeVar Type + | UnboundVariable Text + | Ambigious [Constraint] + | UnificationMismatch [Type] [Type] + | NoInstance Predicate + deriving (Eq) + +type Constraint = (Type, Type) + +newtype Subst = Subst (Map.Map TypeVar Type) + deriving (Eq, Ord, Show, Semigroup, Monoid) + +type Unifier = (Subst, [Constraint]) + +-- | Constraint solver monad +type Solve a = ExceptT TypeError Identity a + +class Substitutable a where + apply :: Subst -> a -> a + ftv :: a -> Set.Set TypeVar + +instance Substitutable Type where + apply _ (TypeCon a) = TypeCon a + apply (Subst s) t@(TypeVar a) = Map.findWithDefault t a s + apply s (t1 `TypeArr` t2) = apply s t1 `TypeArr` apply s t2 + + ftv TypeCon {} = Set.empty + ftv (TypeVar a) = Set.singleton a + ftv (t1 `TypeArr` t2) = ftv t1 `Set.union` ftv t2 + +instance Substitutable Scheme where + apply (Subst s) (Forall as t) = Forall as $ apply s' t + where + s' = Subst $ foldr Map.delete s as + ftv (Forall as t) = ftv t `Set.difference` Set.fromList as + +instance Substitutable Constraint where + apply s (t1, t2) = (apply s t1, apply s t2) + ftv (t1, t2) = ftv t1 `Set.union` ftv t2 + +instance Substitutable AnnotatedExpression where + apply s (Annotated x sc d) = Annotated x (apply s sc) d + ftv (Annotated _ s _) = ftv s + +instance (Substitutable a) => Substitutable [a] where + apply = map . apply + ftv = foldr (Set.union . ftv) Set.empty + +instance Substitutable InterpreterEnv where + apply s (IEnv ty cl) = IEnv (Map.map (apply s) ty) (apply s cl) + ftv (IEnv ty cl) = ftv (Map.elems ty) `Set.union` ftv cl + +instance Substitutable Predicate where + apply s (IsIn x t) = IsIn x (apply s t) + ftv (IsIn _ t) = ftv t + +instance (Substitutable t) => Substitutable (Qualified t) where + apply s (Qual ps t) = Qual (apply s ps) (apply s t) + ftv (Qual ps t) = ftv ps `Set.union` ftv t + +------------------------------------------------------------------------------- +-- Constraint Solver +------------------------------------------------------------------------------- + +-- | The empty substitution +emptySubst :: Subst +emptySubst = mempty + +-- | Compose substitutions +compose :: Subst -> Subst -> Subst +(Subst s1) `compose` (Subst s2) = Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1 + +-- | Run the constraint solver +runSolve :: [Constraint] -> Either TypeError Subst +runSolve cs = runIdentity $ runExceptT $ solver st + where + st = (emptySubst, cs) + +unifyMany :: [Type] -> [Type] -> Solve Subst +unifyMany [] [] = return emptySubst +unifyMany (t1 : ts1) (t2 : ts2) = + do + su1 <- unifies t1 t2 + su2 <- unifyMany (apply su1 ts1) (apply su1 ts2) + return (su2 `compose` su1) +unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2 + +unifies :: Type -> Type -> Solve Subst +unifies t1 t2 | t1 == t2 = return emptySubst +unifies (TypeVar v) t = v `bind` t +unifies t (TypeVar v) = v `bind` t +unifies (TypeArr t1 t2) (TypeArr t3 t4) = unifyMany [t1, t2] [t3, t4] +unifies t1 t2 = throwError $ UnificationFail t1 t2 + +-- Unification solver +solver :: Unifier -> Solve Subst +solver (su, cs) = + case cs of + [] -> return su + ((t1, t2) : cs0) -> do + su1 <- unifies t1 t2 + solver (su1 `compose` su, apply su1 cs0) + +bind :: TypeVar -> Type -> Solve Subst +bind a t + | t == TypeVar a = return emptySubst + | occursCheck a t = throwError $ InfiniteType a t + | otherwise = return (Subst $ Map.singleton a t) + +occursCheck :: (Substitutable a) => TypeVar -> a -> Bool +occursCheck a t = a `Set.member` ftv t diff --git a/src/Zwirn/Language/TypeCheck/Infer.hs b/src/Zwirn/Language/TypeCheck/Infer.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/TypeCheck/Infer.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zwirn.Language.TypeCheck.Infer + ( inferTerm, + generalize, + ) +where + +{- + Infer.hs - type inference algorithm adapted from + https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Control.Monad (replicateM) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.List (nub) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (Text, pack) +-- import Zwirn.Language.TypeCheck.Env as Env + +import Zwirn.Language.Environment +import Zwirn.Language.Simple +import Zwirn.Language.TypeCheck.Constraint +import Zwirn.Language.TypeCheck.Types + +-- | Inference monad +type Infer a = + ( ReaderT + InterpreterEnv -- Typing environment + ( StateT -- Inference state + InferState + ( Except -- Inference errors + TypeError + ) + ) + a -- Result + ) + +-- | Inference state +newtype InferState = InferState {count :: Int} + +-- | Initial inference state +initInfer :: InferState +initInfer = InferState {count = 0} + +------------------------------------------------------------------------------- +-- Inference +------------------------------------------------------------------------------- + +-- | Run the inference monad +runInfer :: InterpreterEnv -> Infer a -> Either TypeError a +runInfer env m = runExcept $ evalStateT (runReaderT m env) initInfer + +-- | Solve for the toplevel type of an expression in a given environment +inferTerm :: InterpreterEnv -> SimpleTerm -> Either TypeError Scheme +inferTerm env ex = case runInfer env (infer ex) of + Left err -> Left err + Right (ty, ps, cs) -> case runSolve cs of + Left err -> Left err + Right subst -> case runInfer env (filterAndCheck (apply subst ps) (apply subst ty)) of + Left err -> Left err + Right xs -> Right $ closeOver xs $ apply subst ty + +-- | Return the internal constraints used in solving for the type of an expression +-- constraintsTerm :: Env -> SimpleTerm -> Either TypeError ([Constraint], Subst, Type, Scheme) +-- constraintsTerm env ex = case runInfer env (infer ex) of +-- Left err -> Left err +-- Right (ty, cs) -> case runSolve cs of +-- Left err -> Left err +-- Right subst -> Right (cs, subst, ty, sc) +-- where +-- sc = closeOver $ apply subst ty + +-- | Canonicalize and return the polymorphic toplevel type. +closeOver :: [Predicate] -> Type -> Scheme +closeOver ps t = normalize $ generalize ps t + +-- | modified environment where x :: sc +inEnv :: (Name, Scheme) -> Infer a -> Infer a +inEnv (x, sc) m = do + let scope = insertType x sc + local scope m + +-- | Lookup type in the environment +lookupEnv :: Name -> Infer (Type, [Predicate]) +lookupEnv x = do + env <- ask + case lookupType x env of + Nothing -> throwError $ UnboundVariable x + Just s -> instantiate s + +letters :: [Text] +letters = map pack $ [1 ..] >>= flip replicateM ['a' .. 'z'] + +fresh :: Infer Type +fresh = do + s <- get + put s {count = count s + 1} + return $ TypeVar (letters !! count s) + +instantiate :: Scheme -> Infer (Type, [Predicate]) +instantiate (Forall as (Qual ps t)) = do + as' <- mapM (const fresh) as + let s = Subst $ Map.fromList $ zip as as' + return $ (apply s t, apply s ps) + +generalize :: [Predicate] -> Type -> Scheme +generalize ps t = Forall as (Qual ps t) + where + as = Set.toList $ ftv t + +filterAndCheck :: [Predicate] -> Type -> Infer [Predicate] +filterAndCheck [] _ = return [] +filterAndCheck (p@(IsIn _ (TypeVar _)) : ps) t = + if or $ Set.map (\x -> elem x $ ftv p) (ftv t) + then (p :) <$> filterAndCheck ps t + else filterAndCheck ps t +filterAndCheck (p : ps) t = checkInstance p >> filterAndCheck ps t + +checkInstance :: Predicate -> Infer () +checkInstance p = do + (IEnv _ is) <- ask + (if p `elem` is then return () else throwError $ NoInstance p) + +infer :: SimpleTerm -> Infer (Type, [Predicate], [Constraint]) +infer expr = case expr of + SVar _ x -> do + (t, ps) <- lookupEnv x + return (t, ps, []) + SText _ _ -> return (textT, [], []) + SNum _ _ -> return (numberT, [], []) + SBracket s -> infer s + SRest -> do + tv <- fresh + return (tv, [], []) + SLambda x e -> do + tv <- fresh + (t, ps, c) <- inEnv (x, Forall [] (Qual [] tv)) (infer e) + return (tv `TypeArr` t, ps, c) + SApp e1 e2 -> do + (t1, ps1, c1) <- infer e1 + (t2, ps2, c2) <- infer e2 + tv <- fresh + return (tv, ps1 ++ ps2, c1 ++ c2 ++ [(t1, t2 `TypeArr` tv)]) + SInfix e1 op e2 -> do + (t1, ps1, c1) <- infer e1 + (t2, ps2, c2) <- infer e2 + tv <- fresh + let u1 = t1 `TypeArr` (t2 `TypeArr` tv) + (u2, p3) <- lookupEnv op + return (tv, ps1 ++ ps2 ++ p3, c1 ++ c2 ++ [(u1, u2)]) + SSeq (x : xs) -> do + (t, ps, cs) <- infer x + infs <- mapM infer xs + return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs]) + SStack (x : xs) -> do + (t, ps, cs) <- infer x + infs <- mapM infer xs + return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs]) + SChoice _ (x : xs) -> do + (t, ps, cs) <- infer x + infs <- mapM infer xs + return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs]) + _ -> error "Can't happen" + +normalize :: Scheme -> Scheme +normalize (Forall _ (Qual ps body)) = Forall (map snd ord) (Qual (map normpred ps) $ normtype body) + where + ord = zip (nub $ fv body) letters + + fv (TypeVar a) = [a] + fv (TypeArr a b) = fv a ++ fv b + fv (TypeCon _) = [] + + normtype (TypeArr a b) = TypeArr (normtype a) (normtype b) + normtype (TypeCon a) = TypeCon a + normtype (TypeVar a) = + case Prelude.lookup a ord of + Just x -> TypeVar x + Nothing -> error "type variable not in signature" + + normpred (IsIn n t) = IsIn n (normtype t) diff --git a/src/Zwirn/Language/TypeCheck/Types.hs b/src/Zwirn/Language/TypeCheck/Types.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Language/TypeCheck/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zwirn.Language.TypeCheck.Types where + +{- + Types.hs - defintion of types adapted from + https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Data.Text (Text) + +type Name = Text + +type TypeVar = Text + +data Type + = TypeVar TypeVar + | TypeCon Text + | TypeArr Type Type + deriving (Show, Eq, Ord) + +data Predicate + = IsIn Name Type + deriving (Show, Eq, Ord) + +data Qualified t + = Qual [Predicate] t + deriving (Show, Eq, Ord) + +data Scheme + = Forall [TypeVar] (Qualified Type) + deriving (Show, Eq) + +type Instance = Predicate + +numberT :: Type +numberT = TypeCon "Number" + +textT :: Type +textT = TypeCon "Text" + +mapT :: Type +mapT = TypeCon "Map" + +busT :: Type +busT = TypeCon "Bus" + +varA :: Type +varA = TypeVar "a" + +varB :: Type +varB = TypeVar "b" + +varC :: Type +varC = TypeVar "c" + +isBasicType :: Scheme -> Bool +isBasicType (Forall [] (Qual [] (TypeCon "Bus"))) = False +isBasicType (Forall [] (Qual [] (TypeCon _))) = True +isBasicType (Forall _ (Qual [] (TypeVar _))) = True +isBasicType _ = False + +isBus :: Scheme -> Bool +isBus (Forall [] (Qual [] (TypeCon "Bus"))) = True +isBus (Forall _ (Qual [] (TypeVar _))) = True +isBus _ = False + +infixr 1 --> + +(-->) :: Type -> Type -> Type +(-->) = TypeArr + +unqual :: Type -> Qualified Type +unqual = Qual [] diff --git a/src/Zwirn/Stream.hs b/src/Zwirn/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Zwirn/Stream.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Zwirn.Stream where + +{- + Stream.hs - query and send messages, code adapted from + https://github.com/tidalcycles/Tidal/tree/dev/src/Sound/Tidal/Stream + Copyright (C) 2023, Martin Gius + + This library 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 library 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 library. If not, see . +-} + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar, swapMVar) +import Control.Monad (when) +import Data.Bifunctor (second) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, isJust) +import Data.Text (Text, pack) +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified Network.Socket as N +import qualified Sound.Osc as O +import Sound.Osc.Time.Timeout (recvPacketTimeout) +import qualified Sound.Osc.Transport.Fd.Udp as O +import Sound.Tidal.Clock +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Link +import Zwirn.Core.Cord (stack) +import Zwirn.Core.Query +import qualified Zwirn.Core.Time as Z +import Zwirn.Language.Evaluate + +type PlayMap = Map.Map Text (Zwirn Expression) + +type BusMap = Map.Map Int (Zwirn Expression) + +data StreamConfig = StreamConfig + { streamConfigPort :: Int, + streamConfigBusPort :: Int, + streamConfigAddress :: String + } + deriving (Generic) + +data Stream = Stream + { sPlayMap :: MVar PlayMap, + sBusMap :: MVar BusMap, + sState :: MVar ExpressionMap, + sBusses :: MVar [Int], + sAddress :: RemoteAddress, + sBusAddress :: RemoteAddress, + sLocal :: O.Udp, + sClockRef :: ClockRef, + sClockConfig :: ClockConfig + } + +type RemoteAddress = N.SockAddr + +streamReplace :: Stream -> Text -> Zwirn Expression -> IO () +streamReplace str key p = modifyMVar_ (sPlayMap str) (return . Map.insert key p) + +streamReplaceBus :: Stream -> Int -> Zwirn Expression -> IO () +streamReplaceBus str key p = modifyMVar_ (sBusMap str) (return . Map.insert key p) + +streamSet :: Stream -> T.Text -> Expression -> IO () +streamSet str x ex = modifyMVar_ (sState str) (return . Map.insert x ex) + +streamSetCPS :: Stream -> Time -> IO () +streamSetCPS s = Clock.setCPS (sClockConfig s) (sClockRef s) + +streamSetBPM :: Stream -> Time -> IO () +streamSetBPM s = Clock.setBPM (sClockRef s) + +streamFirst :: Stream -> Zwirn Expression -> IO () +streamFirst str z = do + dummy <- newMVar $ Map.singleton (pack "_streamOnceDummy_") z + Clock.clockOnce (tickAction dummy (sBusMap str) (sState str) (sBusses str) (sAddress str) (sBusAddress str) (sLocal str)) (sClockConfig str) (sClockRef str) + +startStream :: StreamConfig -> MVar PlayMap -> MVar ExpressionMap -> ClockConfig -> IO Stream +startStream config zMV stMV conf = do + let target_address = streamConfigAddress config + target_port = streamConfigPort config + target_bus_port = streamConfigBusPort config + remote <- resolve target_address target_port + remoteBus <- resolve target_address target_bus_port + local <- O.udp_server 2323 + + busMapMV <- newMVar Map.empty + bussesMV <- newMVar [] + + _ <- forkIO $ handshake (N.addrAddress remote) local bussesMV + + cref <- clocked conf (tickAction zMV busMapMV stMV bussesMV (N.addrAddress remote) (N.addrAddress remoteBus) local) + return $ Stream zMV busMapMV stMV bussesMV (N.addrAddress remote) (N.addrAddress remoteBus) local cref conf + +tickAction :: MVar PlayMap -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> RemoteAddress -> RemoteAddress -> O.Udp -> (Time, Time) -> Double -> ClockConfig -> ClockRef -> (SessionState, SessionState) -> IO () +tickAction zMV busMapMV stMV bussesMV remote remoteBus local (star, end) nudge cconf cref (ss, _) = do + cps <- Clock.getCPS cconf cref + vs <- processPlayMap (star, end) cps zMV stMV + bs <- processBusMap (star, end) busMapMV stMV bussesMV + mapM_ (processAndSend remote local nudge cconf cref ss) vs + mapM_ (processAndSend remoteBus local nudge cconf cref ss) bs + +processPlayMap :: (Time, Time) -> Time -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, O.Message)] +processPlayMap (star, end) cps zMV stMV = do + pm <- readMVar zMV + let p = playMapToCord pm + st <- readMVar stMV + let qs = findAllValuesWithTimeState (Z.Time (align star) 1, Z.Time (align end) 1) st p + vs = map (\(t, v, _) -> (t, v)) qs + sts = map (\(_, _, x) -> x) qs + + -- TODO: what about race conditions? + updateState stMV sts + + return $ (\(t, ex) -> (t, expressionToMessage (fromIntegral $ floor t) (realToFrac cps) ex)) <$> vs + +processBusMap :: (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> IO [(Z.Time, O.Message)] +processBusMap (star, end) busMV stMV bussesMV = do + bm <- readMVar busMV + let bs = Map.toList bm + busses <- readMVar bussesMV + st <- readMVar stMV + return $ concatMap (\(i, p) -> second (busExpressionToMessage $ toBus busses i) <$> findAllValuesWithTime (Z.Time (align star) 1, Z.Time (align end) 1) st p) bs + +toBus :: [Int] -> Int -> Int +toBus [] i = i +toBus xs i = xs !! (i `mod` length xs) + +resolve :: String -> Int -> IO N.AddrInfo +resolve host port = do + let hints = N.defaultHints {N.addrSocketType = N.Stream} + addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + return addr + +playMapToCord :: PlayMap -> Zwirn Expression +playMapToCord = stack . Map.elems + +align :: Time -> Time +align t = fromIntegral (floor $ t / 0.001) * 0.001 + +expressionToOSC :: Expression -> [O.Datum] +expressionToOSC (ENum n) = [O.float n] +expressionToOSC (EText n) = [O.string $ T.unpack n] +expressionToOSC (EMap m) = concatMap (\(k, v) -> O.string (T.unpack k) : expressionToOSC v) $ Map.toList m +expressionToOSC _ = [] + +additionalData :: Double -> Double -> [O.Datum] +additionalData cyc cps = [O.string "cps", O.float cps, O.string "cycle", O.float cyc] + +expressionToMessage :: Double -> Double -> Expression -> O.Message +expressionToMessage cyc cps ex = O.message "/dirt/play" (additionalData cyc cps ++ expressionToOSC ex) + +busExpressionToMessage :: Int -> Expression -> O.Message +busExpressionToMessage bus ex = O.message "/c_set" (O.int32 bus : expressionToOSC ex) + +sendMessage :: RemoteAddress -> O.Udp -> Double -> Double -> (Double, O.Message) -> IO () +sendMessage remote local latency extraLatency (time, m) = sendBndl remote local $ O.Bundle timeWithLatency [m] + where + timeWithLatency = time - latency + extraLatency + +sendBndl :: RemoteAddress -> O.Udp -> O.Bundle -> IO () +sendBndl remote local bndl = O.sendTo local (O.Packet_Bundle bndl) remote + +defaultLatency :: Double +defaultLatency = 0.2 + +processAndSend :: RemoteAddress -> O.Udp -> Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, O.Message) -> IO () +processAndSend remote local nudge cconf cref ss (t, msg) = do + let onBeat = Clock.cyclesToBeat cconf (realToFrac ((\(Z.Time r _) -> fromRational r) t)) + + on <- Clock.timeAtBeat cconf ss onBeat + onOSC <- Clock.linkToOscTime cref on + + sendMessage remote local defaultLatency nudge (onOSC, msg) + +updateState :: MVar ExpressionMap -> [ExpressionMap] -> IO () +updateState _ [] = return () +updateState stmv (st : _) = modifyMVar_ stmv (const $ return st) + +handshake :: RemoteAddress -> O.Udp -> MVar [Int] -> IO () +handshake addr udp bussesMV = sendHandshake >> listen 0 + where + sendHandshake :: IO () + sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) addr + listen :: Int -> IO () + listen waits = do + ms <- recvMessagesTimeout 2 udp + if null ms + then do + checkHandshake waits -- there was a timeout, check handshake + listen (waits + 1) + else do + mapM_ respond ms + listen 0 + checkHandshake :: Int -> IO () + checkHandshake waits = do + busses <- readMVar bussesMV + when (null busses) $ do + -- when (waits == 0) $ print "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshake + respond :: O.Message -> IO () + respond (O.Message "/dirt/hello" _) = sendHandshake + respond (O.Message "/dirt/handshake/reply" xs) = do + prev <- swapMVar bussesMV $ bufferIndices xs + return () + -- Only report the first time.. + -- when (null prev) $ print "Connected to SuperDirt." + respond _ = return () + bufferIndices :: [O.Datum] -> [Int] + bufferIndices [] = [] + bufferIndices (x : xs') + | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' + +recvMessagesTimeout :: Double -> O.Udp -> IO [O.Message] +recvMessagesTimeout n sock = maybe [] O.packetMessages <$> recvPacketTimeout n sock diff --git a/zwirn.cabal b/zwirn.cabal new file mode 100644 --- /dev/null +++ b/zwirn.cabal @@ -0,0 +1,64 @@ +cabal-version: 3.0 +name: zwirn +version: 0.1.0.0 +synopsis: a live coding language for playing with nested functions of time +description: zwirn is a live coding language for playing with nested functions of time, + which trigger the sending of osc-messages. it's syntax is inspired by TidalCycles' + mini-notation and it's API for manipulating patterns. +license: GPL-3.0-only +license-file: LICENSE +author: Martin Gius +maintainer: Martin Gius +copyright: Martin Gius +category: Language, Sound +build-type: Simple +extra-doc-files: README.md +tested-with: GHC == 9.8.2 + +source-repository this + type: git + location: https://github.com/polymorphicengine/zwirn + tag: 0.1.0.0 + + +library + hs-source-dirs: src + exposed-modules: Zwirn.Language.TypeCheck.Types + Zwirn.Language.TypeCheck.Constraint + Zwirn.Language.TypeCheck.Infer + Zwirn.Language.Syntax + Zwirn.Language.Lexer + Zwirn.Language.Parser + Zwirn.Language.Compiler + Zwirn.Language.Rotate + Zwirn.Language.Simple + Zwirn.Language.Pretty + Zwirn.Language.Block + Zwirn.Language.Builtin.Internal + Zwirn.Language.Builtin.Prelude + Zwirn.Language.Builtin.Parameters + Zwirn.Language.Environment + Zwirn.Language.Evaluate + Zwirn.Language.Evaluate.Convert + Zwirn.Language.Evaluate.Expression + Zwirn.Language.Evaluate.SKI + Zwirn.Language.Evaluate.Internal + Zwirn.Language + Zwirn.Stream + build-depends: array >= 0.5.6 && < 0.6, + base >= 4.17 && < 4.20, + bytestring >= 0.12.1 && < 0.13, + pretty >= 1.1.3 && < 1.2, + containers >= 0.6.8 && < 0.7, + exceptions >= 0.10.9 && < 0.11, + mtl >= 2.3.1 && < 2.4, + filepath >= 1.5.4 && < 1.6, + hosc >= 0.21.1 && < 0.22, + text >= 2.1.1 && < 2.2, + network >= 3.2.7 && < 3.3, + zwirn-core >= 0.1.1 && < 0.2, + tidal-link >= 1.1 && < 1.2 + build-tool-depends: alex:alex, happy:happy + default-language: Haskell2010 + ghc-options: -threaded + -Wall