diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6a26401c9..283c2cacf 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -110,6 +110,7 @@ jobs: os: - ubuntu-latest - macos-latest + fail-fast: false # So the cache is still filled runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v4 @@ -133,6 +134,8 @@ jobs: run: nix flake check - name: Build all packages run: nix build --accept-flake-config + - name: Build Javascript thingy + run: nix build .#rhine-tree-js --accept-flake-config build-devshell: name: Nix Flake Develop diff --git a/automaton-lens/CHANGELOG.md b/automaton-lens/CHANGELOG.md new file mode 100644 index 000000000..ba1339671 --- /dev/null +++ b/automaton-lens/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for automaton-lens + +## 1.4 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/automaton-lens/LICENSE b/automaton-lens/LICENSE new file mode 100644 index 000000000..dba13ed2d --- /dev/null +++ b/automaton-lens/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are 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. + + 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. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + 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 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 work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero 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 Affero 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 Affero 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 Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + 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 AGPL, see +. diff --git a/automaton-lens/automaton-lens.cabal b/automaton-lens/automaton-lens.cabal new file mode 100644 index 000000000..2a733fd9e --- /dev/null +++ b/automaton-lens/automaton-lens.cabal @@ -0,0 +1,45 @@ +cabal-version: 3.0 +name: automaton-lens +version: 1.4 +-- synopsis: +-- description: +license: AGPL-3.0-or-later +license-file: LICENSE +author: Manuel Bärenz +maintainer: programming@manuelbaerenz.de +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common opts + if flag(dev) + ghc-options: -Werror + ghc-options: + -W + +library + import: opts + exposed-modules: Data.Automaton.Lens + build-depends: + base >=4.16 && <4.21, + lens, + profunctors, + automaton + + hs-source-dirs: src + default-language: GHC2021 + +test-suite automaton-lens-test + import: opts + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + automaton-lens + +flag dev + description: Enable warnings as errors. Active on ci. + default: False + manual: True diff --git a/automaton-lens/src/Data/Automaton/Lens.hs b/automaton-lens/src/Data/Automaton/Lens.hs new file mode 100644 index 000000000..7d00de552 --- /dev/null +++ b/automaton-lens/src/Data/Automaton/Lens.hs @@ -0,0 +1,33 @@ +module Data.Automaton.Lens where + +-- lens +import Control.Lens.Combinators + +-- profunctors +import Data.Profunctor.Traversing (Traversing (..)) + +-- automaton +import Data.Automaton +import Data.Stream.Result (ResultStateT) +import Control.Arrow + +{- HLINT ignore applyLensLike "Eta reduce" -} -- I think deep subsumption prevents this hint from typechecking +applyLensLike :: Functor m => (forall state m . LensLike (ResultStateT state m) s t a b) -> Automaton m a b -> Automaton m s t +applyLensLike lensLike = handleStatefully lensLike + +applyTraversal :: Monad m => Traversal s t a b -> Automaton m a b -> Automaton m s t +applyTraversal = wander + +{- HLINT ignore applyLens "Eta reduce" -} +applyLens :: Functor m => Lens s t a b -> Automaton m a b -> Automaton m s t +applyLens lens = handleStatefully lens + +applyPrism_ :: Monad m => Prism s t a b -> Automaton m a b -> Automaton m s t +applyPrism_ prism automaton = prism (automaton >>> arr Identity) >>> arr runIdentity + +applyPrism :: (Monad m, Applicative f) => Prism s t a b -> Automaton m a (f b) -> Automaton m s (f t) +applyPrism prism = prism + +{- +* Simple lenses ~ apply only one end? +-} diff --git a/automaton-lens/test/Main.hs b/automaton-lens/test/Main.hs new file mode 100644 index 000000000..3e2059e31 --- /dev/null +++ b/automaton-lens/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/automaton/automaton.cabal b/automaton/automaton.cabal index bdb4781fd..24bce7f69 100644 --- a/automaton/automaton.cabal +++ b/automaton/automaton.cabal @@ -47,12 +47,17 @@ common opts default-extensions: Arrows DataKinds + DerivingVia FlexibleContexts FlexibleInstances + GADTs ImportQualifiedPost + LambdaCase MultiParamTypeClasses NamedFieldPuns NoStarIsType + RankNTypes + StandaloneDeriving TupleSections TypeApplications TypeFamilies diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs index 2d0a5e30d..6adf6d44e 100644 --- a/automaton/src/Data/Automaton.hs +++ b/automaton/src/Data/Automaton.hs @@ -20,7 +20,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Compose (Compose (..)) import Data.Maybe (fromMaybe) -import Data.Monoid (Last (..), Sum (..)) +import Data.Monoid (Last (..), Sum (..), Ap (..)) import Prelude hiding (id, (.)) -- mmorph @@ -33,7 +33,7 @@ import Control.Monad.Trans.Reader -- profunctors import Data.Profunctor (Choice (..), Profunctor (..), Strong) import Data.Profunctor.Strong (Strong (..)) -import Data.Profunctor.Traversing +import Data.Profunctor.Traversing (Traversing (..)) -- selective import Control.Selective (Selective) @@ -281,6 +281,13 @@ instance (Monad m, Alternative m) => ArrowZero (Automaton m) where instance (Monad m, Alternative m) => ArrowPlus (Automaton m) where (<+>) = (<|>) +-- instance Semigroup w => Semigroup (Automaton m a w) where +-- instance Monoid w => Monoid (Automaton m a w) where + +deriving via Ap (Automaton m a) w instance (Applicative m, Semigroup w) => Semigroup (Automaton m a w) +deriving via Ap (Automaton m a) w instance (Applicative m, Monoid w) => Monoid (Automaton m a w) + + -- | Consume an input and produce output effectfully, without keeping internal state arrM :: (Functor m) => (a -> m b) -> Automaton m a b arrM f = Automaton $! StreamOptimized.constM $! ReaderT f @@ -400,26 +407,41 @@ instance (Monad m) => Strong (Automaton m) where -- | Step an automaton several steps at once, depending on how long the input is. instance (Monad m) => Traversing (Automaton m) where - wander f Automaton {getAutomaton = Stateful StreamT {state, step}} = - Automaton - { getAutomaton = - Stateful - StreamT - { state - , step = - step - & fmap runReaderT - & flip - & fmap ResultStateT - & f - & fmap getResultStateT - & flip - & fmap ReaderT - } - } + wander f automaton@Automaton {getAutomaton = Stateful _} = handleStatefully f automaton + -- I'm assuming that it's more efficient not to pass through an unnecessary state layer wander f (Automaton (Stateless m)) = Automaton $ Stateless $ ReaderT $ f $ runReaderT m {-# INLINE wander #-} +{- | Apply a morphism of stateful computations to an automaton. + +This keeps the state of the automaton unchanged, but modifies the step function. +-} +handleStatefully :: + (Functor m) => + -- | An automaton can be seen as a function into the state monad transformer, + -- where @s@ is the internal state. + (forall s. (a -> ResultStateT s m b) -> c -> ResultStateT s m d) -> + Automaton m a b -> + Automaton m c d +handleStatefully f Automaton {getAutomaton = Stateful StreamT {state, step}} = + Automaton + { getAutomaton = + Stateful + StreamT + { state + , step = + step + & fmap runReaderT + & flip + & fmap ResultStateT + & f + & fmap getResultStateT + & flip + & fmap ReaderT + } + } +handleStatefully f (Automaton (Stateless m)) = Automaton $ Stateless $ ReaderT $ fmap (fmap output . ($ ()) . getResultStateT) $ f $ ResultStateT . (fmap (fmap (Result ())) . const <$> runReaderT m) + -- | Only step the automaton if the input is 'Just'. mapMaybeS :: (Monad m) => Automaton m a b -> Automaton m (Maybe a) (Maybe b) mapMaybeS = traverse' diff --git a/automaton/src/Data/Stream.hs b/automaton/src/Data/Stream.hs index 822e8d8da..280b9eda8 100644 --- a/automaton/src/Data/Stream.hs +++ b/automaton/src/Data/Stream.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Data.Stream where @@ -117,6 +112,8 @@ instance (Applicative m) => Applicative (StreamT m) where {-# INLINE (<*>) #-} deriving via Ap (StreamT m) a instance (Applicative m, Num a) => Num (StreamT m a) +deriving via Ap (StreamT m) a instance (Applicative m, Semigroup a) => Semigroup (StreamT m a) +deriving via Ap (StreamT m) a instance (Applicative m, Monoid a) => Monoid (StreamT m a) instance (Applicative m, Fractional a) => Fractional (StreamT m a) where fromRational = pure . fromRational diff --git a/automaton/src/Data/Stream/Result.hs b/automaton/src/Data/Stream/Result.hs index cb9461f64..dbf52c5f4 100644 --- a/automaton/src/Data/Stream/Result.hs +++ b/automaton/src/Data/Stream/Result.hs @@ -42,3 +42,6 @@ instance (Monad m) => Applicative (ResultStateT s m) where Result s' f <- mf s Result s'' a <- ma s' pure (Result s'' (f a)) + +unzipResult :: Functor f => f (Result s a) -> Result (f s) (f a) +unzipResult fResult = Result (resultState <$> fResult) (output <$> fResult) diff --git a/flake.lock b/flake.lock index 44e5fee55..58a22a722 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,44 @@ { "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-wasm-meta": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + }, + "locked": { + "host": "gitlab.haskell.org", + "lastModified": 1732660577, + "narHash": "sha256-MAtC5kugt8M3BkY/pmINOgqFqWDU05uDWaYBTEckoK4=", + "owner": "ghc", + "repo": "ghc-wasm-meta", + "rev": "455a759195e71c572e73b56d868e544176d32897", + "type": "gitlab" + }, + "original": { + "host": "gitlab.haskell.org", + "owner": "ghc", + "repo": "ghc-wasm-meta", + "type": "gitlab" + } + }, "monad-schedule": { "inputs": { "nixpkgs": [ @@ -21,6 +60,22 @@ } }, "nixpkgs": { + "locked": { + "lastModified": 1732014248, + "narHash": "sha256-y/MEyuJ5oBWrWAic/14LaIr/u5E0wRVzyYsouYY3W6w=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "23e89b7da85c3640bbc2173fe04f4bd114342367", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { "locked": { "lastModified": 1731745710, "narHash": "sha256-SVeiClbgqL071JpAspOu0gCkPSAL51kSIRwo4C/pghA=", @@ -38,8 +93,24 @@ }, "root": { "inputs": { + "ghc-wasm-meta": "ghc-wasm-meta", "monad-schedule": "monad-schedule", - "nixpkgs": "nixpkgs" + "nixpkgs": "nixpkgs_2" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" } } }, diff --git a/flake.nix b/flake.nix index 257e97713..4c95e738c 100644 --- a/flake.nix +++ b/flake.nix @@ -17,6 +17,7 @@ url = "github:turion/monad-schedule"; inputs.nixpkgs.follows = "nixpkgs"; }; + ghc-wasm-meta.url = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org"; }; outputs = inputs: @@ -83,6 +84,9 @@ microstache = doJailbreak hprev.microstache; gloss-rendering = doJailbreak hprev.gloss-rendering; gloss = doJailbreak hprev.gloss; + + # For rhine-tree + websockets = doJailbreak hprev.websockets; }) ]; @@ -151,6 +155,7 @@ # Helper to build a flake output for all systems that are defined in nixpkgs forAllPlatforms = f: mapAttrs (system: pkgs: f system (pkgs.extend overlay)) inputs.nixpkgs.legacyPackages; + rhine-tree-js = pkgs: import ./rhine-tree/nix { inherit pkgs overlay lib; }; in { # Reexport the overlay so other downstream flakes can use it to develop rhine projects with low effort. @@ -163,6 +168,7 @@ # Usage: nix build packages = forAllPlatforms (system: pkgs: { default = pkgs.rhine-all; + rhine-tree-js = rhine-tree-js pkgs; }); # We re-export the entire nixpkgs package set with our overlay. @@ -174,7 +180,7 @@ # Usage: nix develop (will use the default GHC) # Alternatively, specify the GHC: nix develop .#ghc98 - devShells = forAllPlatforms (systems: pkgs: mapAttrs + devShells = forAllPlatforms (systems: pkgs: (mapAttrs (_: hp: hp.shellFor { packages = ps: map (pname: ps.${pname}) pnames; nativeBuildInputs = with hp; [ @@ -186,6 +192,31 @@ cabal-install ]; }) - (hpsFor pkgs)); + (hpsFor pkgs)) // + { + wasm = + let pkgs = inputs.ghc-wasm-meta.inputs.nixpkgs.legacyPackages.x86_64-linux; + in + pkgs.mkShell { + packages = [ + inputs.ghc-wasm-meta.packages.x86_64-linux.all_9_10 + # pkgs.dart-sass + ]; + }; + js = + let + pkgs = inputs.nixpkgs.legacyPackages.x86_64-linux.pkgsCross.ghcjs.extend overlay; + hp = pkgs.haskell.packages.ghc910; + in + hp.shellFor { + packages = ps: map (pname: ps.${pname}) pnames; + nativeBuildInputs = with hp; [ + cabal-gild + cabal-install + fourmolu + haskell-language-server + ]; + }; + }); }; } diff --git a/rhine-tree-example/CHANGELOG.md b/rhine-tree-example/CHANGELOG.md new file mode 100644 index 000000000..4fa27eb5f --- /dev/null +++ b/rhine-tree-example/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for rhine-tree + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/rhine-tree-example/LICENSE b/rhine-tree-example/LICENSE new file mode 100644 index 000000000..8b76fa3be --- /dev/null +++ b/rhine-tree-example/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Manuel Bärenz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/rhine-tree-example/app/Dommy.hs b/rhine-tree-example/app/Dommy.hs new file mode 100644 index 000000000..85a17e820 --- /dev/null +++ b/rhine-tree-example/app/Dommy.hs @@ -0,0 +1,38 @@ +module Dommy where + +import FRP.Rhine.Tree + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Lens ((^.)) +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Monoid ((<>)) +import Language.Javascript.JSaddle ( + askJSM, + fun, + global, + js, + js1, + jsg, + jsg3, + jss, + nextAnimationFrame, + runJSM, + syncPoint, + valToNumber, + valToJSON + ) + +import FRP.Rhine +import FRP.Rhine.Tree +import FRP.Rhine.Tree.Types (DOM(..)) +import FRP.Rhine.Tree.Types (Node(..), Content (ContentText)) + +main :: JSM () +main = do + clock <- createJSMClock + flowJSM mainClSF clock + +mainClSF :: JSMSF () () +mainClSF = appendS $ DOM [Node "p" [] [ContentText "Hi"]] diff --git a/rhine-tree-example/app/DommyGHC.hs b/rhine-tree-example/app/DommyGHC.hs new file mode 100644 index 000000000..7f9304675 --- /dev/null +++ b/rhine-tree-example/app/DommyGHC.hs @@ -0,0 +1,5 @@ +import Dommy qualified + +import Language.Javascript.JSaddle.WebKitGTK (run) + +main = run $ Dommy.main diff --git a/rhine-tree-example/rhine-tree-example.cabal b/rhine-tree-example/rhine-tree-example.cabal new file mode 100644 index 000000000..792485297 --- /dev/null +++ b/rhine-tree-example/rhine-tree-example.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.0 +name: rhine-tree-example +version: 0.1.0.0 +-- synopsis: +-- description: +license: MIT +license-file: LICENSE +author: Manuel Bärenz +maintainer: programming@manuelbaerenz.de +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + default-language: GHC2021 + default-extensions: + GADTs + TypeFamilies + Arrows + ScopedTypeVariables + OverloadedStrings + +executable dommy-ghc + import: warnings + build-depends: + base, + rhine, + rhine-tree, + jsaddle, + jsaddle-webkit2gtk, + lens + other-modules: + Dommy + ghc-options: -threaded + hs-source-dirs: app + main-is: DommyGHC.hs diff --git a/rhine-tree/CHANGELOG.md b/rhine-tree/CHANGELOG.md new file mode 100644 index 000000000..4fa27eb5f --- /dev/null +++ b/rhine-tree/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for rhine-tree + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/rhine-tree/LICENSE b/rhine-tree/LICENSE new file mode 100644 index 000000000..8b76fa3be --- /dev/null +++ b/rhine-tree/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Manuel Bärenz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/rhine-tree/app/Dommy.hs b/rhine-tree/app/Dommy.hs new file mode 100644 index 000000000..6c42645e3 --- /dev/null +++ b/rhine-tree/app/Dommy.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ApplicativeDo #-} +import Data.Functor (void) +import Data.Text (Text) +import FRP.Rhine.Tree +import FRP.Rhine.Tree.Types (Content (ContentText), DOM (..), Node (..)) +import Language.Javascript.JSaddle + ( JSM, + ) +import qualified Data.Text as T +import FRP.Rhine (count) + +default (Text) + +main :: IO () +main = mainJSM +-- main = run 8080 mainJSM -- using JSaddle Warp, needs an extra file + +mainJSM :: JSM () +mainJSM = do + clock <- createJSMClock + logJS "created" + flowJSM mainClSF clock + +mainClSF :: JSMSF DOM () () +-- mainClSF = do +-- void $ permanent'' $ Node ("p" :: Text) [] [ContentText ("I bims" :: Text)] +-- void $ permanent'' $ Node ("p" :: Text) [] [ContentText ("I bims hier" :: Text)] +-- mainClSF = (void $ permanent'' $ Node ("p" :: Text) [] [ContentText ("I bims" :: Text)]) *> +-- (void $ permanent'' $ Node ("p" :: Text) [] [ContentText ("I bims hier" :: Text)]) -- FIXME y do notaton no work? +mainClSF = void $ proc () -> do + permanent'' $ Node ("p" :: Text) [] [ContentText ("I bims" :: Text)] -< () + (_, i) <- permanent'' $ Node ("div" :: Text) [] [ContentText ("I bims hier" :: Text)] -< () + n <- count -< () + dynamic (Node "div" [] []) (varying $ Node "p" [] . pure . ContentText) -< T.pack $ show (i, n :: Integer) diff --git a/rhine-tree/nix/default.nix b/rhine-tree/nix/default.nix new file mode 100644 index 000000000..e984570f0 --- /dev/null +++ b/rhine-tree/nix/default.nix @@ -0,0 +1,20 @@ +{ pkgs, overlay, lib }: +let + dommyPkg = (pkgs.pkgsCross.ghcjs.extend overlay).haskell.packages.ghc910.rhine-tree; + dommy = lib.traceVal (dommyPkg + "/bin/dommy"); + dommyContents = lib.traceVal (builtins.readFile dommy); + botchedHTML = pkgs.writeTextFile { + name = "index.html"; + text = '' + + + + + + + ''; + }; +in +dommyPkg diff --git a/rhine-tree/rhine-tree.cabal b/rhine-tree/rhine-tree.cabal new file mode 100644 index 000000000..3fc63b50e --- /dev/null +++ b/rhine-tree/rhine-tree.cabal @@ -0,0 +1,73 @@ +cabal-version: 3.0 +name: rhine-tree +version: 0.1.0.0 +-- synopsis: +-- description: +license: MIT +license-file: LICENSE +author: Manuel Bärenz +maintainer: programming@manuelbaerenz.de +-- copyright: +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + default-language: GHC2021 + default-extensions: + GADTs + TypeFamilies + Arrows + ScopedTypeVariables + OverloadedLists + OverloadedStrings + +library + import: warnings + exposed-modules: + FRP.Rhine.Tree + FRP.Rhine.Tree.Types + -- other-modules: + -- other-extensions: + build-depends: base >=4.16 && < 4.21 + , transformers + , base-compat + , sop-core + , lens + , text + , automaton + , rhine + , these + , semialign + , jsaddle + , time + , vector-sized + , vector + , finite-typelits + hs-source-dirs: src + +executable dommy + import: warnings + build-depends: + base, + rhine, + rhine-tree, + jsaddle, + text, + lens + ghc-options: -threaded + hs-source-dirs: app + main-is: Dommy.hs + +test-suite rhine-tree-test + import: warnings + default-language: GHC2021 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base ^>=4.18.2.1, + rhine-tree diff --git a/rhine-tree/src/FRP/Rhine/Tree.hs b/rhine-tree/src/FRP/Rhine/Tree.hs new file mode 100644 index 000000000..daca3f61b --- /dev/null +++ b/rhine-tree/src/FRP/Rhine/Tree.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module FRP.Rhine.Tree where + +-- base + +import Control.Applicative (Alternative) +-- base-compat + +-- transformers + +-- text + +-- lens + +-- jsaddle + +-- rhine-tree + +import Control.Concurrent (Chan, newChan, readChan, writeChan) +import Control.Lens (ALens', Index, IndexedTraversal', IxValue, Ixed (..), Lens', Prism', Traversal', itraversed, re, to, view, (%~), (<.), (^.), (^?), (^@..)) +import Control.Monad (join, void) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.State.Strict (StateT (..)) +import Control.Monad.Trans.State.Strict qualified as StateT +import Data.Align (Semialign (..)) +import Data.Automaton.Trans.Reader (readerS, runReaderS) +import Data.Automaton.Trans.State (runStateS) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Compat (unzip) +import Data.Functor.Compose (Compose (..)) +import Data.Kind (Type) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (Alt (..)) +import Data.Proxy (Proxy (..)) +import Data.Stream (StreamT (..)) +import Data.Stream.Result (mapResultState, unzipResult) +import Data.Text hiding (index, length) +import Data.Text qualified as T hiding (length) +import Data.These (these) +import Data.Vector qualified as V +import FRP.Rhine hiding (readerS, runReaderS, step) +import FRP.Rhine.ClSF.State qualified as ClSF +import FRP.Rhine.Tree.Types +import Language.Javascript.JSaddle (MonadJSM (..), fun, js, js1, js2, jsg, jss, syncPoint, valToNumber) +import Language.Javascript.JSaddle.Types (JSM) +import Prelude hiding (unzip) + +default (Text) + +class MonadDOM td m where + waitDOMEvent :: proxy td -> m DOMEvent + currentTime :: m td + +data DOMClock td = DOMClock + +instance (MonadDOM td m, TimeDomain td, Monad m) => Clock m (DOMClock td) where + type Time (DOMClock td) = td + type Tag (DOMClock td) = DOMEvent + initClock DOMClock = do + initTime <- currentTime + return (constM currentTime &&& constM (waitDOMEvent (Proxy @td)), initTime) + +focusState :: (Functor m) => Lens' s a -> StateT a m b -> StateT s m b +focusState l = StateT . (getCompose .) . l . (Compose .) . runStateT + +prismState :: (Applicative m) => Prism' s a -> StateT a m b -> StateT s m (Maybe b) +prismState p = StateT . (\action s -> (s ^? p & traverse action) <&> second (maybe s (view (re p))) . Data.Functor.Compat.unzip) . runStateT + +traverseState :: (Applicative m, Alternative f) => Traversal' s a -> StateT a m b -> StateT s m (f b) +traverseState t = fmap getAlt . StateT . (getCompose .) . t . (Compose .) . runStateT . fmap (Alt . pure) + +-- | Morally an affine traversal +iPointing1 :: IndexedTraversal' Int Node Node +iPointing1 = children . itraversed <. _Child + +iPointingDOM1 :: IndexedTraversal' Int DOM Node +iPointingDOM1 = dom . itraversed + +class HasEvent a where + type Event a :: Type + type Event a = () + +instance HasEvent DOM where + type Event DOM = JSMEvent + +-- FIXME Maybe At is cleverer +-- FIXME use free category +data IndexList c t a b where + Here :: (c a) => t a -> IndexList c t a a + There :: (Ixed a) => Index a -> IndexList c t (IxValue a) b -> IndexList c t a b + +-- Lensing :: AtL a => Index a -> IndexList c t (IxValue a) b -> IndexList c t a b + +-- FIXME Stupid workaround because of type families. Maybe we can have an associated data family? +newtype AnEvent a = AnEvent (Event a) + +type EventList = IndexList HasEvent AnEvent + +lensAutomaton :: (Monad m) => Lens' s a -> Automaton (StateT a m) i o -> Automaton (StateT s m) i o +lensAutomaton l = hoistS $ focusState l + +-- FIXME If I had lenses into the inner structure I'd get away with output instead of Maybe output +-- FIXME can we use FilterAutomaton? At least we can use any Alternative +-- FIXME it mihgt be cleverer to put the Index in a Reader, or even supply a custom asking function +indexAutomaton1 :: (Ixed a, Monad m) => Automaton (StateT (IxValue a) m) input output -> Automaton (StateT a m) (input, Index a) (Maybe output) +indexAutomaton1 = handleAutomaton $ \StreamT {state, step} -> + StreamT + { state, + step = \s -> ReaderT $ \(input, i) -> + let transition = step s & flip runReaderT input + maybeStep = traverseState (ix i) transition + in (maybeStep <&> mapResultState (fromMaybe s) . unzipResult) + } + +-- FIXME test for nested indices +indexAutomaton :: + forall a b m output input. + (Ixed a, Monad m) => + Automaton (StateT a m) (input, AnEvent a) (Maybe output) -> + Automaton (StateT (IxValue a) m) (input, EventList (IxValue a) b) output -> + Automaton (StateT a m) (input, EventList a b) (Maybe output) +-- indexAutomaton eHere eThere = arr splitIndexList >>> eHere ||| indexAutomaton1 eThere +indexAutomaton eHere eThere = proc i -> do + case splitIndexList i of + Left ia -> eHere -< ia + Right (ie, Left i) -> indexAutomaton1 eThere -< (ie, i) + where + -- Right (ie, Right l) -> lensAutomaton eThere -< _ + + -- Need this workaround because GADTs can't be matched in Arrow notation as of 9.10 + splitIndexList :: (input, EventList a b) -> Either (input, AnEvent a) ((input, EventList (IxValue a) b), Either (Index a) (ALens' a (IxValue a))) + splitIndexList (input, Here event) = Left (input, event) + splitIndexList (input, There i eventList) = Right ((input, eventList), Left i) + +-- splitIndexList (input, Lensing i eventList) = Right ((input, eventList), Right $ atl i) + +data SomeEvent root = forall a. SomeEvent {_someEvent :: EventList root a} + +someEventHere :: SomeEvent node -> Maybe (Event node) +someEventHere (SomeEvent (Here (AnEvent e))) = Just e +someEventHere (SomeEvent (There _ _)) = Nothing + +type NodeEvent = SomeEvent Node + +type DOMEvent = SomeEvent DOM + +class Render a where + render :: a -> Text + +instance Render Attr where + render Attr {_attrName, _value} = _attrName <> "=\"" <> _value <> "\"" + +instance Render [Attr] where + render = T.unwords . fmap render + +instance Render Content where + render (ContentText text) = text + render (Child node) = render node + +instance Render [Content] where + render = T.unlines . fmap render + +instance Render (V.Vector Content) where + render = render . V.toList + +instance Render Node where + render :: Node -> Text + render Node {_name, _attrs, _children} = + T.unlines + [ T.concat + [ "<", + _name, + " ", + render _attrs, + ">" + ], + render _children, + T.concat + [ "" + ] + ] + +instance Render DOM where + render DOM {_dom} = T.unlines $ render <$> _dom + +-- T.unlines $ +-- "" +-- : (render <$> _dom) + +data Edit a = Add a | Delete | Put a + +diff0 :: (Eq a) => a -> a -> Maybe (Edit a) +diff0 a1 a2 + | a1 == a2 = Nothing + | otherwise = Just $ Put a2 + +-- FIXME Or use SemialignWithIndex +diff :: (Semialign f, Eq a) => (forall x. IndexedTraversal' i (f x) x) -> f a -> f a -> [(i, Edit a)] +diff t fa1 fa2 = align fa1 fa2 ^@.. t <. to (these (pure . const Delete) (pure . Add) diff0) <&> (\(i, me) -> (i,) <$> me) & catMaybes + +data JSMEvent + = OnClick + { clientX :: Double, + clientY :: Double + } + | DOMContentLoaded + | RhineStarted + +newtype JSMClock (node :: Type) = JSMClock {events :: Chan (SomeEvent node)} + +instance GetClockProxy (JSMClock node) + +instance (MonadJSM m) => Clock m (JSMClock node) where + type Time (JSMClock node) = () -- FIXME Use nextAnimationFrame maybe for continuous things? + type Tag (JSMClock node) = SomeEvent node + initClock JSMClock {events} = return (constM $ ((),) <$> liftIO (readChan events), ()) + +createJSMClock :: JSM (JSMClock DOM) +createJSMClock = do + events <- liftIO newChan + liftIO $ writeChan events $ SomeEvent $ Here $ AnEvent RhineStarted + doc <- jsg ("document" :: Text) + doc + ^. jss + ("onclick" :: Text) + ( fun $ \a b [e] -> do + clientX <- e ^. js ("clientX" :: Text) >>= valToNumber + clientY <- e ^. js ("clientY" :: Text) >>= valToNumber + liftIO $ print clientX + liftIO $ writeChan events $ SomeEvent $ Here $ AnEvent OnClick {clientX, clientY} + syncPoint + ) + doc + ^. jss + ("DOMContentLoaded" :: Text) + ( fun $ \_ _ _ -> do + liftIO $ putStrLn "load" + liftIO $ writeChan events $ SomeEvent $ Here $ AnEvent DOMContentLoaded + syncPoint + ) + return JSMClock {events} + +-- FIXME Next iteration: Cache DOM and only update diff +-- FIXME Also register event listeners when dom nodes are created +runStateTDOM :: StateT DOM JSM a -> JSM a +runStateTDOM action = do + logJS "starting runStateTDOM" + (a, dom_) <- runStateT action mempty + logJS "Calculated:" + logJS $ render dom_ + doc <- jsg ("document" :: Text) + doc ^. (js ("body" :: Text) . jss ("innerHTML" :: Text) (render dom_)) + doc + ^. js ("body" :: Text) + . js1 ("querySelectorAll" :: Text) ("*" :: Text) + . js1 + ("forEach" :: Text) + ( fun $ \_ _ [el] -> do + el + ^. js2 + ("addEventListener" :: Text) + ("click" :: Text) + ( fun $ \_ _ e -> do + logJS "something happened" + ) + liftIO $ putStrLn "could have" + ) + logJS "done" + syncPoint -- FIXME needed? + return a + +runStateTDOMS :: JSMSF DOM a b -> ClSF JSM (JSMClock DOM) a b +runStateTDOMS sf = feedback mempty $ proc (a, dom_) -> do + constMCl $ logJS "starting runStateTDOM" -< () + (dom', b) <- ClSF.runStateS sf -< (dom_, a) + constMCl $ logJS "Calculated:" -< () + arrMCl logJS -< render dom' + doc <- constMCl $ jsg ("document" :: Text) -< () + arrMCl (\(t, doc) -> doc ^. (js ("body" :: Text) . jss ("innerHTML" :: Text) t)) -< (render dom', doc) + constMCl syncPoint -< () + constMCl $ logJS "syncPoint reached" -< () + returnA -< (b, dom') + +-- type TreeSF m cl root node i o = Tag cl ~ SomeEvent root => ClSF (StateT node m) cl i o +type TreeSF' m cl node i o = TreeChildSF m cl node node i o +type TreeChildSF m cl node child i o = ClSF (StateT child m) (cl node) i o + +{- +pushTreeSF :: forall a m cl root i o . (Ixed a, Monad m) => TreeSF m cl root (IxValue a) i o -> TreeSF m cl root a i (Maybe o) +-- FIXME Use filter automaton at some point? +pushTreeSF sf = readerS (arr filterTi >>> mapMaybeS (indexAutomaton1 (runReaderS sf)) >>> arr join) + where + filterTi :: (TimeInfo cl, i) -> Maybe ((TimeInfo cl, i), Index a) + filterTi (ti@TimeInfo {tag = SomeEvent (There ix el)}, i) = _ +-- pushTreeSF sf = (readerS $ (mapMaybeS (arr _ >>> indexAutomaton1 (runReaderS sf))) >>> arr _) >>> arr _ +-} + +pushTreeSF :: + forall m a cl i o. + (Monad m, Ixed a, Tag (cl a) ~ SomeEvent a, Tag (cl (IxValue a)) ~ SomeEvent (IxValue a), Time (cl a) ~ Time (cl (IxValue a))) => + TreeSF' m cl (IxValue a) i o -> + TreeSF' m cl a i (Maybe o) +-- FIXME Use filter automaton at some point? +pushTreeSF sf = readerS $ arr filterTi >>> mapMaybeS (indexAutomaton1 (runReaderS sf)) >>> arr join + where + filterTi :: (TimeInfo (cl a), i) -> Maybe ((TimeInfo (cl (IxValue a)), i), Index a) + filterTi (ti@TimeInfo {tag = SomeEvent (There idx el)}, i) = Just ((retag (const (SomeEvent el)) ti, i), idx) + filterTi (TimeInfo {tag = SomeEvent (Here _)}, _) = Nothing + +pushTreeSF' :: + forall m a cl i o. + (Monad m, Ixed a, Tag (cl a) ~ SomeEvent a, Tag (cl (IxValue a)) ~ SomeEvent (IxValue a), Time (cl a) ~ Time (cl (IxValue a))) => + TreeSF' m cl (IxValue a) (Index a, i) o -> + TreeSF' m cl a i (Maybe o) +-- FIXME Use filter automaton at some point? +pushTreeSF' sf = readerS $ arr filterTi >>> mapMaybeS (indexAutomaton1 (runReaderS sf)) >>> arr join + where + filterTi :: (TimeInfo (cl a), i) -> Maybe ((TimeInfo (cl (IxValue a)), (Index a, i)), Index a) + filterTi (ti@TimeInfo {tag = SomeEvent (There idx el)}, i) = Just ((retag (const (SomeEvent el)) ti, (idx, i)), idx) + filterTi (TimeInfo {tag = SomeEvent (Here _)}, _) = Nothing + +-- -- FIXME I want this in pushTreeSF somehow +-- onlyAt :: (Monad m, Tag (cl (IxValue node)) ~ SomeEvent (IxValue node)) => proxy node -> TreeSF' m cl (IxValue node) (Index node, a) (Maybe a) +-- onlyAt _ = proc (index, a) -> do +-- tag <- tagS -< () +-- returnA -< case tag of +-- SomeEvent (Here (AnEvent e)) -> _ +-- _ -> Nothing + +-- FIXME generalise +-- type JSMSF node a b = ClSF (StateT node JSM) JSMClock a b +type JSMSF node a b = TreeSF' JSM JSMClock node a b + +flowJSM :: JSMSF DOM () () -> JSMClock DOM -> JSM () +flowJSM sf cl = flow $ runStateTDOMS sf @@ cl + +stateS :: (Monad m) => (a -> s -> (b, s)) -> ClSF (StateT s m) cl a b +stateS f = arrMCl $ StateT.state . f + +appendS :: (Monoid s, Monad m) => s -> ClSF (StateT s m) cl a () +appendS s = constMCl $ StateT.modify (<> s) + +{- +jsmSF :: + forall a output input. + ( Ixed a, + HasEvent a, + Event a ~ JSMEvent -- FIXME get rid of that constraint + ) => + JSMSF a input (Maybe output) -> + JSMSF (IxValue a) input output -> + JSMSF a input (Maybe output) + -- FIXME More general routing by getting the evnt structure from the tick +jsmSF here there = + readerS $ + arr (\(ti, input) -> ((ti, input), Here $ AnEvent $ tag ti)) + >>> indexAutomaton + (arr (\((ti, input), _) -> (ti, input)) >>> runReaderS here) + (arr (\((ti, input), _) -> (ti, input)) >>> runReaderS there) +-} + +-- FIXME Naming +-- FIXME does this exist already +class (Ixed a) => AtL a where + atl :: Index a -> Lens' a (IxValue a) + +class (Ixed a) => AppendChild a where + -- | Law: + -- let (a', i) = appendChild v a in a' ^@? ix i == Just v + appendChild :: IxValue a -> a -> (Index a, a) + +instance AppendChild DOM where + -- FIXME This is super inefficient, should use a vector or a Seq + appendChild node dom_ = (dom_ ^. dom . to length, dom_ & dom %~ (++ [node])) + +instance AppendChild Node where + -- FIXME This is super inefficient, should use a vector or a Seq + appendChild child parent = (parent ^. children . to length, parent & children %~ (`V.snoc` Child child)) + +class Register m a where + register :: IndexList c t root a -> a -> m () + +permanent :: (AppendChild node) => IxValue node -> JSMSF node a () +-- permanent v = jsmSF (arr (const Nothing)) (constMCl (StateT.put v)) >>> arr (const ()) +permanent v = constMCl $ void (StateT.state (appendChild v)) + +permanent' :: (Monad m) => node -> TreeSF' m cl node a () +permanent' = constMCl . StateT.put + +varying :: (Monad m) => (a -> node) -> TreeSF' m cl node a () +varying f = arrMCl $ StateT.put . f + +eventHere :: (Tag (cl node) ~ SomeEvent node, Monad m) => TreeSF' m cl node a (Maybe (Event node)) +eventHere = tagS >>> arr someEventHere + +permanent'' :: (AppendChild node) => IxValue node -> JSMSF node a (Maybe (Event (IxValue node)), Index node) +permanent'' v = feedback Nothing $ proc (_, iMaybe) -> do + i' <- case iMaybe of + Nothing -> do + i <- constMCl $ StateT.state $ appendChild v -< () + returnA -< i + Just i -> do + returnA -< i + mEvent <- pushTreeSF eventHere -< () + returnA -< ((join mEvent, i'), Just i') + +dynamic :: (AppendChild node, Eq (Index node)) => IxValue node -> JSMSF (IxValue node) a b -> JSMSF node a (Maybe b) +dynamic v sf = proc a -> do + (_, i) <- permanent'' v -< () + constMCl (lift $ logJS "dyńamic") -< () + dynamicAt sf -< (i, a) -- FIXME But this doesn't start because there is no event going to it. + -- It's time to do dom diffing and attaching events + +dynamicAt :: (AppendChild node, Eq (Index node)) => JSMSF (IxValue node) a b -> JSMSF node (Index node, a) (Maybe b) +dynamicAt sf = arr join <<< pushTreeSF' sf' + where + sf' = proc (i1, (i2, a')) -> do + if i1 == i2 + then do + constMCl (lift $ logJS "equal") -< () + arr Just <<< sf -< a' + else do + constMCl (lift $ logJS "different") -< () + returnA -< Nothing + +-- modal :: TreeSF' m cl (IxValue node) (i, a) o -> TreeSF' m cl node (i, Maybe a) o +-- modal sf = _ + +logJS :: Text -> JSM () +logJS msg = do + c <- jsg ("console" :: Text) + void $ c ^. js1 ("log" :: Text) msg diff --git a/rhine-tree/src/FRP/Rhine/Tree/Types.hs b/rhine-tree/src/FRP/Rhine/Tree/Types.hs new file mode 100644 index 000000000..17e8c64a0 --- /dev/null +++ b/rhine-tree/src/FRP/Rhine/Tree/Types.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} +-- text +-- lens +{-# OPTIONS_GHC -Wno-orphans #-} + +module FRP.Rhine.Tree.Types where + +import Control.Lens (At, Index, IxValue, Ixed (..), Prism', lens, makeLenses, makePrisms, prism) +import Control.Lens.At (At (..)) +import Data.Finite (Finite) +import Data.SOP (I, NP) +import Data.Text +import Data.Vector qualified as V +import Data.Vector.Sized (Vector) +import Data.Vector.Sized qualified as S +import GHC.TypeLits (KnownNat) + +data Fix f = Fix {_fix :: f (Fix f)} + +makeLenses ''Fix + +newtype DOM = DOM {_dom :: [Node]} + +instance Semigroup DOM where + DOM dom1 <> DOM dom2 = DOM $ dom1 <> dom2 + +instance Monoid DOM where + mempty = DOM mempty + +data Node = Node + { _name :: Text, + _attrs :: [Attr], + _children :: V.Vector Content + } + +someVector :: (KnownNat n) => Prism' (V.Vector Content) (S.Vector n Content) +someVector = prism S.fromSized $ \v -> maybe (Left v) Right $ S.toSized v + +type instance Index (S.Vector n a) = Finite n + +type instance IxValue (S.Vector n (Maybe a)) = a + +instance Ixed (S.Vector n (Maybe a)) + +-- Deep subsumption +{- HLINT at ignore "Eta reduce" -} +instance At (S.Vector n (Maybe a)) where + at i = S.ix i + +data Content = ContentText Text | Child Node + +data Attr = Attr + { _attrName :: Text, + _value :: Text + } + +makeLenses ''Attr +makeLenses ''Node +makeLenses ''DOM +makePrisms ''Content + +type instance Index Node = Int + +type instance IxValue Node = Node + +instance Ixed Node where + ix i = children . ix i . _Child + +type instance Index DOM = Int + +type instance IxValue DOM = Node + +instance Ixed DOM where + ix i = dom . ix i diff --git a/rhine-tree/static/index.html b/rhine-tree/static/index.html new file mode 100644 index 000000000..0e1e320bd --- /dev/null +++ b/rhine-tree/static/index.html @@ -0,0 +1,7 @@ + + + + + + diff --git a/rhine-tree/test/Main.hs b/rhine-tree/test/Main.hs new file mode 100644 index 000000000..3e2059e31 --- /dev/null +++ b/rhine-tree/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index 5aace1e6b..555a9ddeb 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -101,6 +101,7 @@ library FRP.Rhine.ClSF.Except FRP.Rhine.ClSF.Random FRP.Rhine.ClSF.Reader + FRP.Rhine.ClSF.State FRP.Rhine.ClSF.Upsample FRP.Rhine.ClSF.Util FRP.Rhine.Clock diff --git a/rhine/src/FRP/Rhine/ClSF/State.hs b/rhine/src/FRP/Rhine/ClSF/State.hs new file mode 100644 index 000000000..9083a7b00 --- /dev/null +++ b/rhine/src/FRP/Rhine/ClSF/State.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Create and remove 'StateT' layers in 'ClSF's. +-} +module FRP.Rhine.ClSF.State where + +-- base +import Data.Tuple (swap) + +-- transformers +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +-- automaton +import Data.Automaton.Trans.State qualified as Automaton + +-- rhine +import FRP.Rhine.ClSF.Core + +commuteState :: ReaderT r (StateT s m) a -> StateT s (ReaderT r m) a +commuteState a = + StateT $ \s -> ReaderT $ \r -> runStateT (runReaderT a r) s +{-# INLINE commuteState #-} + +commuteStateBack :: StateT s (ReaderT r m) a -> ReaderT r (StateT s m) a +commuteStateBack a = + ReaderT $ \r -> StateT $ \s -> runReaderT (runStateT a s) r +{-# INLINE commuteStateBack #-} + +stateS :: + (Monad m) => + ClSF m cl (s, a) (s, b) -> + ClSF (StateT s m) cl a b +stateS behaviour = hoistS commuteStateBack $ Automaton.stateS behaviour +{-# INLINE stateS #-} + +runStateS :: + (Monad m) => + ClSF (StateT s m) cl a b -> + ClSF m cl (s, a) (s, b) +runStateS behaviour = Automaton.runStateS (hoistS commuteState behaviour) +{-# INLINE runStateS #-} + +runStateS_ :: + (Monad m) => + ClSF (StateT s m) cl a b -> + s -> + ClSF m cl a (s, b) +runStateS_ behaviour s = Automaton.runStateS_ (hoistS commuteState behaviour) s +{-# INLINE runStateS_ #-}