packages feed

zwirn (empty) → 0.1.0.0

raw patch · 25 files changed

+4462/−0 lines, 25 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, containers, exceptions, filepath, hosc, mtl, network, pretty, text, tidal-link, zwirn-core

Files

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