diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,1 @@ +include ../cho-cabal-make.inc diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,32 @@ +_Reactive_ [1] is a simple foundation for programming reactive systems +functionally. Like Fran/FRP, it has a notions of (reactive) behaviors and +events. Like DataDriven [2], Reactive has a data-driven implementation. + +The inspiration for Reactive was Mike Sperber's Lula [3] implementation of +FRP. Mike used blocking threads, which I had never considered for FRP. +While playing with the idea, I realized that I could give a very elegant +and efficient solution to caching, which DataDriven doesn't do. (For an +application "f <*> a" of a varying function to a varying argument, caching +remembers the latest function to apply to a new argument and the last +argument to which to apply a new function.) + +The theory and implementation of Reactive are described in the paper +"Push-pull functional reactive programming" [4]. + +Note that cabal[5], version 1.4.0.1 or greater is required for installation. + +You can configure, build, and install all in the usual way with Cabal +commands. + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + + +References: + +[1] http://haskell.org/haskellwiki/Reactive +[2] http://haskell.org/haskellwiki/DataDriven +[3] http://www-pu.informatik.uni-tuebingen.de/lula/deutsch/publications.html +[4] http://conal.net/papers/push-pull-frp/ +[5] http://www.haskell.org/cabal/download.html diff --git a/announce b/announce new file mode 100644 --- /dev/null +++ b/announce @@ -0,0 +1,9 @@ +Reactive [1] is a library for functional reactive programming (FRP), similar to the original Fran [2] but with a more modern interface (using standard type classes) and a hybrid push/pull implementation. It is designed to be used in a variety of contexts, such as interactive 2D and 3D graphics, graphical user interfaces, web services, and automatic recompilation/re-execution. It has a simple and precise semantics based on continuous time and is built on a notion of functional future values. The semantics and implementation are described in the paper "Simply efficient functional reactivity" [3]. + +Reactive now has a mailing list [4] and a feature/bug tracker [5]. + +[1] http://haskell.org/haskellwiki/Reactive +[2] http://conal.net/Fran +[3] http://conal.net/papers/simply-reactive +[4] http://www.haskell.org/mailman/listinfo/reactive +[5] http://trac.haskell.org/reactive diff --git a/changes.tw b/changes.tw new file mode 100644 --- /dev/null +++ b/changes.tw @@ -0,0 +1,29 @@ +== Version 0 == + +=== Version 0.8 === + +=== Version 0.8.1 === + +* Adding QuickCheck tests. + +''Fill in missing versions'' + + +=== Version 0.3 === + +* Commented out LANGUAGE pragmas and added OPTIONS_GHC -fglasgow-exts for ghc-6.6 compatibility. + +=== Version 0.2 === + +* Fixed switcher. Didn't terminate. Thanks to Ivan Tomac for the bug report. + +=== Version 0.1 === + +* Added Never constructor for Future. Allows optimizations, including a huge improvement for (>>=) on Event (which had been piling up nevers). +* removed -threaded comment +* added traceR (reactive value tracing) +* use idler in src/Examples.hs (for single-threaded use of wxHaskell) + +=== Version 0.0 === + +* New project. diff --git a/reactive.cabal b/reactive.cabal --- a/reactive.cabal +++ b/reactive.cabal @@ -1,42 +1,88 @@ Name: reactive -Version: 0.5.0.1 -Synopsis: Simple foundation for functional reactive programming +Version: 0.11.5 +Synopsis: Push-pull functional reactive programming Category: reactivity, FRP Description: /Reactive/ is a simple foundation for programming reactive systems functionally. Like Fran\/FRP, it has a notions of (reactive) behaviors and - events. Like DataDriven, Reactive has a data-driven implementation. - The main difference between Reactive and DataDriven is that Reactive - builds on functional \"futures\" (using threading), while DataDriven - builds on continuation-based computations. + events. Unlike most previous FRP implementations, Reactive has a hybrid + demand/data-driven implementation, as described in the paper \"Push-pull + functional reactive programming\", . . + This version of Reactive has some serious bugs that show up particularly + with some uses of the Event monad. Some problems have been due to bugs + in the GHC run-time support for concurrency. I do not know whether the + remaining problems in Reactive are still more subtle RTS issues, or + some subtle laziness bugs in Reactive. Help probing the remaining + difficulties is most welcome. + . + Import "FRP.Reactive" for FRP client apps. To make a Reactive adapter for an + imperative library, import "FRP.Reactive.LegacyAdapters". + . Please see the project wiki page: . - The module documentation pages have links to colorized source code and - to wiki pages where you can read and contribute user comments. Enjoy! + © 2007-2009 by Conal Elliott; GNU AGPLv3 license (see COPYING). + I am not thrilled with GPL, and I doubt I'll stay with it for long. + If you would like different terms, please talk to me. . - © 2007 by Conal Elliott; BSD3 license. -Author: Conal Elliott + With contributions from: Robin Green, Thomas Davie, Luke Palmer, + David Sankel, Jules Bean, Creighton Hogg, Chuan-kai Lin, and Richard + Smith. Please let me know if I've forgotten to list you. + +Author: Conal Elliott Maintainer: conal@conal.net Homepage: http://haskell.org/haskellwiki/reactive -Package-Url: http://darcs.haskell.org/packages/reactive -Copyright: (c) 2007-2008 by Conal Elliott -License: BSD3 +Package-Url: http://code.haskell.org/reactive +Bug-Reports: http://trac.haskell.org/reactive + +Copyright: (c) 2007-2009 by Conal Elliott +Cabal-Version: >= 1.2 +License: OtherLicense +License-File: COPYING Stability: provisional -build-type: Simple -Hs-Source-Dirs: src -Extensions: -Build-Depends: base >= 3.0.3.2 && < 5, TypeCompose>=0.6.7 -Exposed-Modules: - Data.SFuture - Data.Future - Data.Fun - Data.Reactive +Build-Type: Simple Extra-Source-Files: -ghc-options: -Wall +Library + Build-Depends: base >=4 && <5, old-time, random, QuickCheck >= 2.1.0.2, + TypeCompose>=0.8.0, vector-space>=0.5, + unamb>=0.1.5, checkers >= 0.2.3, + category-extras >= 0.53.5, Stream >= 0.3.1 + -- This library uses the ImpredicativeTypes flag, and it depends + -- on vector-space, which needs ghc >= 6.9 + if impl(ghc < 6.9) { + buildable: False + } + Hs-Source-Dirs: src + Exposed-Modules: + FRP.Reactive --- Experimental modules: --- Data.SEvent --- Data.MEvent --- Data.EventExtras --- Data.SReactive + FRP.Reactive.Future + FRP.Reactive.PrimReactive + FRP.Reactive.Reactive + FRP.Reactive.Behavior + FRP.Reactive.Fun + FRP.Reactive.Improving + FRP.Reactive.Num + FRP.Reactive.VectorSpace + + FRP.Reactive.Internal.Misc + FRP.Reactive.Internal.Fun + FRP.Reactive.Internal.Future + FRP.Reactive.Internal.Reactive + FRP.Reactive.Internal.Behavior + FRP.Reactive.Internal.Clock + FRP.Reactive.Internal.Timing + FRP.Reactive.Internal.Chan + + FRP.Reactive.LegacyAdapters + + Data.AddBounds + Data.Min + Data.Max + Data.PairMonad + -- Probably eliminate the next few + FRP.Reactive.Internal.IVar + FRP.Reactive.Internal.Serial + FRP.Reactive.Internal.TVal + + ghc-options: -Wall diff --git a/src/Data/AddBounds.hs b/src/Data/AddBounds.hs new file mode 100644 --- /dev/null +++ b/src/Data/AddBounds.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.AddBounds +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Add bounds to an ordered type +---------------------------------------------------------------------- + +module Data.AddBounds (AddBounds(..)) where + +import Control.Applicative (pure,(<$>)) + +import Data.Unamb (unamb) + +import Data.AffineSpace + +-- Testing +import Test.QuickCheck +import Test.QuickCheck.Checkers + + +-- | Wrap a type into one having new least and greatest elements, +-- preserving the existing ordering. +data AddBounds a = MinBound | NoBound a | MaxBound + deriving (Eq {-, Ord-}, Read, Show) + +instance Bounded (AddBounds a) where + minBound = MinBound + maxBound = MaxBound + + +-- Normally, I'd derive 'Ord' as well, but there's a sticky point. The +-- derived instance uses the default definition of 'min', which is uses +-- '(<=)' and thus cannot exploit any partial information. So, define our +-- own 'min' in terms of 'min' on @a@. +-- Examples: +-- (NoBound undefined) `min` (NoBound undefined) can return (NoBound _|_) +-- using this definition, but will not produce any output using the +-- default min. +-- +-- (NoBound a) `min` (NoBound b) can return partial information from +-- a `min` b while the default implementation cannot. + +-- instance Ord a => Ord (AddBounds a) where +-- MinBound <= _ = True +-- NoBound _ <= MinBound = False +-- NoBound a <= NoBound b = a <= b +-- NoBound _ <= MaxBound = True +-- MaxBound <= MaxBound = True +-- MaxBound <= _ = False -- given previous + +-- MinBound `min` _ = MinBound +-- _ `min` MinBound = MinBound +-- NoBound a `min` NoBound b = NoBound (a `min` b) +-- u `min` MaxBound = u +-- MaxBound `min` v = v + +-- MinBound `max` v = v +-- u `max` MinBound = u +-- NoBound a `max` NoBound b = NoBound (a `max` b) +-- _ `max` MaxBound = MaxBound +-- MaxBound `max` _ = MaxBound + + +-- The definition above is too strict for some uses. Here's a parallel +-- version. + + +-- Alternatively, make a non-parallel definition here and use 'pmin' +-- instead of 'min' where I want. + + +-- General recipe for Ord methods: use unamb to try two strategies. The +-- first one, "justB", only examines b. The second one first examines +-- only examines a and then examines both. I take care that the two +-- strategies handle disjoint inputs. I could instead let the second +-- strategy handle the first one redundantly, being careful that they +-- agree. + +-- This instance is very like the one Richard Smith (lilac) constructed. +-- It fixes a couple of small bugs and follows a style that helps me see +-- that I'm covering all of the cases with the evaluation order I want. + +instance Ord a => Ord (AddBounds a) where + a <= b = justB b `unamb` (a <=* b) + where + justB MaxBound = True + justB _ = undefined + + MinBound <=* _ = True + _ <=* MinBound = False + NoBound u <=* NoBound v = u <= v + MaxBound <=* NoBound _ = False + _ <=* MaxBound = undefined + + a `min` b = justB b `unamb` (a `min'` b) + where + justB MinBound = MinBound + justB MaxBound = a + justB (NoBound _) = undefined + + MinBound `min'` _ = MinBound + MaxBound `min'` v = v + NoBound u `min'` NoBound v = NoBound (u `min` v) + _ `min'` MinBound = undefined + _ `min'` MaxBound = undefined + + a `max` b = justB b `unamb` (a `max'` b) + where + justB MaxBound = MaxBound + justB MinBound = a + justB (NoBound _) = undefined + + MaxBound `max'` _ = MaxBound + MinBound `max'` v = v + NoBound u `max'` NoBound v = NoBound (u `max` v) + _ `max'` MaxBound = undefined + _ `max'` MinBound = undefined + + +-- instance Arbitrary a => Arbitrary (AddBounds a) where +-- arbitrary = frequency [ (1 ,pure MinBound) +-- , (10, NoBound <$> arbitrary) +-- , (1 ,pure MaxBound) ] +-- coarbitrary MinBound = variant 0 +-- coarbitrary (NoBound a) = variant 1 . coarbitrary a +-- coarbitrary MaxBound = variant 2 + +instance Arbitrary a => Arbitrary (AddBounds a) where + arbitrary = frequency [ (1 ,pure MinBound) + , (10, NoBound <$> arbitrary) + , (1 ,pure MaxBound) ] + +instance CoArbitrary a => CoArbitrary (AddBounds a) where + coarbitrary MinBound = variant (0::Int) + coarbitrary (NoBound a) = variant (1::Int) . coarbitrary a + coarbitrary MaxBound = variant (2::Int) + +instance (EqProp a, Eq a) => EqProp (AddBounds a) where + NoBound a =-= NoBound b = a =-= b + u =-= v = u `eq` v + + +-- Hm. I'm dissatisfied with this next instance. I'd like to tweak my +-- type definitions to eliminate these partial definitions. + +instance AffineSpace t => AffineSpace (AddBounds t) where + type Diff (AddBounds t) = Diff t + NoBound u .-. NoBound v = u .-. v + -- I don't know what to do here + _ .-. _ = error "(.-.) on AddBounds: only defined on NoBound args" + NoBound u .+^ v = NoBound (u .+^ v) + _ .+^ _ = error "(.+^) on AddBounds: only defined on NoBound args" diff --git a/src/Data/Fun.hs b/src/Data/Fun.hs deleted file mode 100644 --- a/src/Data/Fun.hs +++ /dev/null @@ -1,62 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Data.Fun --- Copyright : (c) Conal Elliott 2007 --- License : BSD3 --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Functions, with constant functions optimized. With instances of --- 'Functor', 'Applicative', 'Monad', and 'Arrow' ----------------------------------------------------------------------- - -module Data.Fun (Fun(..), apply) where - -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative(..)) -import qualified Control.Category (Category, (.), id) -import Control.Arrow (Arrow, arr, first, second, (***), (>>>)) - --- | Constant-optimized functions -data Fun t a = K a -- ^ constant function - | Fun (t -> a) -- ^ non-constant function - --- | 'Fun' as a function -apply :: Fun t a -> (t -> a) -apply (K a) = const a -apply (Fun f) = f - -instance Monoid a => Monoid (Fun t a) where - mempty = K mempty - K a `mappend` K a' = K (a `mappend` a') - funa `mappend` funb = Fun (apply funa `mappend` apply funb) - -instance Functor (Fun t) where - fmap f (K a) = K (f a) - fmap f (Fun g) = Fun (f.g) - -- Or use - -- fmap f = (pure f <*>) - -instance Applicative (Fun t) where - pure = K - K f <*> K x = K (f x) - cf <*> cx = Fun (apply cf <*> apply cx) - -instance Monad (Fun t) where - return = pure - K a >>= h = h a - Fun f >>= h = Fun (f >>= apply . h) - -instance Control.Category.Category Fun where - id = arr id - K b . _ = K b - Fun g . K a = K (g a) - Fun f . Fun g = Fun (f . g) - -instance Arrow Fun where - arr = Fun - first = Fun . first . apply - second = Fun . second . apply - K a' *** K b' = K (a',b') - f *** g = first f >>> second g diff --git a/src/Data/Future.hs b/src/Data/Future.hs deleted file mode 100644 --- a/src/Data/Future.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} --- For ghc-6.6 compatibility --- {-# OPTIONS_GHC -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Data.Future --- Copyright : (c) Conal Elliott 2007 --- License : BSD3 --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- A /future value/ is a value that will become knowable only later. This --- module gives a way to manipulate them functionally. For instance, --- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable. --- See . --- --- Primitive futures can be things like /the value of the next key you --- press/, or /the value of LambdaPix stock at noon next Monday/. --- --- Composition is via standard type classes: 'Functor', 'Applicative', --- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of --- these classes: --- --- * Monoid: 'mempty' is a future that never becomes knowable. --- @a `mappend` b@ is whichever of @a@ and @b@ is knowable first. --- --- * 'Functor': apply a function to a future. The result is knowable when --- the given future is knowable. --- --- * 'Applicative': 'pure' gives value knowable since the beginning of --- time. '(\<*\>)' applies a future function to a future argument. --- Result available when /both/ are available, i.e., it becomes knowable --- when the later of the two futures becomes knowable. --- --- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@ cascades --- futures. 'join' resolves a future future into a future. --- --- The current implementation is nondeterministic in 'mappend' for futures --- that become knowable at the same time or nearly the same time. I --- want to make a deterministic implementation. --- --- See "Data.SFuture" for a simple denotational semantics of futures. The --- current implementation /does not/ quite implement this target semantics --- for 'mappend' when futures are available simultaneously or nearly --- simultaneously. I'm still noodling how to implement that semantics. ----------------------------------------------------------------------- - -module Data.Future - ( Future(..), force, newFuture - , future - , runFuture - ) where - -import Control.Concurrent -import Data.Monoid (Monoid(..)) -import Control.Applicative -import Control.Monad (join,forever) -import System.IO.Unsafe --- import Foreign (unsafePerformIO) - --- TypeCompose -import Control.Instances () -- IO monoid - --- About determinacy: for @f1 `mappend` f2@, we might get @f2@ instead of --- @f1@ even if they're available simultaneously. It's even possible to --- get the later of the two if they're nearly simultaneous. --- --- What will it take to get deterministic semantics for @f1 `mappend` f2@? --- Idea: make an "event occurrence" type, which is a future with a time --- and a value. (The time is useful for snapshotting continuous --- behaviors.) When one occurrence happens with a time @t@, query whether --- the other one occurs by the same time. What does it take to support --- this query operation? --- --- Another idea: speculative execution. When one event occurs, continue --- to compute consequences. If it turns out that an earlier occurrence --- arrives later, do some kind of 'retry'. - --- The implementation is very like IVars. Each future contains an MVar --- reader. 'force' blocks until the MVar is written. - --- | Value available in the future. -data Future a = - -- | Future that may arrive. The 'IO' blocks until available. No side-effect. - Future (IO a) - -- | Future that never arrives. - | Never - --- Why not simply use @a@ (plain-old lazy value) in place of @IO a@ in --- 'Future'? Several of the definitions below get simpler, and many --- examples work. See NewFuture.hs. But sometimes that implementation --- mysteriously crashes or just doesn't update. Odd. - --- | Access a future value. Blocks until available. -force :: Future a -> IO a -force (Future io) = io -force Never = hang - --- | Block forever -hang :: IO a -hang = do -- putStrLn "warning: blocking forever." - -- Any never-terminating computation goes here - -- This one can yield an exception "thread blocked indefinitely" - -- newEmptyMVar >>= takeMVar - -- sjanssen suggests this alternative: - forever $ threadDelay maxBound - -- forever's return type is (), though it could be fully - -- polymorphic. Until it's fixed, I need the following line. - return undefined - --- | Make a 'Future' and a way to fill it. The filler should be invoked --- only once. -newFuture :: IO (Future a, a -> IO ()) -newFuture = do v <- newEmptyMVar - return (Future (readMVar v), putMVar v) - --- | Make a 'Future', given a way to compute a value. -future :: IO a -> Future a -future mka = unsafePerformIO $ - do (fut,sink) <- newFuture - forkIO $ mka >>= sink - return fut -{-# NOINLINE future #-} - -instance Functor Future where - fmap f (Future get) = future (fmap f get) - fmap _ Never = Never - -instance Applicative Future where - pure a = Future (pure a) - Future getf <*> Future getx = future (getf <*> getx) - _ <*> _ = Never - --- Note Applicative's pure uses 'Future' as an optimization over --- 'future'. No thread or MVar. - -instance Monad Future where - return = pure - Future geta >>= h = future (geta >>= force . h) - Never >>= _ = Never - -instance Monoid (Future a) where - mempty = Never - mappend = race - --- | Race to extract a value. -race :: Future a -> Future a -> Future a -Never `race` b = b -a `race` Never = a -a `race` b = unsafePerformIO $ - do (c,sink) <- newFuture - lock <- newEmptyMVar -- to avoid double-kill - let run fut tid = forkIO $ do x <- force fut - putMVar lock () - killThread tid - sink x - mdo ta <- run a tb - tb <- run b ta - return () - return c -{-# NOINLINE race #-} - --- TODO: make race deterministic, using explicit times. Figure out how --- one thread can inquire whether the other whether it is available by a --- given time, and if so, what time. - --- | Run an 'IO'-action-valued 'Future'. -runFuture :: Future (IO ()) -> IO () -runFuture = join . force diff --git a/src/Data/Max.hs b/src/Data/Max.hs new file mode 100644 --- /dev/null +++ b/src/Data/Max.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.Max +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Max monoid +---------------------------------------------------------------------- + +module Data.Max (Max(..)) where + + +import Data.Monoid (Monoid(..)) + +import Test.QuickCheck (Arbitrary, CoArbitrary) +import Test.QuickCheck.Checkers (EqProp) + + +-- | Ordered monoid under 'max'. +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Bounded, Read, Show, EqProp, Arbitrary, CoArbitrary) + +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = Max minBound + Max a `mappend` Max b = Max (a `max` b) diff --git a/src/Data/Min.hs b/src/Data/Min.hs new file mode 100644 --- /dev/null +++ b/src/Data/Min.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.Min +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Min monoid +---------------------------------------------------------------------- + +module Data.Min (Min(..)) where + +import Data.Monoid (Monoid(..)) + +import Test.QuickCheck (Arbitrary) +import Test.QuickCheck.Checkers (EqProp) + +-- | Ordered monoid under 'min'. +newtype Min a = Min { getMin :: a } + deriving (Eq, Ord, Read, Show, Bounded, EqProp, Arbitrary) + +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = Min maxBound + Min a `mappend` Min b = Min (a `min` b) diff --git a/src/Data/PairMonad.hs b/src/Data/PairMonad.hs new file mode 100644 --- /dev/null +++ b/src/Data/PairMonad.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.PairMonad +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Writer monad as a pair. Until it's in Control.Monad.Instances. +-- +-- Use @import Data.PairMonad ()@ +---------------------------------------------------------------------- + +module Data.PairMonad () where + +import Data.Monoid +import Control.Applicative + + +-- Orphan instance: + +-- Equivalent to the Monad Writer instance. +instance Monoid o => Monad ((,) o) where + return = pure + (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a + +-- Alternatively, +-- m >>= f = join (fmap f m) +-- where +-- join ((o, (o',a))) = (o `mappend` o', a) +-- Or even, +-- (o,a) >>= f = (o,id) <*> f a +-- +-- I prefer the join version, because it's the standard (>>=)-via-join, +-- plus a very simple definition for join. Too bad join isn't a method of +-- Monad, with (>>=) and join defined in terms of each other. Why isn't +-- it? Probably because Monad isn't derived from Functor. Was that an +-- oversight? diff --git a/src/Data/Reactive.hs b/src/Data/Reactive.hs deleted file mode 100644 --- a/src/Data/Reactive.hs +++ /dev/null @@ -1,498 +0,0 @@ --- {-# LANGUAGE TypeOperators, ScopedTypeVariables, PatternSignatures --- , FlexibleInstances --- #-} - --- For ghc-6.6 compatibility -{-# OPTIONS_GHC -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Data.Reactive --- Copyright : (c) Conal Elliott 2007 --- License : BSD3 --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- Functional /events/ and /reactive values/. An 'Event' is stream of --- future values in time order. A 'Reactive' value is a discretly --- time-varying value. These two types are closely linked: a reactive --- value is defined by an initial value and an event that yields future --- values; while an event is simply a future reactive value. --- --- Many of the operations on events and reactive values are packaged as --- instances of the standard type classes 'Monoid', 'Functor', --- 'Applicative', and 'Monad'. --- --- Although the basic 'Reactive' type describes /discretely/-changing --- values, /continuously/-changing values are modeled simply as reactive --- functions. For convenience, this module defines 'ReactiveB' as a type --- composition of 'Reactive' and a constant-optimized representation of --- functions of time. --- --- The exact packaging of discrete vs continuous will probably change with --- more experience. ----------------------------------------------------------------------- - -module Data.Reactive - ( -- * Events and reactive values - Event(..), Reactive(..), Source, inEvent, inEvent2 - , stepper, switcher, mkEvent, mkEventTrace, mkEventShow - , runE, forkE, subscribe, forkR - -- * Event extras - , accumE, scanlE, monoidE - , withPrevE, countE, countE_, diffE - , snapshot, snapshot_, whenE, once, traceE, eventX - -- * Reactive extras - , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR - -- * Reactive behaviors - , Time, ReactiveB - -- * To be moved elsewhere - , replace, forget - , Action, Sink - , joinMaybes, filterMP - ) where - -import Data.Monoid -import Control.Arrow (first,second) -import Control.Applicative -import Control.Monad -import Debug.Trace (trace) -import Data.IORef -import Control.Concurrent -- (forkIO,ThreadId) - -import Data.Maybe - --- TypeCompose -import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..)) -import Data.Pair - -import Data.Future -import Data.Fun - - -{-------------------------------------------------------------------- - Events and reactive values ---------------------------------------------------------------------} - --- | Event, i.e., a stream of future values. Instances: --- --- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend` --- e'@ is the event that combines occurrences from @e@ and @e'@. (Fran's --- @neverE@ and @(.|.)@.) --- --- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs, --- and whose occurrence values come from applying @f@ to the values from --- @e@. (Fran's @(==>)@.) --- --- * 'Applicative': @pure a@ is an event with a single occurrence, --- available from the beginning of time. @ef \<*\> ex@ is an event whose --- occurrences are made from the /product/ of the occurrences of @ef@ and --- @ex@. For every occurrence @f@ at time @tf@ of @ef@ and occurrence @x@ --- at time @tx@ of @ex@, @ef \<*\> ex@ has an occurrence @f x@ at time @max --- tf tx@. --- --- * 'Monad': @return a@ is the same as @pure a@ (as always). In @e >>= --- f@, each occurrence of @e@ leads, through @f@, to a new event. --- Similarly for @join ee@, which is somehow simpler for me to think --- about. The occurrences of @e >>= f@ (or @join ee@) correspond to the --- union of the occurrences of all such events. For example, suppose --- we're playing Asteroids and tracking collisions. Each collision can --- break an asteroid into more of them, each of which has to be tracked --- for more collisions. Another example: A chat room has an /enter/ --- event, whose occurrences contain new events like /speak/. An --- especially useful monad-based function is 'joinMaybes', which filters a --- Maybe-valued event. --- -newtype Event a = Event { eFuture :: Future (Reactive a) } - --- | Reactive value: a discretely changing value. Reactive values can be --- understood in terms of (a) a simple denotational semantics of reactive --- values as functions of time, and (b) the corresponding instances for --- functions. The semantics is given by the function @(%$) :: Reactive a --- -> (Time -> a)@. A reactive value also has a current value and an --- event (stream of future values). --- --- Instances for 'Reactive' --- --- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then --- @Reactive o@ is a monoid, with @mempty = pure mempty@, and @mappend = --- liftA2 mappend@. In other words, @mempty %$ t == mempty@, and @(r --- `mappend` s) %$ t == (r %$ t) `mappend` (s %$ t).@ --- --- * 'Functor': @fmap f r %$ t == f (r %$ t)@. --- --- * 'Applicative': @pure a %$ t == a@, and @(s \<*\> r) %$ t == --- (s %$ t) (r %$ t)@. --- --- * 'Monad': @return a %$ t == a@, and @join rr %$ t == (rr %$ t) --- %$ t@. As always, @(r >>= f) == join (fmap f r)@. --- -data Reactive a = - Stepper { - rInit :: a -- ^ initial value - , rEvent :: Event a -- ^ waiting for event - } - --- data Reactive a = a `Stepper` Event a - --- | Reactive value from an initial value and a new-value event. -stepper :: a -> Event a -> Reactive a -stepper = Stepper - --- | Compatibility synonym (for ease of transition from DataDriven) -type Source = Reactive - --- | Apply a unary function inside an 'Event' representation. -inEvent :: (Future (Reactive a) -> Future (Reactive b)) -> (Event a -> Event b) -inEvent f = Event . f . eFuture - --- | Apply a unary function inside an 'Event' representation. -inEvent2 :: (Future (Reactive a) -> Future (Reactive b) -> Future (Reactive c)) - -> (Event a -> Event b -> Event c) -inEvent2 f = inEvent . f . eFuture - --- Why the newtype for Event? Because the 'Monoid' instance of 'Future' --- does not do what I want for 'Event'. It will pick just the --- earlier-occurring event, while I want an interleaving of occurrences --- from each. - -instance Monoid (Event a) where - mempty = Event mempty - mappend = inEvent2 merge - --- Standard instance for Applicative of Monoid -instance Monoid a => Monoid (Reactive a) where - mempty = pure mempty - mappend = liftA2 mappend - --- | Merge two 'Future' streams into one. -merge :: Future (Reactive a) -> Future (Reactive a) -> Future (Reactive a) -Never `merge` fut = fut -fut `merge` Never = fut -u `merge` v = - (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v) - where - onFut f (a `Stepper` Event t') = a `stepper` Event (f t') - -instance Functor Event where - fmap f = inEvent $ (fmap.fmap) f - --- I could probably define an Applicative instance like []'s for Event, --- i.e., apply all functions to all arguments. I don't think I want that --- semantics. - -instance Functor Reactive where - fmap f (a `Stepper` e) = f a `stepper` fmap f e - -instance Applicative Event where { pure = return; (<*>) = ap } - -instance Applicative Reactive where - pure a = a `stepper` mempty - rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) = - f x `stepper` Event fut - where - fut = fmap (\ rf' -> rf' <*> rx ) futf `mappend` - fmap (\ rx' -> rf <*> rx') futx - --- More succinctly, --- --- rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) = --- f x `stepper` Event (((<*> rx) <$> futf) `mappend` ((rf <*>) <$> futx)) - - --- A wonderful thing about the <*> definition for Reactive is that it --- automatically caches the previous value of the function or argument --- when the argument or function changes. - --- TODO: The definitions of merge and <*> have some similarities. Can I --- factor out a common pattern? - -instance Monad Event where - return a = Event (pure (pure a)) - e >>= f = joinE (fmap f e) - -joinE :: forall a. Event (Event a) -> Event a -joinE = inEvent q - where - q :: Future (Reactive (Event a)) -> Future (Reactive a) - q = (>>= eFuture . h) - h :: Reactive (Event a) -> Event a - h (ea `Stepper` eea) = ea `mappend` joinE eea - -instance MonadPlus Event where { mzero = mempty; mplus = mappend } - -instance Monad Reactive where - return = pure - r >>= h = joinR (fmap h r) - --- | Switch between reactive values. -switcher :: Reactive a -> Event (Reactive a) -> Reactive a -r `switcher` e = joinR (r `stepper` e) - --- Reactive 'join' -joinR :: Reactive (Reactive a) -> Reactive a -joinR ((a `Stepper` Event fut) `Stepper` e'@(Event fut')) = - a `stepper` Event fut'' - where - -- If fut arrives first, switch and continue waiting for e'. - -- If fut' arrives first, abandon fut and keep switching with new - -- reactive values from fut'. - fut'' = fmap (`switcher` e') fut `mappend` fmap join fut' - --- | Make an event and a sink for feeding the event. Each value sent to --- the sink becomes an occurrence of the event. -mkEvent :: IO (Event a, Sink a) -mkEvent = do (fut,snk) <- newFuture - -- remember how to save the next occurrence. - r <- newIORef snk - return (Event fut, writeTo r) - where - -- Fill in an occurrence while preparing for the next one - writeTo r a = do snk <- readIORef r - (fut',snk') <- newFuture - writeIORef r snk' - snk (a `stepper` Event fut') - --- | Tracing variant of 'mkEvent' -mkEventTrace :: (a -> String) -> IO (Event a, Sink a) -mkEventTrace shw = second tr <$> mkEvent - where - tr snk = (putStrLn.shw) `mappend` snk - --- | Show specialization of 'mkEventTrace' -mkEventShow :: Show a => String -> IO (Event a, Sink a) -mkEventShow str = mkEventTrace ((str ++).(' ':).show) - --- | Run an event in a new thread. -forkE :: Event (IO b) -> IO ThreadId -forkE = forkIO . runE - --- | Subscribe a listener to an event. Wrapper around 'forkE' and 'fmap'. -subscribe :: Event a -> Sink a -> IO ThreadId -subscribe e snk = forkE (snk <$> e) - --- | Run an event in the current thread. -runE :: Event (IO b) -> IO a -runE (Event fut) = do act `Stepper` e' <- force fut - act - runE e' - --- | Run a reactive value in a new thread. The initial action happens in --- the current thread. -forkR :: Reactive (IO b) -> IO ThreadId -forkR (act `Stepper` e) = act >> forkE e - - -{-------------------------------------------------------------------- - Event extras ---------------------------------------------------------------------} - --- | Accumulating event, starting from an initial value and a --- update-function event. See also 'accumR'. -accumE :: a -> Event (a -> a) -> Event a -accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e' - --- | Like 'scanl' for events. See also 'scanlR'. -scanlE :: (a -> b -> a) -> a -> Event b -> Event a -scanlE f a e = a `accumE` (flip f <$> e) - --- | Accumulate values from a monoid-valued event. Specialization of --- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidR'. -monoidE :: Monoid o => Event o -> Event o -monoidE = scanlE mappend mempty - --- | Pair each event value with the previous one, given an initial value. -withPrevE :: Event a -> Event (a,a) -withPrevE e = (joinMaybes . fmap combineMaybes) $ - (Nothing,Nothing) `accumE` fmap (shift.Just) e - where - -- Shift newer value into (old,new) pair if present. - shift :: u -> Unop (u,u) - shift new (_,old) = (old,new) - combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v) - combineMaybes = uncurry (liftA2 (,)) - --- | Count occurrences of an event, remembering the occurrence values. --- See also 'countE_'. -countE :: Num n => Event b -> Event (b,n) -countE = scanlE h (b0,0) - where - b0 = error "withCountE: no initial value" - h (_,n) b = (b,n+1) - --- | Count occurrences of an event, forgetting the occurrence values. See --- also 'countE'. See also 'countR'. -countE_ :: Num n => Event b -> Event n -countE_ e = snd <$> countE e - --- | Difference of successive event occurrences. -diffE :: Num n => Event n -> Event n -diffE e = uncurry (-) <$> withPrevE e - --- | Snapshot a reactive value whenever an event occurs. -snapshot :: Event a -> Reactive b -> Event (a,b) -e `snapshot` r = joinMaybes $ e `snap` r - --- This variant of 'snapshot' yields 'Just's when @e@ happens and --- 'Nothing's when @r@ changes. -snap :: forall a b. Event a -> Reactive b -> Event (Maybe (a,b)) -e@(Event ve) `snap` r@(b `Stepper` Event vr) = - Event ((g <$> ve) `mappend` (h <$> vr)) - where - -- When e occurs, produce a pair, and start snapshotting the old - -- reactive value with the new event. - g :: Reactive a -> Reactive (Maybe (a,b)) - g (a `Stepper` e') = Just (a,b) `stepper` (e' `snap` r) - -- When r changes, produce no pair, and start snapshotting the new - -- reactive value with the old event. - h :: Reactive b -> Reactive (Maybe (a,b)) - h r' = Nothing `stepper` (e `snap` r') - --- Introducing Nothing above allows the mappend to commit to the RHS. - --- | Like 'snapshot' but discarding event data (often @a@ is @()@). -snapshot_ :: Event a -> Reactive b -> Event b -e `snapshot_` src = snd <$> (e `snapshot` src) - --- | Filter an event according to whether a boolean source is true. -whenE :: Event a -> Reactive Bool -> Event a -whenE e = joinMaybes . fmap h . snapshot e - where - h (a,True) = Just a - h (_,False) = Nothing - --- | Just the first occurrence of an event. -once :: Event a -> Event a -once = inEvent $ fmap $ pure . rInit - --- | Tracing of events. -traceE :: (a -> String) -> Unop (Event a) -traceE shw = fmap (\ a -> trace (shw a) a) - - --- | Make an extensible event. The returned sink is a way to add new --- events to mix. You can often use '(>>=)' or 'join' instead. Warning: --- this function might be removed at some point. -eventX :: IO (Event a, Sink (Event a)) -eventX = first join <$> mkEvent - - -{-------------------------------------------------------------------- - Reactive extras ---------------------------------------------------------------------} - -mkReactive :: a -> IO (Reactive a, Sink a) -mkReactive a0 = first (a0 `stepper`) <$> mkEvent - --- | Reactive value from an initial value and an updater event. See also --- 'accumE'. -accumR :: a -> Event (a -> a) -> Reactive a -a `accumR` e = a `stepper` (a `accumE` e) - --- | Like 'scanl' for reactive values. See also 'scanlE'. -scanlR :: (a -> b -> a) -> a -> Event b -> Reactive a -scanlR f a e = a `stepper` scanlE f a e - --- | Accumulate values from a monoid-valued event. Specialization of --- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'. -monoidR :: Monoid a => Event a -> Reactive a -monoidR = scanlR mappend mempty - --- | Start out blank ('Nothing'), latching onto each new @a@, and blanking --- on each @b@. If you just want to latch and not blank, then use --- 'mempty' for @lose@. -maybeR :: Event a -> Event b -> Reactive (Maybe a) -maybeR get lose = - Nothing `stepper` (fmap Just get `mappend` replace Nothing lose) - --- | Flip-flopping source. Turns true when @ea@ occurs and false when --- @eb@ occurs. -flipFlop :: Event a -> Event b -> Reactive Bool -flipFlop ea eb = - False `stepper` (replace True ea `mappend` replace False eb) - --- TODO: generalize 'maybeR' & 'flipFlop'. Perhaps using 'Monoid'. --- Note that Nothing and (Any False) are mempty. - --- | Count occurrences of an event. See also 'countE'. -countR :: Num n => Event a -> Reactive n -countR e = 0 `stepper` countE_ e - --- | Tracing of reactive values -traceR :: (a -> String) -> Unop (Reactive a) -traceR shw (a `Stepper` e) = a `Stepper` traceE shw e - - -{-------------------------------------------------------------------- - Other instances ---------------------------------------------------------------------} - --- Standard instances -instance Pair Reactive where pair = liftA2 (,) -instance (Monoid_f f) => Monoid_f (Reactive :. f) where - { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) } -instance Pair f => Pair (Reactive :. f) where pair = apPair - -instance Unpair Reactive where {fsts = fmap fst; snds = fmap snd} - --- Standard instances -instance Monoid_f Event where - { mempty_f = mempty ; mappend_f = mappend } -instance Monoid ((Event :. f) a) where - { mempty = O mempty; mappend = inO2 mappend } -instance Monoid_f (Event :. f) where - { mempty_f = mempty ; mappend_f = mappend } -instance Copair f => Pair (Event :. f) where - pair = copair - --- Standard instance for functors -instance Unpair Event where {fsts = fmap fst; snds = fmap snd} - - - -{-------------------------------------------------------------------- - Reactive behaviors over continuous time ---------------------------------------------------------------------} - --- | Time for continuous behaviors -type Time = Double - --- | Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in --- a type composition to get 'Functor' and 'Applicative' for free. -type ReactiveB = Reactive :. Fun Time - - -{-------------------------------------------------------------------- - To be moved elsewhere ---------------------------------------------------------------------} - --- | Replace a functor value with a given one. -replace :: Functor f => b -> f a -> f b -replace b = fmap (const b) - --- | Forget a functor value, replace with @()@ -forget :: Functor f => f a -> f () -forget = replace () - --- | Convenient alias for dropping parentheses. -type Action = IO () - --- | Value sink -type Sink a = a -> Action - --- | Pass through @Just@ occurrences. -joinMaybes :: MonadPlus m => m (Maybe a) -> m a -joinMaybes = (>>= maybe mzero return) - --- | Pass through values satisfying @p@. -filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a -filterMP p m = joinMaybes (liftM f m) - where - f a | p a = Just a - | otherwise = Nothing - --- Alternatively: --- filterMP p m = m >>= guarded p --- where --- guarded p x = guard (p x) >> return x diff --git a/src/Data/SFuture.hs b/src/Data/SFuture.hs deleted file mode 100644 --- a/src/Data/SFuture.hs +++ /dev/null @@ -1,195 +0,0 @@ --- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall -fno-warn-orphans #-} --- For ghc-6.6 compatibility -{-# OPTIONS_GHC -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Data.SFuture --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- --- A sort of semantic prototype for functional /futures/, roughly as --- described at . --- --- A /future/ is a value that will become knowable only later. This --- module gives a way to manipulate them functionally. For instance, --- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable. --- --- Primitive futures can be things like /the value of the next key you --- press/, or /the value of LambdaPix stock at noon next Monday/. --- --- Composition is via standard type classes: 'Ord', 'Functor', --- 'Applicative', 'Monad', and 'Monoid'. Some comments on the 'Future' --- instances of these classes: --- --- * 'Ord': @a `min` b@ is whichever of @a@ and @b@ is knowable first. @a --- `max` b@ is whichever of @a@ and @b@ is knowable last. --- --- * Monoid: 'mempty' is a future that never becomes knowable. 'mappend' --- is the same as 'min'. --- --- * 'Functor': apply a function to a future. The result is knowable when --- the given future is knowable. --- --- * 'Applicative': 'pure' gives value knowable since the beginning of --- time. '(\<*\>)' applies a future function to a future argument. --- Result available when /both/ are available, i.e., it becomes knowable --- when the later of the two futures becomes knowable. --- --- * 'Monad': 'return' is the same as 'pure' (as always). @(>>=)@ --- cascades futures. 'join' resolves a future future value into a --- future value. --- --- Futures are parametric over /time/ as well as /value/ types. The time --- parameter can be any ordered type. --- --- Please keep in mind that this module specifies the interface and --- semantics, rather than a useful implementation. See "Data.Future" for --- an implementation that nearly implements the semantics described here. --- --- On second thought, I'm experimenting with using this module in an --- usable implementation of events. See Data.MEvent. ----------------------------------------------------------------------- - -module Data.SFuture - ( - -- * Time & futures - Time, Future(..), futTime, futVal, sequenceF - -- * To go elsewhere - , Max(..), Min(..), AddBounds(..) - ) where - -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative(..)) -import Data.Function (on) - - -{---------------------------------------------------------- - Time and futures -----------------------------------------------------------} - --- | Time of some event occurrence, which can be any @Ord@ type. In an --- actual implementation, we would not usually have access to the time --- value until (slightly after) that time. Extracting the actual time --- would block until the time is known. The added bounds represent --- -Infinity and +Infinity. Pure values have time minBound (-Infinity), --- while eternally unknowable values (non-occurring events) have time --- maxBound (+Infinity). -type Time t = Max (AddBounds t) - --- | A future value of type @a@ with time type @t@. Semantically, just a --- time\/value pair, but those values would not be available until --- 'force'd, which could block. -newtype Future t a = Future { unFuture :: (Time t, a) } - deriving (Functor, Applicative, Monad, Show) - --- The 'Applicative' instance relies on the 'Monoid' instance of 'Max'. - --- | A future's time -futTime :: Future t a -> Time t -futTime = fst . unFuture - --- | A future's value -futVal :: Future t a -> a -futVal = snd . unFuture - - --- -- The Monoid instance picks the earlier future --- instance Ord t => Monoid (Future t a) where --- mempty = Future (maxBound, error "it'll never happen, buddy") --- fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) = --- if t <= t' then fut else fut' - --- or: - - -instance Eq (Future t a) where - (==) = error "sorry, no (==) for futures" - -instance Ord t => Ord (Future t a) where - (<=) = (<=) `on` futTime - -- We could leave 'min' to the default in terms of '(<=)', but the - -- following can yield partial time info, as much as allowed by the time - -- parameter type @t@ and its 'min'. - Future (s,a) `min` Future (t,b) = - Future (s `min` t, if s <= t then a else b) - --- For some choices of @t@, there may be an efficient combination of 'min' --- and '(<=)'. In particular, 'Improving' has 'minI'. - -instance Ord t => Monoid (Future t a) where - mempty = Future (maxBound, error "it'll never happen, buddy") - mappend = min - --- 'sequenceF' is like 'sequenceA' from "Data.Traversable". However, --- the @Traversable@ class assumes @Foldable@, which I'm not confident --- how to implement usefully. (I could of course just strip off the --- 'Future' constructor and the time. Why is Foldable required? - --- | Make a future container into a container of futures. -sequenceF :: Functor f => Future t (f a) -> f (Future t a) -sequenceF (Future (tt, f)) = fmap (Future . ((,) tt)) f - - - -{---------------------------------------------------------- - To go elsewhere -----------------------------------------------------------} - --- For Data.Monoid: - --- | Ordered monoid under 'max'. -newtype Max a = Max { getMax :: a } - deriving (Eq, Ord, Read, Show, Bounded) - -instance (Ord a, Bounded a) => Monoid (Max a) where - mempty = Max minBound - Max a `mappend` Max b = Max (a `max` b) - --- | Ordered monoid under 'min'. -newtype Min a = Min { getMin :: a } - deriving (Eq, Ord, Read, Show, Bounded) - -instance (Ord a, Bounded a) => Monoid (Min a) where - mempty = Min maxBound - Min a `mappend` Min b = Min (a `min` b) - --- I have a niggling uncertainty about the 'Ord' & 'Bounded' instances for --- @Min a@? Is there a reason flip the @a@ ordering instead of preserving --- it? - --- For Control.Monad.Instances - --- Equivalent to the Monad Writer instance. --- import Data.Monoid -instance Monoid o => Monad ((,) o) where - return = pure - (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a - --- Alternatively, --- m >>= f = join (fmap f m) --- where --- join ((o, (o',a))) = (o `mappend` o', a) --- Or even, --- (o,a) >>= f = (o,id) <*> f a --- --- I prefer the join version, because it's the standard (>>=)-via-join, --- plus a very simple definition for join. Too bad join isn't a method of --- Monad, with (>>=) and join defined in terms of each other. Why isn't --- it? Probably because Monad isn't derived from Functor. Was that an --- oversight? - --- Where to put this definition? Prelude? - --- | Wrap a type into one having new least and greatest elements, --- preserving the existing ordering. -data AddBounds a = MinBound | NoBound a | MaxBound - deriving (Eq, Ord, Read, Show) - -instance Bounded (AddBounds a) where - minBound = MinBound - maxBound = MaxBound diff --git a/src/Examples.hs b/src/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Examples.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TypeOperators, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} + +---------------------------------------------------------------------- +-- | +-- Module : Examples +-- Copyright : (c) Conal Elliott 2007 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Simple test for Reactive +---------------------------------------------------------------------- + +-- module Main where + +-- base +import Data.Monoid +import Data.IORef +import Control.Monad +import Control.Applicative +import Control.Arrow (first,second) +import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId) + +-- wxHaskell +import Graphics.UI.WX hiding (Event,Reactive) +import qualified Graphics.UI.WX as WX +-- TypeCompose +import Control.Compose ((:.)(..), inO,inO2) +import Data.Title + +-- Reactive +import Reactive.Reactive + + +{-------------------------------------------------------------------- + Mini-Phooey +--------------------------------------------------------------------} + +type Win = Panel () + +type Wio = ((->) Win) :. IO :. (,) Layout + +type Wio' a = Win -> IO (Layout,a) + + +wio :: Wio' a -> Wio a +wio = O . O + +unWio :: Wio a -> Wio' a +unWio = unO . unO + +inWio :: (Wio' a -> Wio' b) -> (Wio a -> Wio b) +inWio f = wio . f . unWio + +inWio2 :: (Wio' a -> Wio' b -> Wio' c) -> (Wio a -> Wio b -> Wio c) +inWio2 f = inWio . f . unWio + +instance Title_f Wio where + title_f str = inWio ((fmap.fmap.first) (boxed str)) + +-- Bake in vertical layout. See phooey for flexible layout. +instance Monoid Layout where + mempty = WX.empty + mappend = above + +instance Monoid a => Monoid (Wio a) where + mempty = wio mempty + mappend = inWio2 mappend + +type WioE a = Wio (Event a) +type WioR a = Wio (Reactive a) + +buttonE :: String -> WioE () +buttonE str = wio $ \ win -> + do (e, snk) <- mkEvent + b <- button win [ text := str, on command := snk () ] + return (hwidget b, e) + +buttonE' :: String -> a -> WioE a +buttonE' str a = (a `replace`) <$> buttonE str + +sliderE :: (Int,Int) -> Int -> WioE Int +sliderE (lo,hi) initial = wio $ \ win -> + do (e, snk) <- mkEvent + s <- hslider win True lo hi + [ selection := initial ] + set s [ on command := getAttr selection s >>= snk ] + return (hwidget s, e) + +sliderR :: (Int,Int) -> Int -> WioR Int +sliderR lh initial = stepper initial <$> sliderE lh initial + +stringO :: Wio (Sink String) +stringO = attrO (flip textEntry []) text + +-- Make an output. The returned sink collects updates. On idle, the +-- latest update gets stored in the given attribute. +attrO :: Widget w => (Win -> IO w) -> Attr w a -> Wio (Sink a) +attrO mk attr = wio $ \ win -> + do ctl <- mk win + ref <- newIORef Nothing + setAttr (on idle) win $ + do readIORef ref >>= maybe mempty (setAttr attr ctl) + writeIORef ref Nothing + return True + return (hwidget ctl , writeIORef ref . Just) + +-- -- The following alternative ought to be more efficient. Oddly, the timer +-- -- doesn't get restarted, although enabled gets set to True. + +-- stringO = wio $ \ win -> +-- do ctl <- textEntry win [] +-- ref <- newIORef (error "stringO: no initial value") +-- tim <- timer win [ interval := 10, enabled := False ] +-- let enable b = do putStrLn $ "enable: " ++ show b +-- setAttr enabled tim b +-- set tim [ on command := do putStrLn "timer" +-- readIORef ref >>= setAttr text ctl +-- enable False +-- ] +-- return ( hwidget ctl +-- , \ str -> writeIORef ref str >> enable True ) + +showO :: Show a => Wio (Sink a) +showO = (. show) <$> stringO + +showR :: Show a => WioR (Sink a) +showR = pure <$> showO + + +-- | Horizontally-filled widget layout +hwidget :: Widget w => w -> Layout +hwidget = hfill . widget + +-- | Binary layout combinator +above, leftOf :: Layout -> Layout -> Layout +la `above` lb = fill (column 0 [la,lb]) +la `leftOf` lb = fill (row 0 [la,lb]) + +-- | Get attribute. Just a flipped 'get'. Handy for partial application. +getAttr :: Attr w a -> w -> IO a +getAttr = flip get + +-- | Set a single attribute. Handy for partial application. +setAttr :: Attr w a -> w -> Sink a +setAttr attr ctl x = set ctl [ attr := x ] + + +{-------------------------------------------------------------------- + Running +--------------------------------------------------------------------} + +-- | Fork a 'Wio': handle frame & widget creation, and apply layout. +forkWio :: (o -> IO ThreadId) -> String -> Wio o -> IO () +forkWio forker name w = start $ + do f <- frame [ visible := False, text := name ] + pan <- panel f [] + (l,o) <- unWio w pan + set pan [ layout := l ] + forker o + -- Yield regularly, to allow other threads to continue. Unnecessary + -- when apps are compiled with -threaded. + -- timer pan [interval := 10, on command := yield] + set f [ layout := fill (widget pan) + , visible := True + ] + +-- | Fork a 'WioE' +forkWioE :: String -> WioE Action -> IO () +forkWioE = forkWio forkE + +-- | Fork a 'WioR' +forkWioR :: String -> WioR Action -> IO () +forkWioR = forkWio forkR + + +{-------------------------------------------------------------------- + Examples +--------------------------------------------------------------------} + +alarm :: Double -> Int -> IO (Event Int) +alarm secs reps = + do (e,snk) <- mkEvent + forkIO $ forM_ [1 .. reps] $ \ i -> + do threadDelay micros + snk i + return e + where + micros = round (1.0e6 * secs) + + +t0 = alarm 0.5 10 >>= \ e -> runE $ print <$> {-traceE (const "boo!")-} e + +mkAB :: WioE String +mkAB = buttonE' "a" "a" `mappend` buttonE' "b" "b" + + +t1 = forkWioE "t1" $ liftA2 (<$>) stringO mkAB + +acc :: WioE String +acc = g <$> mkAB + where + g :: Event String -> Event String + g e = "" `accumE` (flip (++) <$> e) + +t2 = forkWioE "t2" $ liftA2 (<$>) stringO acc + +total :: Show a => WioR (Sink a) +total = title "total" showR + +sl :: Int -> WioR Int +sl = sliderR (0,100) + +apples, bananas, fruit :: WioR Int +apples = title "apples" $ sl 3 +bananas = title "bananas" $ sl 7 +fruit = title "fruit" $ (liftA2.liftA2) (+) apples bananas + +t3 = forkWioR "t3" $ liftA2 (<**>) fruit total + +t4 = forkWioR "t4" $ liftA2 (<*>) showR (sl 0) + +t5 = forkWioR "t5" $ liftA2 (<$>) showO (sl 0) + +-- This example shows what happens with expensive computations. There's a +-- lag between slider movement and shown result. Can even get more than +-- one computation behind. +t6 = forkWioR "t6" $ liftA2 (<$>) showO (fmap (ack 2) <$> sliderR (0,1000) 0) + +ack 0 n = n+1 +ack m 0 = ack (m-1) 1 +ack m n = ack (m-1) (ack m (n-1)) + +-- Test switchers. Ivan Tomac's example. +sw1 = do (e, snk) <- mkEvent + forkR $ print <$> pure "init" `switcher` ((\_ -> pure "next") <$> e) + snk () + snk () + +-- TODO: replace sw1 with a declarative GUI example, say switching between +-- two different previous GUI examples. + +main = t6 + + +updPair :: Either c d -> (c,d) -> (c,d) +updPair = (first.const) `either` (second.const) + +-- updPair (Left c') (_,d) = (c',d) +-- updPair (Right d') (c,_) = (c,d') + +-- mixEither :: (Event c, Event d) -> Event (Either c d) +-- mixEither :: (Functor f, Monoid (f (Either a b))) => +-- (f a, f b) -> f (Either a b) +mixEither :: MonadPlus m => (m a, m b) -> m (Either a b) +mixEither (ec,ed) = liftM Left ec `mplus` liftM Right ed + +-- unmixEither :: Event (Either c d) -> (Event c, Event d) +unmixEither :: MonadPlus m => m (Either c d) -> (m c, m d) +unmixEither ecd = (filt left, filt right) + where + filt f = joinMaybes (liftM f ecd) + +left :: Either c d -> Maybe c +left (Left c) = Just c +left _ = Nothing + +right :: Either c d -> Maybe d +right (Right d) = Just d +right _ = Nothing + + +-- pairEditE :: (Event c, Event d) -> Event ((c,d) -> (c,d)) + +-- pairEditE :: (Functor f, Monoid (f ((d, a) -> (d, a)))) => +-- (f d, f a) -> f ((d, a) -> (d, a)) +-- pairEditE (ce,de) = +-- ((first.const) <$> ce) `mappend` ((second.const) <$> de) + +-- pairEditE :: (Functor m, MonadPlus m) => (m d, m a) -> m ((d, a) -> (d, a)) +-- pairEditE (ce,de) = +-- ((first.const) <$> ce) `mplus` ((second.const) <$> de) + +pairEditE :: MonadPlus m => (m c,m d) -> m ((c,d) -> (c,d)) +pairEditE = liftM updPair . mixEither + +-- pairEditE cde = liftM updPair (mixEither cde) + +-- or, skipping sums + +-- pairEditE (ce,de) = +-- liftM (first.const) ce `mplus` liftM (second.const) de + +pairE :: (c,d) -> (Event c, Event d) -> Event (c,d) +pairE cd cde = cd `accumE` pairEditE cde + +pairR :: Reactive c -> Reactive d -> Reactive (c,d) + +-- (c `Stepper` ce) `pairR` (d `Stepper` de) = +-- (c,d) `stepper` pairE (c,d) (ce,de) + +-- More directly: + +(c `Stepper` ce) `pairR` (d `Stepper` de) = + (c,d) `accumR` pairEditE (ce,de) + +-- pairR' :: Reactive c -> Reactive d -> Reactive (c,d) +-- (c `Stepper` ce) `pairR'` (d `Stepper` de) = +-- (c,d) `accumR` pairEditE (ce,de) + diff --git a/src/FRP/Reactive.hs b/src/FRP/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- A library for programming with functional reactive behaviors. +---------------------------------------------------------------------- + +module FRP.Reactive + ( + -- * Events + TimeT, ITime + , EventG, Event + , accumE + , withTimeE, withTimeE_ + , zipE, scanlE, monoidE + , mealy, mealy_, countE, countE_, diffE + , withPrevE, withPrevEWith + , eitherE + , justE, filterE + -- ** More esoteric + , listE, atTimes, atTime, once + , firstRestE, firstE, restE, snapRemainderE + , withRestE, untilE + , splitE, switchE + -- ** Useful with events. + , joinMaybes, filterMP + -- * Behaviors + , BehaviorG, Behavior, Behaviour + , time + , stepper, switcher --, select + , snapshotWith, snapshot, snapshot_, whenE + , accumB + , scanlB, monoidB, maybeB, flipFlop, countB + , sumB, integral + ) where + +-- Reactive.Reactive exports reactive values as well. Filter them out. + +import FRP.Reactive.Reactive hiding + (stepper,switcher,snapshotWith,snapshot,snapshot_,whenE,flipFlop,integral) +import FRP.Reactive.Behavior +import FRP.Reactive.VectorSpace () +import FRP.Reactive.Num () diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Behavior.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, TypeOperators + , StandaloneDeriving, GeneralizedNewtypeDeriving + , TypeSynonymInstances, UndecidableInstances + #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Behavior +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Reactive behaviors (continuous time) +---------------------------------------------------------------------- + +module FRP.Reactive.Behavior + ( + BehaviorG, Behavior, Behaviour + , time + , stepper, switcher --, select + , snapshotWith, snapshot, snapshot_, whenE + , accumB, scanlB, monoidB, maybeB, flipFlop, countB + , sumB, integral + ) where + +import Data.Monoid (Monoid(..)) +import Control.Applicative (Applicative,(<$>),pure) +-- import Control.Monad (join) + +import Control.Comonad + +import Control.Compose ((:.)(..),unO) + +import Data.VectorSpace +import Data.AffineSpace + +import qualified FRP.Reactive.Reactive as R +import FRP.Reactive.Reactive + ( ImpBounds, TimeT, EventG, ReactiveG + , withTimeE,onceRestE,diffE,joinMaybes,result) +import FRP.Reactive.Fun +-- import FRP.Reactive.Improving +import FRP.Reactive.Internal.Behavior + +-- type EventI t = EventG (Improving t) +-- type ReactiveI t = ReactiveG (Improving t) +-- type BehaviorI t = BehaviorG (Improving t) t + +type EventI t = EventG (ImpBounds t) +type ReactiveI t = ReactiveG (ImpBounds t) +type BehaviorI t = BehaviorG (ImpBounds t) t + +-- | Time-specialized behaviors. +-- Note: The signatures of all of the behavior functions can be generalized. Is +-- the interface generality worth the complexity? +type Behavior = BehaviorI TimeT + +-- Synonym for 'Behavior' +type Behaviour = Behavior + + +-- | The identity generalized behavior. Has value @t@ at time @t@. +-- +-- > time :: Behavior TimeT +time :: (Ord t) => BehaviorI t t +time = beh (pure (fun id)) + +-- Turn a reactive value into a discretly changing behavior. +rToB :: ReactiveI t a -> BehaviorI t a +rToB = beh . fmap pure + +-- Then use 'rToB' to promote reactive value functions to behavior +-- functions. + +-- | Discretely changing behavior, based on an initial value and a +-- new-value event. +-- +-- >stepper :: a -> Event a -> Behavior a +stepper :: a -> EventI t a -> BehaviorI t a +stepper = (result.result) rToB R.stepper + +-- Suggested by Robin Green: + +-- stepper = select pure + +-- -- | Use a key event to key into a behaviour-valued function +-- select :: (a -> Behavior b) -> a -> Event a -> Behavior b +-- select f a e = f a `switcher` (f <$> e) + +-- Looking for a more descriptive name. + +-- | Switch between behaviors. +-- +-- > switcher :: Behavior a -> Event (Behavior a) -> Behavior a +switcher :: (Ord tr, Bounded tr) => + BehaviorG tr tf a + -> EventG tr (BehaviorG tr tf a) + -> BehaviorG tr tf a +b `switcher` eb = beh (unb b `R.switcher` (unb <$> eb)) + +-- | Snapshots a behavior whenever an event occurs and combines the values +-- using the combining function passed. Take careful note of the order of +-- arguments and results. +-- +-- > snapshotWith :: (a -> b -> c) -> Behavior b -> Event a -> Event c +snapshotWith :: (Ord t) => + (a -> b -> c) + -> BehaviorI t b -> EventI t a -> EventI t c +snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e) + where + f ((a,t),tfun) = h a (tfun `apply` t) + + +-- 'snapshotWith' is where tr meets tf. withTimeE is specialized from +-- withTimeGE, converting the ITime into a TimeT. This specialization +-- interferes with the generality of several functions in this module, +-- which are therefore now still using 'Behavior' instead of 'BehaviorG'. +-- Figure out how to get generality. + + +-- | Snapshot a behavior whenever an event occurs. See also +-- 'snapshotWith'. Take careful note of the order of arguments and +-- results. +-- +-- > snapshot :: Behavior b -> Event a -> Event (a,b) +snapshot :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t (a,b) +snapshot = snapshotWith (,) + +-- TODO: tweak withTimeE so that 'snapshotWith' and 'snapshot' can have +-- more general types. The problem is that withTimeE gives a friendlier +-- kind of time, namely known and finite. Necessary? + +-- Alternative implementations: +-- snapshotWith c e b = uncurry c <$> snapshot e b +-- snapshotWith c = (result.result.fmap) (uncurry c) snapshot + +-- | Like 'snapshot' but discarding event data (often @a@ is '()'). +-- +-- > snapshot_ :: Behavior b -> Event a -> Event b +snapshot_ :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t b +snapshot_ = snapshotWith (flip const) + +-- Alternative implementations +-- e `snapshot_` src = snd <$> (e `snapshot` src) +-- snapshot_ = (result.result.fmap) snd snapshot + +-- | Filter an event according to whether a reactive boolean is true. +-- +-- > whenE :: Behavior Bool -> Event a -> Event a +whenE :: (Ord t) => BehaviorI t Bool -> EventI t a -> EventI t a +b `whenE` e = joinMaybes (h <$> (b `snapshot` e)) + where + h (a,True) = Just a + h (_,False) = Nothing + +-- TODO: Same comment about generality as with snapshot + +-- | Behavior from an initial value and an updater event. See also +-- 'accumE'. +-- +-- > accumB :: a -> Event (a -> a) -> Behavior a +accumB :: a -> EventI t (a -> a) -> BehaviorI t a +accumB = (result.result) rToB R.accumR + +-- -- | Like 'scanl' for behaviors. See also 'scanlE'. +-- scanlB :: (a -> b -> a) -> a -> Event b -> Behavior a +-- scanlB = (result.result.result) rToB R.scanlR + +-- -- | Accumulate values from a monoid-valued event. Specialization of +-- -- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. +-- monoidB :: Monoid a => Event a -> Behavior a +-- monoidB = result rToB R.monoidR + + +---- The next versions are more continuous: + +-- type RF a = Reactive (Fun TimeT a) + +-- scanlB :: forall a c. (Behavior a -> c -> Behavior a) -> Behavior a +-- -> Event c -> Behavior a +-- scanlB f b0 e = beh (scanlRF f' (unb b0) e) +-- where +-- f' :: RF a -> c -> RF a +-- f' r c = unb (f (beh r) c) + +-- scanlRF :: (RF a -> c -> RF a) -> RF a -> Event c -> RF a +-- scanlRF h rf0 e = join (R.scanlR h rf0 e) + +-- monoidB :: Monoid a => Event (Behavior a) -> Behavior a +-- monoidB = scanlB mappend mempty + +-- -- I doubt the above definitions work well. They accumulate reactives without +-- -- aging them. See 'accumE'. + + +-- | Like 'scanl' for behaviors. See also 'scanlE'. +-- +-- > scanlB :: forall a. (Behavior a -> Behavior a -> Behavior a) -> Behavior a +-- > -> Event (Behavior a) -> Behavior a + +-- TODO: generalize scanlB's type + +scanlB :: forall a b tr tf. (Ord tr, Bounded tr) => + (b -> BehaviorG tr tf a -> BehaviorG tr tf a) + -> BehaviorG tr tf a + -> EventG tr b -> BehaviorG tr tf a +scanlB plus zero = h + where + h :: EventG tr b -> BehaviorG tr tf a + h e = zero `switcher` (g <$> onceRestE e) + g :: (b, EventG tr b) -> BehaviorG tr tf a + g (b, e') = b `plus` h e' + + +-- | Accumulate values from a monoid-valued event. Specialization of +-- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'. +-- +-- > monoidB :: Monoid a => Event (Behavior a) -> Behavior a +monoidB :: (Ord tr, Bounded tr, Monoid a) => EventG tr (BehaviorG tr tf a) + -> BehaviorG tr tf a +monoidB = scanlB mappend mempty + +-- | Like 'sum' for behaviors. +-- +-- > sumB :: AdditiveGroup a => Event a -> Behavior a +sumB :: (Ord t, AdditiveGroup a) => EventI t a -> BehaviorI t a +sumB = result rToB R.sumR + +-- | Start out blank ('Nothing'), latching onto each new @a@, and blanking +-- on each @b@. If you just want to latch and not blank, then use +-- 'mempty' for the second event. +-- +-- > maybeB :: Event a -> Event b -> Behavior (Maybe a) +maybeB :: (Ord t) => + EventI t a -> EventI t b -> BehaviorI t (Maybe a) +maybeB = (result.result) rToB R.maybeR + +-- | Flip-flopping behavior. Turns true whenever first event occurs and +-- false whenever the second event occurs. +-- +-- > flipFlop :: Event a -> Event b -> Behavior Bool +flipFlop :: (Ord t) => EventI t a -> EventI t b -> BehaviorI t Bool +flipFlop = (result.result) rToB R.flipFlop + +-- | Count occurrences of an event. See also 'countE'. +-- +-- > countB :: Num n => Event a -> Behavior n +countB :: (Ord t, Num n) => EventI t a -> BehaviorI t n +countB = result rToB R.countR + +-- | Euler integral. +-- +-- > integral :: (VectorSpace v, Scalar v ~ TimeT) => +-- > Event () -> Behavior v -> Behavior v +integral :: (VectorSpace v, AffineSpace t, Scalar v ~ Diff t, Ord t) => + EventI t a -> BehaviorI t v -> BehaviorI t v +integral t b = sumB (snapshotWith (*^) b (diffE (time `snapshot_` t))) + +-- TODO: This integral definition is piecewise-constant. Change to piecewise-linear. + + +-- TODO: find out whether this integral works recursively. If not, then +-- fix the implementation, rather than changing the semantics. (No +-- "delayed integral".) +-- +-- Early experiments suggest that recursive integration gets stuck. +-- Chuan-kai Lin has come up with a new lazier R.snapshotWith, but it +-- leaks when the reactive value changes in between event occurrences. + + +---- Comonadic stuff + +-- Orphan. Move elsewhere + +instance (Functor g, Functor f, Copointed g, Copointed f) + => Copointed (g :. f) where + extract = extract . extract . unO + +-- instance (Comonad g, Comonad f) => Comonad (g :. f) where +-- duplicate = inO (fmap duplicate . duplicate) + + +-- WORKING HERE + +-- The plan for duplicate: +-- +-- (g :. f) a -> g (f a) -> g (f (f a)) -> g (g (f (f a))) +-- -> g (f (g (f a))) -> (g :. f) (g (f a)) +-- -> (g :. f) ((g :. f) a) -> + +-- But we'll have to do that middle twiddle, which I couldn't do for +-- behaviors to get a Monad either. Is there another way? + + +-- instance Comonad (g :. f) where +-- duplicate + +deriving instance (Monoid tr, Monoid tf) => Copointed (BehaviorG tr tf) + +-- ITime and TimeT are not currently monoids. They can be when I wrap +-- them in the Sum monoid constructor, in which mempty = 0 and mappend = +-- (+). This monoid change moves us from absolute to relative time. What +-- do I do for never-occuring futures and terminating events? + +-- + +-- instance (Ord t, Monoid t, Monoid (Improving t)) => Comonad (BehaviorI t) where +-- duplicate = duplicateB + +-- duplicateB :: forall t a. +-- (Ord t, Monoid t, Monoid (Improving t)) => +-- BehaviorI t -> BehaviorI t (BehaviorI t a) where +-- duplicate b@(_ `Stepper`) = bb0 `switcher` +-- where +-- f0 `R.Stepper` e = unb b +-- bb0 = beh (pure (fun (\ t -> undefined))) + +-- f0 :: T a + +-- e :: E (T a) + +-- duplicate f0 :: T (T a) + + +-- b :: B a + +-- unb b :: R (T a) + + + +-- dup b :: B (B a) + + +-- TODO: generalize to BehaviorG +-- TODO: something about Monoid (Improving t) + +-- Standard instances for applicative functors + +-- #define APPLICATIVE Behavior +-- #include "Num-inc.hs" diff --git a/src/FRP/Reactive/Fun.hs b/src/FRP/Reactive/Fun.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Fun.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Fun +-- Copyright : (c) Conal Elliott 2007 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Functions, with constant functions optimized, with instances for many +-- standard classes. +---------------------------------------------------------------------- + +module FRP.Reactive.Fun (Fun, fun, apply, batch) where + +import Prelude hiding + ( zip, zipWith +#if __GLASGOW_HASKELL__ >= 609 + , (.), id +#endif + ) +#if __GLASGOW_HASKELL__ >= 609 +import Control.Category +#endif + + +import Data.Monoid (Monoid(..)) +import Control.Applicative (Applicative(..),liftA) +import Control.Arrow +#if __GLASGOW_HASKELL__ < 610 + hiding (pure) +#endif +import Text.Show.Functions () + +import Control.Comonad + +import Data.Zip (Zip(..)) + +import Test.QuickCheck +import Test.QuickCheck.Checkers +import Test.QuickCheck.Classes + +import FRP.Reactive.Internal.Fun + + +-- TODO: write RULE for fun . const = K +fun :: (t -> a) -> Fun t a +fun = Fun + +instance (CoArbitrary a,Arbitrary b) => Arbitrary (Fun a b) where + arbitrary = oneof [liftA K arbitrary, liftA Fun arbitrary] + +instance (Arbitrary a, CoArbitrary b) => CoArbitrary (Fun a b) where + coarbitrary (K a) = variant (0 :: Int) . coarbitrary a + coarbitrary (Fun x) = variant (1 :: Int) . coarbitrary x + +instance Show b => Show (Fun a b) where + show (K x) = "K " ++ show x + show (Fun f) = "Fun " ++ show f + +instance (Show a, Arbitrary a, EqProp a, EqProp b) => EqProp (Fun a b) where + (=-=) = eqModels + +instance Model (Fun a b) (a -> b) where + model = apply + +instance Model1 (Fun a) ((->) a) where + model1 = apply + +-- | 'Fun' as a function +apply :: Fun t a -> (t -> a) +apply (K a) = const a +apply (Fun f) = f + +instance Monoid a => Monoid (Fun t a) where + mempty = K mempty + K a `mappend` K a' = K (a `mappend` a') + funa `mappend` funb = Fun (apply funa `mappend` apply funb) + +instance Functor (Fun t) where + fmap f (K a) = K (f a) + fmap f (Fun g) = Fun (f.g) -- == Fun (fmap f g) + +instance Zip (Fun t) where + K x `zip` K y = K (x,y) + cf `zip` cx = Fun (apply cf `zip` apply cx) + +instance Applicative (Fun t) where + pure = K + K f <*> K x = K (f x) + cf <*> cx = Fun (apply cf <*> apply cx) + +instance Monad (Fun t) where + return = pure + K a >>= h = h a + Fun f >>= h = Fun (f >>= apply . h) + +#if __GLASGOW_HASKELL__ >= 609 +instance Category Fun where + id = Fun id + K b . _ = K b + Fun g . K a = K (g a) + Fun f . Fun g = Fun (f . g) +#endif + +instance Arrow Fun where + arr = Fun +#if __GLASGOW_HASKELL__ < 609 + _ >>> K b = K b + K a >>> Fun g = K (g a) + Fun g >>> Fun f = Fun (g >>> f) +#endif + first = Fun . first . apply + second = Fun . second . apply + K a' *** K b' = K (a',b') + f *** g = first f >>> second g + +instance Pointed (Fun t) where + point = K + +instance Monoid t => Copointed (Fun t) where + extract = extract . apply + +instance Monoid t => Comonad (Fun t) where + duplicate (K a) = K (K a) + duplicate (Fun f) = Fun (Fun . duplicate f) + + + +---------------------------------- + +batch :: TestBatch +batch = ( "FRP.Reactive.Fun" + , concatMap unbatch + [ monoid (undefined :: Fun NumT [T]) + , semanticMonoid (undefined :: Fun NumT [T]) + , functor (undefined :: Fun NumT (NumT,T,NumT)) + , semanticFunctor (undefined :: Fun NumT ()) + , applicative (undefined :: Fun NumT (NumT,T,NumT)) + , semanticApplicative (undefined :: Fun NumT ()) + , monad (undefined :: Fun NumT (NumT,T,NumT)) + , semanticMonad (undefined :: Fun NumT ()) + , arrow (undefined :: Fun NumT (NumT,T,NumT)) + , ("specifics", + [("Constants are" + ,property (\x -> (K (x :: NumT)) =-= + ((fun . const $ x) :: Fun T NumT)))]) + ] + ) diff --git a/src/FRP/Reactive/Future.hs b/src/FRP/Reactive/Future.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Future.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Future +-- Copyright : (c) Conal Elliott 2007-2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- A simple formulation of functional /futures/, roughly as +-- described at . +-- +-- A /future/ is a value with an associated time of /arrival/. Typically, +-- neither the time nor the value can be known until the arrival time. +-- +-- Primitive futures can be things like /the value of the next key you +-- press/, or /the value of LambdaPix stock at noon next Monday/. +-- +-- Composition is via standard type classes: 'Functor', 'Applicative', +-- 'Monad', and 'Monoid'. Some comments on the 'Future' instances of +-- these classes: +-- +-- * Monoid: 'mempty' is a future that never arrives (infinite time and +-- undefined value), and @a `mappend` b@ is the earlier of @a@ and @b@, +-- preferring @a@ when simultaneous. +-- +-- * 'Functor': apply a function to a future argument. The (future) +-- result arrives simultaneously with the argument. +-- +-- * 'Applicative': 'pure' gives value arriving negative infinity. +-- '(\<*\>)' applies a future function to a future argument, yielding a +-- future result that arrives once /both/ function and argument have +-- arrived (coinciding with the later of the two times). +-- +-- * 'Monad': 'return' is the same as 'pure' (as usual). @(>>=)@ cascades +-- futures. 'join' resolves a future future value into a future value. +-- +-- Futures are parametric over /time/ as well as /value/ types. The time +-- parameter can be any ordered type and is particularly useful with time +-- types that have rich partial information structure, such as /improving +-- values/. +---------------------------------------------------------------------- + +module FRP.Reactive.Future + ( + -- * Time & futures + Time, ftime + , FutureG(..), isNeverF, inFuture, inFuture2, futTime, futVal, future + , withTimeF + -- * Tests + , batch + ) where + +import Data.Monoid (Monoid(..)) + +import Data.Max +-- import Data.AddBounds +import FRP.Reactive.Internal.Future + +-- Testing +import Test.QuickCheck +import Test.QuickCheck.Checkers +import Test.QuickCheck.Classes + +{---------------------------------------------------------- + Time and futures +----------------------------------------------------------} + +-- | Make a finite time +ftime :: t -> Time t +ftime = Max + +-- FutureG representation in Internal.Future + +instance (Bounded t, Eq t, EqProp t, EqProp a) => EqProp (FutureG t a) where + u =-= v | isNeverF u && isNeverF v = property True + Future a =-= Future b = a =-= b + +-- I'd rather say: +-- +-- instance (Bounded t, EqProp t, EqProp a) => EqProp (FutureG t a) where +-- Future a =-= Future b = +-- (fst a =-= maxBound && fst b =-= maxBound) .|. a =-= b +-- +-- However, I don't know how to define disjunction on QuickCheck properties. + +-- | A future's time +futTime :: FutureG t a -> Time t +futTime = fst . unFuture + +-- | A future's value +futVal :: FutureG t a -> a +futVal = snd . unFuture + +-- | A future value with given time & value +future :: t -> a -> FutureG t a +future t a = Future (ftime t, a) + +-- | Access time of future +withTimeF :: FutureG t a -> FutureG t (Time t, a) +withTimeF = inFuture $ \ (t,a) -> (t,(t,a)) + +-- withTimeF = inFuture duplicate (with Comonad) + +-- TODO: Eliminate this Monoid instance. Derive Monoid along with all the +-- other classes. And don't use mempty and mappend for the operations +-- below. For one thing, the current instance makes Future a monoid but +-- unFuture not be a monoid morphism. + +instance (Ord t, Bounded t) => Monoid (FutureG t a) where + mempty = Future (maxBound, error "Future mempty: it'll never happen, buddy") + -- Pick the earlier future. + Future (s,a) `mappend` Future (t,b) = + Future (s `min` t, if s <= t then a else b) + +-- Consider the following simpler definition: +-- +-- fa@(Future (s,_)) `mappend` fb@(Future (t,_)) = +-- if s <= t then fa else fb +-- +-- Nothing can be known about the resulting future until @s <= t@ is +-- determined. In particular, we cannot know lower bounds for the time. +-- In contrast, the actual 'mappend' definition can potentially yield +-- useful partial information, such as lower bounds, about the future +-- time, if the type parameter @t@ has rich partial information structure +-- (non-flat). + +-- For some choices of @t@, there may be an efficient combination of 'min' +-- and '(<=)', so the 'mappend' definition is sub-optimal. In particular, +-- 'Improving' has 'minI'. + + +-- -- A future known never to happen (by construction), i.e., infinite time. +-- isNever :: FutureG t a -> Bool +-- isNever = isMaxBound . futTime +-- where +-- isMaxBound (Max MaxBound) = True +-- isMaxBound _ = False +-- +-- This function is an abstraction leak. Don't export it to library +-- users. + + + +{---------------------------------------------------------- + Tests +----------------------------------------------------------} + +-- Represents times at a given instant. +newtype TimeInfo t = TimeInfo (Maybe t) + deriving EqProp + +instance Bounded t => Bounded (TimeInfo t) where + minBound = TimeInfo (Just minBound) + maxBound = TimeInfo Nothing + + +-- A time at a given instant can be some unknown time in the future +unknownTimeInFuture :: TimeInfo a +unknownTimeInFuture = TimeInfo Nothing + +-- or, a known time in the past. We're ignoring known future times for now. +knownTimeInPast :: a -> TimeInfo a +knownTimeInPast = TimeInfo . Just + +instance Eq a => Eq (TimeInfo a) where + TimeInfo Nothing == TimeInfo Nothing = error "Cannot tell if two unknown times in the future are equal" + TimeInfo (Just _) == TimeInfo Nothing = False + TimeInfo Nothing == TimeInfo (Just _) = False + TimeInfo (Just a) == TimeInfo (Just b) = a == b + +instance Ord a => Ord (TimeInfo a) where + -- The minimum of two unknown times in the future is an unkown time in the + -- future. + TimeInfo Nothing `min` TimeInfo Nothing = unknownTimeInFuture + TimeInfo Nothing `min` b = b + a `min` TimeInfo Nothing = a + TimeInfo (Just a) `min` TimeInfo (Just b) = (TimeInfo . Just) (a `min` b) + + TimeInfo Nothing <= TimeInfo Nothing = error "Cannot tell if one unknown time in the future is less than another." + TimeInfo Nothing <= TimeInfo (Just _) = False + TimeInfo (Just _) <= TimeInfo Nothing = True + TimeInfo (Just a) <= TimeInfo (Just b) = a <= b + +batch :: TestBatch +batch = ( "FRP.Reactive.Future" + , concatMap unbatch + [ monoid (undefined :: FutureG NumT T) + , functorMonoid (undefined :: FutureG NumT + (T,NumT)) + -- Checking the semantics here isn't necessary because + -- the implementation is identical to them. + -- + -- Also, Functor, Applicative, and Monad don't require checking + -- since they are automatically derived. + -- + -- , semanticMonoid' (undefined :: FutureG NumT T) + -- , functor (undefined :: FutureG NumT (T,NumT,T)) + -- , semanticFunctor (undefined :: FutureG NumT ()) + -- , applicative (undefined :: FutureG NumT (NumT,T,NumT)) + -- , semanticApplicative (undefined :: FutureG NumT ()) + -- , monad (undefined :: FutureG NumT (NumT,T,NumT)) + -- , semanticMonad (undefined :: FutureG NumT ()) + + , ("specifics", + [ ("laziness", property laziness ) + ]) + ] + ) + where + laziness :: BoundedT -> T -> Property + laziness t a = (uf `mappend` uf) `mappend` kf =-= kf + where + uf = unknownFuture + kf = knownFuture + knownFuture = future (knownTimeInPast t) a + unknownFuture = future unknownTimeInFuture (error "cannot retrieve value at unknown time at the future") + + +-- Move to checkers +type BoundedT = Int diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Improving.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Improving +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Improving values -- efficient version +---------------------------------------------------------------------- + +module FRP.Reactive.Improving + ( + Improving(..), exactly, before, after, minI, maxI + , batch + ) where + + +import Data.Function (on) +import Text.Show.Functions () +import Control.Applicative (pure,(<$>),liftA2) + +import Data.Unamb (unamb,parCommute,pmin,pmax) + +import Test.QuickCheck +-- import Test.QuickCheck.Instances +import Test.QuickCheck.Checkers +import Test.QuickCheck.Classes +import Test.QuickCheck.Instances.Num + + +{---------------------------------------------------------- + Improving values +----------------------------------------------------------} + +-- | An improving value. +data Improving a = Imp { exact :: a, compareI :: a -> Ordering } + -- deriving Show + +instance Show a => Show (Improving a) where + show = ("Imp "++) . show . exact + +-- | A known improving value (which doesn't really improve) +exactly :: Ord a => a -> Improving a +exactly a = Imp a (compare a) + +-- | A value known to be @< x@. +before :: Ord a => a -> Improving a +before x = Imp undefined comp + where + comp y | x <= y = LT + | otherwise = error "before: comparing before" + +-- | A value known to be @> x@. +after :: Ord a => a -> Improving a +after x = Imp undefined comp + where + comp y | x >= y = GT + | otherwise = error "after: comparing after" + + +instance Eq a => Eq (Improving a) where + -- (==) = (==) `on` exact + -- This version can prove inequality without having to know both values + -- exactly. + (==) = parCommute (\ u v -> u `compareI` exact v == EQ) + +-- TODO: experiment with these two versions of (==). The 'parCommute' one +-- can return 'False' sooner than the simpler def, but I doubt it'll +-- return 'True' any sooner. + +instance Ord a => Ord (Improving a) where + min = (result.result) fst minI + (<=) = (result.result) snd minI + max = (result.result) fst maxI + +-- | Efficient combination of 'min' and '(<=)' +minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool) +~(Imp u uComp) `minI` ~(Imp v vComp) = (Imp uMinV wComp, uLeqV) + where + uMinV = if uLeqV then u else v + -- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@. + uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT) + wComp = liftA2 pmin uComp vComp + +-- -- (u `min` v) `compare` t: Try comparing according to whether u <= v, +-- -- or go with either answer if they agree, e.g., if both say GT. +-- -- And say GT if either comp says LT. +-- wComp t = (uCt `asAgree` LT `unamb` vCt `asAgree` LT) -- LT cases +-- `unamb` (uCt `min` vCt) -- EQ and GT case +-- where +-- uCt = uComp t +-- vCt = vComp t + +-- | Efficient combination of 'max' and '(>=)' +maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool) +~(Imp u uComp) `maxI` ~(Imp v vComp) = (Imp uMaxV wComp, uGeqV) + where + uMaxV = if uGeqV then u else v + -- u >= v: Try @v `compare` u /= GT@ and @u `compare` v /= LT@. + uGeqV = (vComp u /= GT) `unamb` (uComp v /= LT) + wComp = liftA2 pmax uComp vComp + +-- -- (u `max` v) `compare` t: Try comparing according to whether u >= v, +-- -- or go with either answer if they agree, e.g., if both say LT. +-- -- And say LT if either comp says GT. +-- wComp t = (uCt `asAgree` GT `unamb` vCt `asAgree` GT) -- GT cases +-- `unamb` (uCt `max` vCt) -- EQ and LT case +-- where +-- uCt = uComp t +-- vCt = vComp t + +-- TODO: reconsider these wComp tests and look for a smaller set. + +-- TODO: factor commonality out of 'minI' and 'maxI' or combine into +-- a single function. + +-- TODO: Are the lazy patterns at all helpful? + + +-- Experimental 'Bounded' instance. I'm curious about it as an +-- alternative to using 'AddBounds'. However, it seems to lose the +-- advantage of a knowably infinite value, which I use in a lot of +-- optimization, including filter/join. + +-- instance Bounded (Improving a) where +-- minBound = error "minBound not defined on Improving" +-- maxBound = Imp (error "exact maxBound") +-- (const GT) + +instance (Ord a, Bounded a) => Bounded (Improving a) where + minBound = exactly minBound + maxBound = exactly maxBound + +-- Hack: use 0 as lower bound +-- No, this one won't work, because I'll need to extract the exact value +-- in order to compare with maxBound + +-- instance (Ord a, Num a) => Bounded (Improving a) where +-- minBound = exactly 0 +-- maxBound = -- exactly maxBound +-- Imp (error "Improving maxBound evaluated") +-- (const GT) + + +-- TODO: consider 'undefined' instead 'error', for 'unamb'. However, we +-- lose valuable information if the 'undefined' gets forced with no +-- 'unamb' to handle it. Maybe make 'unamb' handle more exceptions. + + +---- + + +-- Modify the result of a function. See +-- . +result :: (b -> b') -> ((a -> b) -> (a -> b')) +result = (.) + + +---- + +-- For now, generate exactly-knowable values. +-- TODO: generate trickier improving values. + +instance (Ord a, Arbitrary a) => Arbitrary (Improving a) where + arbitrary = exactly <$> arbitrary + +instance (CoArbitrary a) => CoArbitrary (Improving a) where + coarbitrary = coarbitrary . exact + +instance Model (Improving a) a where model = exact + +instance EqProp a => EqProp (Improving a) where + (=-=) = (=-=) `on` exact + +-- TODO: revisit (=-=). Maybe it doesn't have to test for full equality. + +genGE :: (Arbitrary a, Num a) => Improving a -> Gen (Improving a) +genGE i = add i <$> oneof [pure 0, positive] + +-- I didn't use nonNegative in genGE, because I want zero pretty often, +-- especially for the antiSymmetric law. + +add :: Num a => Improving a -> a -> Improving a +add (Imp x comp) dx = Imp (x + dx) (comp . subtract dx) + +batch :: TestBatch +batch = ( "Reactive.Improving" + , concatMap unbatch + [ ordI, semanticOrdI, partial ] + ) + where + ordI = ord (genGE :: Improving NumT -> Gen (Improving NumT)) + semanticOrdI = semanticOrd (undefined :: Improving NumT) + +partial :: TestBatch +partial = ( "Partial" + , [ ("min after" , property (minAL :: NumT -> NumT -> Bool)) + , ("max before", property (maxAL :: NumT -> NumT -> Bool)) + ] + ) + +minAL :: Ord a => a -> a -> Bool +minAL x y = after x `min` after y >= exactly (x `min` y) + +maxAL :: Ord a => a -> a -> Bool +maxAL x y = before x `max` before y <= exactly (x `max` y) + + +-- Now I realize that the Ord laws are implied by semantic Ord property, +-- assuming that the model satisfies the Ord laws. + diff --git a/src/FRP/Reactive/Internal/Behavior.hs b/src/FRP/Reactive/Internal/Behavior.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Behavior.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving + , FlexibleInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Behavior +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Representation of reactive behaviors +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Behavior (BehaviorG(..), beh, unb) where + +import Prelude hiding (zip,unzip) + +import Data.Monoid (Monoid(..)) +import Control.Applicative (Applicative(pure),liftA2) + +-- TypeCompose +import Control.Compose ((:.)(..),unO) +import Data.Zip (Zip(..),Unzip(..)) + +import qualified FRP.Reactive.Reactive as R +-- import FRP.Reactive.Reactive (TimeT) +import FRP.Reactive.Fun + + +-- Reactive behaviors. Simply a reactive 'Fun'ction value. Wrapped in +-- a type composition to get 'Functor' and 'Applicative' for free. + +-- | Reactive behaviors. They can be understood in terms of a simple +-- model (denotational semantics) as functions of time, namely @at :: +-- BehaviorG t a -> (t -> a)@. +-- +-- The semantics of 'BehaviorG' instances are given by corresponding +-- instances for the semantic model (functions). See +-- . +-- +-- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at` +-- t == f (r `at` t)@. +-- +-- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s +-- \<*\> at t@. That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t +-- == (s `at` t) (r `at` t)@. +-- +-- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at +-- . at rr)@. That is, @return a `at` t == a@, and @join rr `at` t == +-- (rr `at` t) `at` t@. As always, @(r >>= f) == join (fmap f r)@. +-- @at (r >>= f) == at r >>= at . f@. +-- +-- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then +-- @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend +-- == liftA2 mappend@. That is, @mempty `at` t == mempty@, and @(r +-- `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@ +newtype BehaviorG tr tf a = Beh { unBeh :: (R.ReactiveG tr :. Fun tf) a } + deriving (Monoid,Functor,Applicative) + +-- Standard Monoid instance for Applicative applied to Monoid. Used by +-- @deriving Monoid@ above. +instance (Applicative (R.ReactiveG tr :. Fun tf), Monoid a) + => Monoid ((R.ReactiveG tr :. Fun tf) a) where + { mempty = pure mempty; mappend = liftA2 mappend } + +-- Standard 'Zip' for an 'Applicative' +instance (Ord tr, Bounded tr) => Zip (BehaviorG tr tf) where zip = liftA2 (,) + +-- Standard 'Unzip' for a 'Functor' +instance Unzip (BehaviorG tr tf) where {fsts = fmap fst; snds = fmap snd} + +-- | Wrap a reactive time fun as a behavior. +beh :: R.ReactiveG tr (Fun tf a) -> BehaviorG tr tf a +beh = Beh . O + +-- | Unwrap a behavior. +unb :: BehaviorG tr tf a -> R.ReactiveG tr (Fun tf a) +unb = unO . unBeh diff --git a/src/FRP/Reactive/Internal/Chan.hs b/src/FRP/Reactive/Internal/Chan.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Chan.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Chan +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (concurrency) +-- +-- Unbounded channels. +-- +----------------------------------------------------------------------------- + +module FRP.Reactive.Internal.Chan + ( + -- * The 'Chan' type + Chan, -- abstract + + -- * Operations + newChan, -- :: IO (Chan a) + writeChan, -- :: Chan a -> a -> IO () + readChan, -- :: Chan a -> IO a + dupChan, -- :: Chan a -> IO (Chan a) + unGetChan, -- :: Chan a -> a -> IO () + isEmptyChan, -- :: Chan a -> IO Bool + + -- * Stream interface + getChanContents, -- :: Chan a -> IO [a] + writeList2Chan, -- :: Chan a -> [a] -> IO () + -- * New stuff + weakChanWriter + ) where + +import Prelude + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Concurrent.MVar +import Data.Typeable + + +import System.Mem.Weak (mkWeak,deRefWeak) + + +#include "Typeable.h" + +-- A channel is represented by two @MVar@s keeping track of the two ends +-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s +-- are used to handle consumers trying to read from an empty channel. + +-- |'Chan' is an abstract type representing an unbounded FIFO channel. +data Chan a + = Chan (MVar (Stream a)) + (MVar (Stream a)) + +INSTANCE_TYPEABLE1(Chan,chanTc,"Chan") + +type Stream a = MVar (ChItem a) + +data ChItem a = ChItem a (Stream a) + +-- See the Concurrent Haskell paper for a diagram explaining the +-- how the different channel operations proceed. + +-- @newChan@ sets up the read and write end of a channel by initialising +-- these two @MVar@s with an empty @MVar@. + +-- |Build and returns a new instance of 'Chan'. +newChan :: IO (Chan a) +newChan = do + hole <- newEmptyMVar + readVar <- newMVar hole + writeVar <- newMVar hole + return (Chan readVar writeVar) + +-- To put an element on a channel, a new hole at the write end is created. +-- What was previously the empty @MVar@ at the back of the channel is then +-- filled in with a new stream element holding the entered value and the +-- new hole. + +-- |Write a value to a 'Chan'. +writeChan :: Chan a -> a -> IO () +writeChan (Chan _ writeVar) val = do + new_hole <- newEmptyMVar + modifyMVar_ writeVar $ \old_hole -> do + putMVar old_hole (ChItem val new_hole) + return new_hole + +-- |Read the next value from the 'Chan'. +readChan :: Chan a -> IO a +readChan (Chan readVar _) = do + modifyMVar readVar $ \read_end -> do + (ChItem val new_read_end) <- readMVar read_end + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + return (new_read_end, val) + +-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to +-- either channel from then on will be available from both. Hence this creates +-- a kind of broadcast channel, where data written by anyone is seen by +-- everyone else. +dupChan :: Chan a -> IO (Chan a) +dupChan (Chan _ writeVar) = do + hole <- readMVar writeVar + newReadVar <- newMVar hole + return (Chan newReadVar writeVar) + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetChan :: Chan a -> a -> IO () +unGetChan (Chan readVar _) val = do + new_read_end <- newEmptyMVar + modifyMVar_ readVar $ \read_end -> do + putMVar new_read_end (ChItem val read_end) + return new_read_end + +-- |Returns 'True' if the supplied 'Chan' is empty. +isEmptyChan :: Chan a -> IO Bool +isEmptyChan (Chan readVar writeVar) = do + withMVar readVar $ \r -> do + w <- readMVar writeVar + let eq = r == w + eq `seq` return eq + +-- Operators for interfacing with functional streams. + +-- |Return a lazy list representing the contents of the supplied +-- 'Chan', much like 'System.IO.hGetContents'. +getChanContents :: Chan a -> IO [a] +getChanContents ch + = unsafeInterleaveIO (do + x <- readChan ch + xs <- getChanContents ch + return (x:xs) + ) + +-- |Write an entire list of items to a 'Chan'. +writeList2Chan :: Chan a -> [a] -> IO () +writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) + + +---- New bit: + +-- | A weak channel writer. Sustained by the read head. Thus channel +-- consumers keep channel producers alive. +weakChanWriter :: Chan a -> IO (IO (Maybe (a -> IO ()))) +weakChanWriter ch@(Chan readVar _) = + fmap deRefWeak (mkWeak readVar (writeChan ch) Nothing) diff --git a/src/FRP/Reactive/Internal/Clock.hs b/src/FRP/Reactive/Internal/Clock.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Clock.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Clock +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Serializing clocks +-- +-- Thanks to Luke Palmer for help with this module. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Clock + (Clock(..), makeClock) where + +import Control.Applicative (liftA2) +import System.Time + +import FRP.Reactive.Reactive (TimeT) +-- import FRP.Reactive.Internal.Misc (Sink) +import FRP.Reactive.Internal.Serial + + +-- | Waits a specified duration and then execute an action +-- type Delay t = t -> forall a. IO a -> IO a + +-- | Waits until just after a specified time and then execute an action, +-- passing in the actual time. +-- type Schedule t = t -> Sink (Sink t) + +-- | A serializing clock. Can (a) produce a time and (b) serialize an +-- action. +data Clock t = Clock { cGetTime :: IO t + , cSerialize :: Serial + } + +-- | Make a clock +makeClock :: IO (Clock TimeT) +makeClock = liftA2 clock getClockTime makeSerial + where + clock :: ClockTime -> Serial -> Clock TimeT + clock refTime serial = + Clock (currRelTime refTime) serial + + +-- TODO: How can I know that actions are carried out monotonically? + +-- | Get the current time in seconds, relative to a start 'ClockTime'. +currRelTime :: ClockTime -> IO TimeT +currRelTime (TOD sec0 pico0) = fmap delta getClockTime + where + delta (TOD sec pico) = + fromIntegral (sec-sec0) + 1.0e-12 * fromIntegral (pico-pico0) diff --git a/src/FRP/Reactive/Internal/Fun.hs b/src/FRP/Reactive/Internal/Fun.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Fun.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Fun +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Constant-optimized representation of functions. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Fun (Fun(..)) where + +-- | Constant-optimized functions +data Fun t a = K a -- ^ constant function + | Fun (t -> a) -- ^ non-constant function diff --git a/src/FRP/Reactive/Internal/Future.hs b/src/FRP/Reactive/Internal/Future.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Future.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Future +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Representation of future values +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Future + ( + -- * Time & futures + Time + , FutureG(..), isNeverF, inFuture, inFuture2 + , runF + ) where + + +import Control.Applicative (Applicative(..)) + +import Control.Comonad (Copointed,Comonad) + +import Test.QuickCheck + +import FRP.Reactive.Internal.Misc (Sink) +import Data.Max +import Data.PairMonad () + + +-- | Time used in futures. The parameter @t@ can be any @Ord@ and +-- @Bounded@ type. Pure values have time 'minBound', while +-- never-occurring futures have time 'maxBound.' +-- type Time t = Max (AddBounds t) + +type Time = Max + + +-- | A future value of type @a@ with time type @t@. Simply a +-- time\/value pair. Particularly useful with time types that have +-- non-flat structure. +newtype FutureG t a = Future { unFuture :: (Time t, a) } + deriving (Functor, Applicative, Monad, Copointed, Comonad {-, Show-} + , Arbitrary, CoArbitrary) + +isNeverF :: (Bounded t, Eq t) => FutureG t t1 -> Bool +isNeverF (Future (t,_)) = t == maxBound + +instance (Eq t, Eq a, Bounded t) => Eq (FutureG t a) where + Future a == Future b = + (fst a == maxBound && fst b == maxBound) || a == b + +-- When I drop @AddBounds@, I use @maxBound@ as infinity/never. I'm +-- uncomfortable with this choice, however. Consider a small type like +-- @Bool@ for @t@. + + +instance (Show t, Show a, Eq t, Bounded t) => Show (FutureG t a) where +-- show (Future (Max t, a)) | t == maxBound = "" +-- | otherwise = "<" ++ show t ++ "," ++ show a ++ ">" + show u | isNeverF u = "" + show (Future (Max t, a)) = "<" ++ show t ++ "," ++ show a ++ ">" + +-- The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance +-- of 'Max'. + + +-- | Apply a unary function within the 'FutureG' representation. +inFuture :: ((Time t, a) -> (Time t', b)) + -> FutureG t a -> FutureG t' b +inFuture f = Future . f . unFuture + +-- | Apply a binary function within the 'FutureG' representation. +inFuture2 :: ((Time t, a) -> (Time t', b) -> (Time t', c)) + -> FutureG t a -> FutureG t' b -> FutureG t' c +inFuture2 f = inFuture . f . unFuture + + +-- | Run a future in the current thread. Use the given time sink to sync +-- time, i.e., to wait for an output time before performing the action. +runF :: Ord t => Sink t -> FutureG t (IO a) -> IO a +runF sync (Future (Max t,io)) = sync t >> io diff --git a/src/FRP/Reactive/Internal/IVar.hs b/src/FRP/Reactive/Internal/IVar.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/IVar.hs @@ -0,0 +1,122 @@ +{-# OPTIONS_GHC -Wall #-} +-- {-# OPTIONS_GHC -fno-state-hack #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.IVar +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Write-once variables. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.IVar + ( IVar, newIVar, readIVar, tryReadIVar, writeIVar + ) where + + +import Control.Concurrent.MVar +import Control.Applicative ((<$>)) +import System.IO.Unsafe (unsafePerformIO) + +newtype IVar a = IVar (MVar a) + +newIVar :: IO (IVar a) +newIVar = IVar <$> newEmptyMVar + +-- | Returns the value in the IVar. The *value* will block +-- until the variable becomes filled. +readIVar :: IVar a -> a +readIVar (IVar v) = unsafePerformIO $ do -- putStrLn "readIVar" + readMVar v + +-- | Returns Nothing if the IVar has no value yet, otherwise +-- returns the value. +tryReadIVar :: IVar a -> IO (Maybe a) +tryReadIVar (IVar v) = do + empty <- isEmptyMVar v + if empty + then return Nothing + else Just <$> readMVar v + +-- | Puts the value of the IVar. If it already has a value, +-- block forever. +writeIVar :: IVar a -> a -> IO () +writeIVar (IVar v) x = putMVar v x + +{- + +-- From: Bertram Felgenhauer +-- to: conal@conal.net +-- date: Mon, Nov 10, 2008 at 1:02 PM +-- subject: About IVars + +-- Interestingly, the code triggers a bug in ghc; you have to compile +-- it with -fno-state-hack if you enable optimization. (Though Simon +-- Marlow says that it's not the state hack's fault. See +-- http://hackage.haskell.org/trac/ghc/ticket/2756) + +-- Hm: ghc balks at {-# OPTIONS_GHC -fno-state-hack #-} + + +-- with a few tweaks by conal + +import Control.Concurrent.MVar +import System.IO.Unsafe (unsafePerformIO) + +-- an IVar consists of +-- a) A lock for the writers. (This avoids the bug explained above.) +-- b) An MVar to put the value into +-- c) The value of the IVar. This is the main difference between +-- our implementations. +data IVar a = IVar (MVar ()) (MVar a) a + +-- Creating an IVar creates two MVars and sets up a suspended +-- takeMVar for reading the value. +-- It relies on unsafePerformIO to execute its body at most once; +-- As far as I know this is true since ghc 6.6.1 -- see +-- http://hackage.haskell.org/trac/ghc/ticket/986 +newIVar :: IO (IVar a) +newIVar = do + lock <- newMVar () + trans <- newEmptyMVar + let {-# NOINLINE value #-} + value = unsafePerformIO $ takeMVar trans + return (IVar lock trans value) + +-- Reading an IVar just returns its value. +readIVar :: IVar a -> a +readIVar (IVar _ _ value) = value + +-- Writing an IVar takes the writer's lock and writes the value. +-- (To match your interface, use takeMVar instead of tryTakeMVar) + +writeIVar :: IVar a -> a -> IO () +writeIVar (IVar lock trans _) value = do + a <- tryTakeMVar lock + case a of + Just () -> putMVar trans value + Nothing -> error "writeIVar: already written" + +-- writeIVar :: IVar a -> a -> IO Bool +-- writeIVar (IVar lock trans _) value = do +-- a <- tryTakeMVar lock +-- case a of +-- Just _ -> putMVar trans value >> return True +-- Nothing -> return False + +-- I didn't originally support tryReadIVar, but it's easily implemented, +-- too. +tryReadIVar :: IVar a -> IO (Maybe a) +tryReadIVar (IVar lock _ value) = fmap f (isEmptyMVar lock) + where + f True = Just value + f False = Nothing + +-- tryReadIVar (IVar lock _ value) = do +-- empty <- isEmptyMVar lock +-- if empty then return (Just value) else return Nothing + +-} diff --git a/src/FRP/Reactive/Internal/Misc.hs b/src/FRP/Reactive/Internal/Misc.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Misc.hs @@ -0,0 +1,20 @@ +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Misc +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Misc Reactive internal defs +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Misc (Action, Sink) where + + +-- | Convenient alias for dropping parentheses. +type Action = IO () + +-- | Value consumer +type Sink a = a -> Action diff --git a/src/FRP/Reactive/Internal/Reactive.hs b/src/FRP/Reactive/Internal/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Reactive.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wall #-} + +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Reactive +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Representation for 'Reactive' and 'Event' types. Combined here, +-- because they're mutually recursive. +-- +-- The representation used in this module is based on a close connection +-- between these two types. A reactive value is defined by an initial +-- value and an event that yields future values; while an event is given +-- as a future reactive value. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Reactive + ( + EventG(..), isNeverE, inEvent, inEvent2, eFutures + , ReactiveG(..), inREvent, inFutR + , runE, runR, forkE, forkR + ) where + +-- import Data.List (intersperse) + +import Control.Concurrent (forkIO,ThreadId) + +import FRP.Reactive.Internal.Misc +import FRP.Reactive.Internal.Future +import Data.Max +-- import Data.AddBounds + +-- | Events. Semantically: time-ordered list of future values. +-- Instances: +-- +-- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend` +-- e'@ is the event that combines occurrences from @e@ and @e'@. +-- +-- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs, +-- and whose occurrence values come from applying @f@ to the values from +-- @e@. +-- +-- * 'Applicative': @pure a@ is an event with a single occurrence at time +-- -Infinity. @ef \<*\> ex@ is an event whose occurrences are made from +-- the /product/ of the occurrences of @ef@ and @ex@. For every occurrence +-- @f@ at time @tf@ of @ef@ and occurrence @x@ at time @tx@ of @ex@, @ef +-- \<*\> ex@ has an occurrence @f x@ at time @tf `max` tx@. N.B.: I +-- don't expect this instance to be very useful. If @ef@ has @nf@ +-- instances and @ex@ has @nx@ instances, then @ef \<*\> ex@ has @nf*nx@ +-- instances. However, there are only @nf+nx@ possibilities for @tf +-- `max` tx@, so many of the occurrences are simultaneous. If you think +-- you want to use this instance, consider using 'Reactive' instead. +-- +-- * 'Monad': @return a@ is the same as @pure a@ (as usual). In @e >>= f@, +-- each occurrence of @e@ leads, through @f@, to a new event. Similarly +-- for @join ee@, which is somehow simpler for me to think about. The +-- occurrences of @e >>= f@ (or @join ee@) correspond to the union of the +-- occurrences (temporal interleaving) of all such events. For example, +-- suppose we're playing Asteroids and tracking collisions. Each collision +-- can break an asteroid into more of them, each of which has to be tracked +-- for more collisions. Another example: A chat room has an /enter/ event, +-- whose occurrences contain new events like /speak/. An especially useful +-- monad-based function is 'joinMaybes', which filters a Maybe-valued +-- event. + +newtype EventG t a = Event { eFuture :: FutureG t (ReactiveG t a) } + +-- The event representation requires temporal monotonicity but does not +-- enforce it, which invites bugs. Every operation therefore must be +-- tested for preserving monotonicity. (Better yet, find an efficient +-- representation that either enforces or doesn't require monotonicity.) + +-- Why the newtype for 'EventG?' Because the 'Monoid' instance of 'Future' +-- does not do what I want for 'EventG'. It will pick just the +-- earlier-occurring event, while I want an interleaving of occurrences +-- from each. Similarly for other classes. + + +-- TODO: Alternative and MonadPlus instances for EventG + +-- | Reactive value: a discretely changing value. Reactive values can be +-- understood in terms of (a) a simple denotational semantics of reactive +-- values as functions of time, and (b) the corresponding instances for +-- functions. The semantics is given by the function @at :: ReactiveG t a -> +-- (t -> a)@. A reactive value may also be thought of (and in this module +-- is implemented as) a current value and an event (stream of future values). +-- +-- The semantics of 'ReactiveG' instances are given by corresponding +-- instances for the semantic model (functions): +-- +-- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at` +-- t == f (r `at` t)@. +-- +-- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s +-- \<*\> at t@. That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t +-- == (s `at` t) (r `at` t)@. +-- +-- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at +-- . at rr)@. That is, @return a `at` t == a@, and @join rr `at` t == +-- (rr `at` t) `at` t@. As always, @(r >>= f) == join (fmap f r)@. +-- @at (r >>= f) == at r >>= at . f@. +-- +-- * 'Monoid': a typical lifted monoid. If @o@ is a monoid, then +-- @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend +-- == liftA2 mappend@. That is, @mempty `at` t == mempty@, and @(r +-- `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@ + +data ReactiveG t a = a `Stepper` EventG t a + + +{-------------------------------------------------------------------- + Applying functions inside of representations +--------------------------------------------------------------------} + +-- | Apply a unary function inside an 'EventG' representation. +inEvent :: (FutureG s (ReactiveG s a) -> FutureG t (ReactiveG t b)) + -> (EventG s a -> EventG t b) +inEvent f = Event . f . eFuture + +-- | Apply a binary function inside an 'EventG' representation. +inEvent2 :: (FutureG t (ReactiveG t a) -> FutureG t (ReactiveG t b) + -> FutureG t (ReactiveG t c)) + -> (EventG t a -> EventG t b -> EventG t c) +inEvent2 f = inEvent . f . eFuture + +-- | Apply a unary function inside the 'rEvent' part of a 'Reactive' +-- representation. +inREvent :: (EventG s a -> EventG t a) + -> (ReactiveG s a -> ReactiveG t a) +inREvent f ~(a `Stepper` e) = a `Stepper` f e + +-- | Apply a unary function inside the future reactive inside a 'Reactive' +-- representation. +inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b)) + -> (ReactiveG s b -> ReactiveG t b) +inFutR = inREvent . inEvent + + +{-------------------------------------------------------------------- + Showing values (exposing rep) +--------------------------------------------------------------------} + +isNeverE :: (Bounded t, Eq t) => EventG t a -> Bool +isNeverE = isNeverF . eFuture + +-- | Make the event into a list of futures +eFutures :: (Bounded t, Eq t) => EventG t a -> [FutureG t a] +eFutures e | isNeverE e = [] +eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e + +-- TODO: redefine 'eFutures' as an unfold + +-- TODO: does this isNeverE interfere with laziness? Does it need an unamb? + +-- Show a future +sFuture :: (Show t, Show a) => FutureG t a -> String +sFuture = show . unFuture + +-- sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")" +-- sFuture (Future (Max MaxBound,_)) = "(infty,_)" +-- sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")" + +-- TODO: Better re-use in sFuture. + +-- Truncated show +sFutures :: (Show t, Show a) => [FutureG t a] -> String + +-- sFutures = show + +-- This next implementation blocks all output until far future occurrences +-- are detected, which causes problems for debugging. I like the "...", +-- so look for another implementation. + +-- sFutures fs = +-- let maxleng = 20 +-- a = (intersperse "->" . map sFuture) fs +-- inf = length (take maxleng a) == maxleng +-- in +-- if not inf then concat a +-- else concat (take maxleng a) ++ "..." + +-- This version uses a lazier intersperse +-- sFutures = take 100 . concat . intersperse' "->" . map sFuture + +-- The following version adds "..." in case of truncation. + +sFutures fs = leading early ++ trailing late + where + (early,late) = splitAt 20 fs + leading = concat . intersperse' "->" . map sFuture + trailing [] = "" + trailing _ = "-> ..." + + +-- TODO: clean up sFutures def: use intercalate, concat before trimming, +-- and define&use a general function for truncating and adding "...". +-- Test. + +instance (Eq t, Bounded t, Show t, Show a) => Show (EventG t a) where + show = ("Event: " ++) . sFutures . eFutures + +instance (Eq t, Bounded t, Show t, Show a) => Show (ReactiveG t a) where + show (x `Stepper` e) = show x ++ " `Stepper` " ++ show e + + +{-------------------------------------------------------------------- + Execution +--------------------------------------------------------------------} + +-- | Run an event in the current thread. Use the given time sink to sync +-- time, i.e., to wait for an output time before performing the action. +runE :: forall t. (Ord t, Bounded t) => Sink t -> Sink (EventG t Action) +runE sync ~(Event (Future (Max t,r))) + | t == maxBound = return () -- finished! + | otherwise = sync t >> runR sync r + +-- In most cases, the value of t won't be known ahead of time, so just +-- evaluating t will do the necessary waiting. + + +-- | Run an event in a new thread, using the given time sink to sync time. +forkE :: (Ord t, Bounded t) => Sink t -> EventG t Action -> IO ThreadId +forkE = (fmap.fmap) forkIO runE + +-- TODO: Revisit this tsync definition. For instance, maybe the MaxBound +-- case ought to simply return. + +-- | Run a reactive value in the current thread, using the given time sink +-- to sync time. +runR :: (Bounded t, Ord t) => Sink t -> Sink (ReactiveG t Action) +runR sync (act `Stepper` e) = act >> runE sync e + +-- | Run a reactive value in a new thread, using the given time sink to +-- sync time. The initial action happens in the current thread. +forkR :: (Ord t, Bounded t) => Sink t -> ReactiveG t Action -> IO ThreadId +forkR = (fmap.fmap) forkIO runR + +----- + +-- intersperse :: a -> [a] -> [a] +-- intersperse _ [] = [] +-- intersperse _ [x] = [x] +-- intersperse sep (x:xs) = x : sep : intersperse sep xs + +-- Lazier intersperse + +intersperse' :: a -> [a] -> [a] +intersperse' _ [] = [] +intersperse' sep (x:xs) = x : continue xs + where + continue [] = [] + continue xs' = sep : intersperse' sep xs' + diff --git a/src/FRP/Reactive/Internal/Serial.hs b/src/FRP/Reactive/Internal/Serial.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Serial.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE Rank2Types, ImpredicativeTypes #-} +-- We need ImpredicativeTypes, but GHC 6.8 doesn't think it +-- has them. The cabal file configures this in a compiler-dependent +-- way. +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Serial +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Serialize actions. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Serial + ( Serial, makeSerial, locking + ) where + +import Control.Concurrent.MVar +import Control.Applicative((<$>)) +import Control.Exception (bracket_) + +-- | Serializer. Turns actions into equivalent but serialized actions +type Serial = forall a. IO a -> IO a + +-- | Make a locking serializer +makeSerial :: IO Serial +makeSerial = locking <$> newEmptyMVar + +-- | Make a locking serializer with a given lock +locking :: MVar () -> Serial +locking lock = bracket_ (putMVar lock ()) (takeMVar lock) diff --git a/src/FRP/Reactive/Internal/TVal.hs b/src/FRP/Reactive/Internal/TVal.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/TVal.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ScopedTypeVariables, TypeOperators #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.TVal +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Timed values. A primitive interface for futures. +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.TVal + ((:-->), (:+->), makeEvent) where + +import Control.Applicative ((<$>)) -- ,liftA2 +-- import Control.Monad (forever) +import Control.Concurrent (forkIO,yield) -- , ThreadId + +-- import Control.Concurrent.Chan hiding (getChanContents) +import FRP.Reactive.Internal.Chan + +--import System.Mem.Weak (mkWeakPtr,deRefWeak) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) + +import Data.Stream (Stream(..)) -- ,streamToList + +import Data.Unamb (unamb,assuming) + +import Data.AddBounds +import FRP.Reactive.Improving (Improving(..)) +import FRP.Reactive.Future (FutureG,future) +import FRP.Reactive.Reactive (Event,TimeT,ITime) +import FRP.Reactive.PrimReactive (futureStreamE) + +import FRP.Reactive.Internal.Misc (Sink) +import FRP.Reactive.Internal.Clock +import FRP.Reactive.Internal.Timing (sleepPast) +import FRP.Reactive.Internal.IVar +-- import FRP.Reactive.Internal.Reactive (isNeverE) + +-- | An @a@ that's fed by a @b@ +type b :--> a = (Sink b, a) + +-- | Make a '(:-->)'. +type b :+-> a = IO (b :--> a) + +-- | A value that becomes defined at some time. 'timeVal' may block if +-- forced before the time & value are knowable. 'definedAt' says whether +-- the value is defined at (and after) a given time and likely blocks +-- until the earlier of the query time and the value's actual time. +data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool } + +makeTVal :: Clock TimeT -> a :+-> TVal TimeT a +makeTVal (Clock getT _) = do -- putStrLn "makeTVal" + f <$> newIVar + where + f v = (sink, TVal (readIVar v) (unsafePerformIO . undefAt)) + where + undefAt t = + -- Read v after time t. If it's undefined, then it wasn't defined + -- at t. If it is defined, then see whether it was defined before t. + do -- putStrLn $ "undefAt " ++ show t + -- ser $ putStrLn $ "sleepPast " ++ show t + sleepPast getT t +-- maybe False ((< t) . fst) <$> tryReadIVar v + + value <- tryReadIVar v + case value of + -- We're past t, if it's not defined now, it wasn't at t. + Nothing -> return False + -- If it became defined before t, then it's defined now. + Just (t',_) -> return (t' < t) + + sink a = do -- putStrLn "sink" + t <- getT + writeIVar v (t,a) + + -- sink a = getT >>= writeIVar v . flip (,) a + +-- TODO: oops - the definedAt in makeTVal always waits until the given +-- time. It could also grab the time and compare with t. Currently that +-- comparison is done in tValImp. How can we avoid the redundant test? +-- We don't really have to avoid it, since makeTVal isn't exported. + +-- | 'TVal' as 'Future' +tValFuture :: Ord t => TVal t a -> FutureG (Improving (AddBounds t)) a +tValFuture v = future (tValImp v) (snd (timeVal v)) + +-- | 'TVal' as 'Improving' +tValImp :: Ord t => TVal t a -> Improving (AddBounds t) +tValImp v = Imp ta (\ t' -> assuming (not (definedAt' v t')) GT + `unamb` (ta `compare` t')) + where + ta = NoBound (fst (timeVal v)) + +definedAt' :: TVal t a -> AddBounds t -> Bool +definedAt' _ MinBound = False +definedAt' tval (NoBound t) = definedAt tval t +definedAt' _ MaxBound = True + +-- definedAt' _ _ = error "definedAt': non-NoBound" + + +-- -- | Make a new event and a sink that writes to it. Uses the given +-- -- clock to serialize and time-stamp. +-- makeEvent :: Clock TimeT -> a :+-> Event a +-- makeEvent clock = +-- do chanA <- newChan +-- chanF <- newChan +-- spin $ do +-- -- Get the skeleton tval written out immediately. Details will +-- -- be added +-- (tval,snka) <- makeTVal clock +-- writeChan chanF (tValFuture tval) +-- readChan chanA >>= snka +-- futs <- getChanContents chanF +-- return (futuresE futs, writeChanY chanA) + +-- makeTVal :: Clock TimeT -> a :+-> TVal TimeT a + + +-- | Make a connected sink/future pair. The sink may only be written to once. +makeFuture :: Clock TimeT -> (a :+-> FutureG ITime a) +makeFuture = (fmap.fmap.fmap) tValFuture makeTVal + +-- | Make a new event and a sink that writes to it. Uses the given +-- clock to serialize and time-stamp. +makeEvent :: Clock TimeT -> forall a. Show a => (a :+-> Event a) +makeEvent clock = (fmap.fmap) futureStreamE (listSink (makeFuture clock)) + +-- makeEvent clock = +-- do (snk,s) <- listSink (makeFuture clock) +-- let e = futureStreamE s +-- putStrLn $ "isNeverE e == " ++ show (isNeverE e) +-- -- putStrLn $ "makeEvent: e == " ++ show e +-- return (snk, e) + + +-- Turn a single-feedable into a multi-feedable + +-- listSink :: (b :+-> a) -> (b :+-> [a]) +-- listSink mk = do chanA <- newChan +-- chanB <- newChan +-- spin $ do +-- (snk,a) <- mk +-- -- putStrLn "writing input" +-- writeChan chanA a +-- readChan chanB >>= snk +-- as <- getChanContents chanA +-- return (writeChanY chanB, as) + +listSink :: Show a => (b :+-> a) -> (b :+-> Stream a) + +-- listSink mk = do chanA <- newChan +-- chanB <- newChan +-- spin $ do +-- (snk,a) <- mk +-- -- putStrLn "writing input" +-- writeChan chanA a +-- readChan chanB >>= snk +-- as <- getChanStream chanA +-- return (writeChanY chanB, as) +-- spin :: IO a -> IO ThreadId +-- spin = forkIO . forever + + +-- Yield control after channel write. Helps responsiveness +-- tremendously. +writeChanY :: Chan a -> Sink a +writeChanY ch x = writeChan ch x >> yield +-- Equivalently: +-- writeChanY = (fmap.fmap) (>> yield) writeChan + + + + +-- I want to quit gathing input when no one is listening, to eliminate a +-- space leak. Here's my first attempt: + +-- listSink mk = do chanA <- newChan +-- chanB <- newChan +-- wchanA <- mkWeakPtr chanA Nothing +-- let loop = +-- do mbch <- deRefWeak wchanA +-- case mbch of +-- Nothing -> +-- do -- putStrLn "qutting" +-- return () +-- Just ch -> +-- do -- putStrLn "add value" +-- (a,snk) <- mk +-- writeChan ch a +-- readChan chanB >>= snk +-- loop +-- forkIO loop +-- as <- getChanContents chanA +-- return (writeChanY chanB, as) + +-- This attempt fails. The weak reference gets lost almost immediately. +-- My hunch: ghc optimizes away the Chan representation when compiling +-- getChanContents, and just holds onto the read and write ends (mvars), +-- via a technique described at ICFP 07. I don't know how to get a +-- reliable weak reference, without altering Control.Concurrent.Chan. +-- +-- Apparently this problem has popped up before. See +-- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer + + +listSink mk = do -- putStrLn "listSink" + chanA <- newChan + chanB <- newChan + +-- let loop = do (snk,a) <- mk +-- -- putStrLn "sank" +-- writeChanY chanA a +-- readChan chanB >>= snk +-- loop + +-- wwriteA <- weakChanWriter chanA +-- let loop = do (snk,a) <- mk +-- mbw <- wwriteA +-- case mbw of +-- Nothing -> putStrLn "bailing" +-- Just writeA -> do writeA a >> yield +-- readChan chanB >>= snk +-- loop + + wwriteA <- weakChanWriter chanA + let loop = do mbw <- wwriteA + case mbw of + Nothing -> + do -- putStrLn "bailing" + return () + Just writeA -> + do -- putStrLn "writing to weak channel" + (snk,a) <- mk + writeA a + -- putStrLn "wrote" + yield + readChan chanB >>= snk + loop + + _ <- forkIO loop + as <- getChanStream chanA + + -- debugging. defeats freeing. + -- forkIO $ print $ streamToList as + + return (writeChanY chanB, as) + + +-- I hadn't been yielding after writing to chanA. What implications? + + +-- | Variation on 'getChanContents', returning a stream instead of a +-- list. Note that 'getChanContents' only makes infinite lists. I'm +-- hoping to get some extra laziness by using irrefutable 'Cons' pattern +-- when consuming the stream. +getChanStream :: Chan a -> IO (Stream a) + +-- getChanStream ch = unsafeInterleaveIO $ +-- liftA2 Cons (readChan ch) (getChanStream ch) + +getChanStream ch + = unsafeInterleaveIO (do + x <- readChan ch + xs <- getChanStream ch + return (Cons x xs) + ) + + +{- +-} diff --git a/src/FRP/Reactive/Internal/Timing.hs b/src/FRP/Reactive/Internal/Timing.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Internal/Timing.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Internal.Timing +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- +---------------------------------------------------------------------- + +module FRP.Reactive.Internal.Timing + (adaptE,mkUpdater,sleepPast) + where + +import Data.Monoid (mempty) +import Control.Applicative ((<$>)) +import Control.Monad (unless) +import Data.IORef +import Control.Concurrent (threadDelay) +import Control.Concurrent.SampleVar + +-- For IO monoid +import Control.Instances () + +import Data.AddBounds + +import FRP.Reactive.Reactive (exactNB,TimeT,Event) +import FRP.Reactive.Improving (Improving,exact) +import FRP.Reactive.Behavior (Behavior) + +import FRP.Reactive.Internal.Misc (Action,Sink) +import FRP.Reactive.Internal.Reactive (forkR,runE) +import FRP.Reactive.Internal.Behavior (unb) +import FRP.Reactive.Internal.Fun +import FRP.Reactive.Internal.Clock (makeClock,cGetTime) + + + +-- | Execute an action-valued event. +adaptE :: Sink (Event Action) +adaptE e = do clock <- makeClock + runE (sleepPast (cGetTime clock) . exactNB) e + + +-- | If a sample variable is full, act on the contents, leaving it empty. +drainS :: SampleVar a -> Sink (Sink a) +drainS sv snk = do emptySVar <- isEmptySampleVar sv + unless emptySVar (readSampleVar sv >>= snk) + +-- TODO: Generalize from TimeT below, using BehaviorG. + +noSink :: Sink t +noSink = mempty -- const (putStrLn "noSink") + +-- | Make an action to be executed regularly, given a time-source and a +-- action-behavior. The generated action is optimized to do almost no +-- work during known-constant phases of the given behavior. +mkUpdater :: IO TimeT -> Behavior Action -> IO Action +mkUpdater getT acts = + -- The plan: Stash new phases (time functions) in a sample variable as + -- they arise. Every minPeriod, check the sample var for a new value. + do actSVar <- newEmptySampleVar + _ <- forkR (sleepPast' getT . exact) + (writeSampleVar' actSVar <$> unb acts) + tfunRef <- newIORef (noSink :: Sink TimeT) + return $ + do -- When there's a new time fun, execute it once if + -- constant, or remember for repeated execution if + -- non-constant. + now <- getT + -- putStrLn ("scheduler: time == " ++ show now) + drainS actSVar $ \ actF -> + case actF of + K c -> do -- putStrLn "K" + writeIORef tfunRef noSink >> c + Fun f -> do -- putStrLn "Fun" + writeIORef tfunRef f + readIORef tfunRef >>= ($ now) + -- yield -- experiment + where + writeSampleVar' v x = do -- putStrLn "writeSampleVar" + writeSampleVar v x + +-- | Pause a thread for the given duration in seconds +sleep :: Sink TimeT +sleep = threadDelay . ceiling . (1.0e6 *) + +-- sleep = threadDelay . ceiling . (1.0e6 *) + +-- | Sleep past a given time +sleepPast :: IO TimeT -> Sink TimeT +sleepPast getT !target = + -- Snooze until strictly after the target. + do -- The strict evaluation of target is essential here. + -- (See bang pattern.) Otherwise, the next line will grab a + -- time before a possibly long block, and then sleep much + -- longer than necessary. + now <- getT +-- putStrLn $ "sleepPast: now == " ++ show now +-- ++ ", target == " ++ show target + unless (now > target) $ + sleep (target-now) -- >> loop + +-- | Variant of 'sleepPast', taking a possibly-infinite time +sleepPast' :: IO TimeT -> Sink (AddBounds TimeT) +sleepPast' _ MinBound = return () +sleepPast' getT (NoBound target) = sleepPast getT target +sleepPast' _ MaxBound = error "sleepPast MaxBound. Expected??" diff --git a/src/FRP/Reactive/LegacyAdapters.hs b/src/FRP/Reactive/LegacyAdapters.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/LegacyAdapters.hs @@ -0,0 +1,26 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.LegacyAdapters +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Tools for making Reactive adapters for imperative (\"legacy\") +-- libraries. +---------------------------------------------------------------------- + +module FRP.Reactive.LegacyAdapters + ( Sink, Action + , Clock, makeClock, cGetTime + , adaptE, mkUpdater + , module FRP.Reactive.Internal.TVal + ) where + +import FRP.Reactive.Internal.Misc (Sink,Action) +import FRP.Reactive.Internal.Clock (Clock,makeClock,cGetTime) +import FRP.Reactive.Internal.TVal +import FRP.Reactive.Internal.Timing (adaptE,mkUpdater) + diff --git a/src/FRP/Reactive/Num-inc.hs b/src/FRP/Reactive/Num-inc.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Num-inc.hs @@ -0,0 +1,112 @@ +---------------------------------------------------------------------- +-- Meta-Module : Num-inc +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Instances of Num classes for applicative functors. To be #include'd +-- after defining APPLICATIVE as the applicative functor name. +-- +-- You'll also have to import 'pure' and 'liftA2' from +-- "Control.Applicative". +---------------------------------------------------------------------- + +-- This module still needs some think work. It now assumes that Eq, Ord, +-- Enum, and Show are undefined, which is not a good assumption. For +-- instance, Maybe. + + +noOv :: String -> String -> a +noOv ty meth = error $ meth ++ ": No overloading for " ++ ty + +noFun :: String -> a +noFun = noOv "behavior" + +-- Eq & Show are prerequisites for Num, so they need to be faked here +instance Eq (APPLICATIVE b) where + (==) = noFun "(==)" + (/=) = noFun "(/=)" + +instance Ord b => Ord (APPLICATIVE b) where + min = liftA2 min + max = liftA2 max + +instance Enum b => Enum (APPLICATIVE b) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = noFun "fromEnum" + enumFrom = noFun "enumFrom" + enumFromThen = noFun "enumFromThen" + enumFromTo = noFun "enumFromTo" + enumFromThenTo = noFun "enumFromThenTo" + +instance Show (APPLICATIVE b) where + show = noFun "show" + showsPrec = noFun "showsPrec" + showList = noFun "showList" + +instance Num b => Num (APPLICATIVE b) where + negate = fmap negate + (+) = liftA2 (+) + (*) = liftA2 (*) + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance (Num b, Ord b) => Real (APPLICATIVE b) where + toRational = noFun "toRational" + +instance Integral b => Integral (APPLICATIVE b) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem = (fmap.fmap) unzip (liftA2 quotRem) + divMod = (fmap.fmap) unzip (liftA2 divMod) + toInteger = noFun "toInteger" + +instance Fractional b => Fractional (APPLICATIVE b) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating b => Floating (APPLICATIVE b) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance RealFrac b => RealFrac (APPLICATIVE b) where + properFraction = noFun "properFraction" + truncate = noFun "truncate" + round = noFun "round" + ceiling = noFun "ceiling" + floor = noFun "floor" + +instance RealFloat b => RealFloat (APPLICATIVE b) where + floatRadix = noFun "floatRadix" + floatDigits = noFun "floatDigits" + floatRange = noFun "floatRange" + decodeFloat = noFun "decodeFloat" + encodeFloat = (fmap.fmap) pure encodeFloat + exponent = noFun "exponent" + significand = noFun "significand" + scaleFloat n = fmap (scaleFloat n) + isNaN = noFun "isNaN" + isInfinite = noFun "isInfinite" + isDenormalized = noFun "isDenormalized" + isNegativeZero = noFun "isNegativeZero" + isIEEE = noFun "isIEEE" + atan2 = liftA2 atan2 diff --git a/src/FRP/Reactive/Num.hs b/src/FRP/Reactive/Num.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Num.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Num +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Numeric class instances for behaviors +---------------------------------------------------------------------- + +module FRP.Reactive.Num () where + +import Prelude hiding (zip,unzip) + +import FRP.Reactive.Behavior +import Control.Applicative + +import Data.Zip + +noOv :: String -> String -> a +noOv ty meth = error $ meth ++ ": No overloading for " ++ ty + +noFun :: String -> a +noFun = noOv "behavior" + +-- Eq & Show are prerequisites for Num, so they need to be faked here +instance Eq (Behavior b) where + (==) = noFun "(==)" + (/=) = noFun "(/=)" + +instance Ord b => Ord (Behavior b) where + min = liftA2 min + max = liftA2 max + +instance Enum a => Enum (Behavior a) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = noFun "fromEnum" + enumFrom = noFun "enumFrom" + enumFromThen = noFun "enumFromThen" + enumFromTo = noFun "enumFromTo" + enumFromThenTo = noFun "enumFromThenTo" + +instance Show (Behavior b) where + show = noFun "show" + showsPrec = noFun "showsPrec" + showList = noFun "showList" + +instance Num b => Num (Behavior b) where + negate = fmap negate + (+) = liftA2 (+) + (*) = liftA2 (*) + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance (Num a, Ord a) => Real (Behavior a) where + toRational = noFun "toRational" + +instance Integral a => Integral (Behavior a) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem = (fmap.fmap) unzip (liftA2 quotRem) + divMod = (fmap.fmap) unzip (liftA2 divMod) + toInteger = noFun "toInteger" + +instance Fractional b => Fractional (Behavior b) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating b => Floating (Behavior b) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance RealFrac a => RealFrac (Behavior a) where + properFraction = noFun "properFraction" + truncate = noFun "truncate" + round = noFun "round" + ceiling = noFun "ceiling" + floor = noFun "floor" + +instance RealFloat a => RealFloat (Behavior a) where + floatRadix = noFun "floatRadix" + floatDigits = noFun "floatDigits" + floatRange = noFun "floatRange" + decodeFloat = noFun "decodeFloat" + encodeFloat = (fmap.fmap) pure encodeFloat + exponent = noFun "exponent" + significand = noFun "significand" + scaleFloat n = fmap (scaleFloat n) + isNaN = noFun "isNaN" + isInfinite = noFun "isInfinite" + isDenormalized = noFun "isDenormalized" + isNegativeZero = noFun "isNegativeZero" + isIEEE = noFun "isIEEE" + atan2 = liftA2 atan2 diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/PrimReactive.hs @@ -0,0 +1,957 @@ +{-# LANGUAGE TypeOperators, ScopedTypeVariables + , FlexibleInstances, MultiParamTypeClasses + , GeneralizedNewtypeDeriving + #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +-- For ghc-6.6 compatibility +-- {-# OPTIONS_GHC -fglasgow-exts -Wall #-} + +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.PrimReactive +-- Copyright : (c) Conal Elliott 2007 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Functional /events/ and /reactive values/. Semantically, an 'Event' is +-- stream of future values in time order. A 'Reactive' value is a +-- discretly time-varying value. +-- +-- Many of the operations on events and reactive values are packaged as +-- instances of the standard type classes 'Monoid', 'Functor', +-- 'Applicative', and 'Monad'. +-- +-- This module focuses on representation and primitives defined in terms +-- of the representation. See also "FRP.Reactive.Reactive", which +-- re-exports this module, plus extras that do not exploit the +-- representation. My intention for this separation is to ease +-- experimentation with alternative representations. +-- +-- Although the basic 'Reactive' type describes /discretely/-changing +-- values, /continuously/-changing values can be modeled simply as +-- reactive functions. See "FRP.Reactive.Behavior" for a convenient type +-- composition of 'Reactive' and a constant-optimized representation of +-- functions of time. The exact packaging of discrete vs continuous will +-- probably change with more experience. +---------------------------------------------------------------------- + +module FRP.Reactive.PrimReactive + ( -- * Events and reactive values + EventG, ReactiveG + -- * Operations on events and reactive values + , stepper, switcher, withTimeGE, withTimeGR + , futuresE, futureStreamE, listEG, atTimesG, atTimeG + , snapshotWith, accumE, accumR, once + , withRestE, untilE + , justE, filterE + -- , traceE, traceR + -- , mkEvent, mkEventTrace, mkEventShow + , eventOcc + -- * To be moved elsewhere + , joinMaybes, filterMP, result + -- * To be removed when it gets used somewhere + , isMonotoneR + -- * Testing + , batch, infE, monoid_E + -- * Temporary exports, while debugging + -- , snap, merge + ) where + +import Prelude hiding (zip,zipWith) + +import Data.Monoid +import Control.Applicative +import Control.Arrow (first) +import Control.Monad +import Data.Function (on) +-- import Debug.Trace (trace) + +-- TODO: eliminate the needs for this stuff. +import Control.Concurrent (threadDelay) +import Control.Exception (evaluate) +import System.IO.Unsafe + +import Data.Stream (Stream(..)) + +import Control.Comonad + +import Test.QuickCheck +import Test.QuickCheck.Instances +import Test.QuickCheck.Checkers +import Test.QuickCheck.Classes +-- import Data.List + +-- TypeCompose +import Control.Compose ((:.)(..), inO2, Monoid_f(..)) +import Data.Zip +import Control.Instances () -- Monoid (IO ()) + + +import Data.Unamb (unamb, assuming) +import Data.Unamb (race) -- eliminate + +-- import Data.Max +-- import Data.AddBounds +import FRP.Reactive.Future hiding (batch) +import FRP.Reactive.Internal.Reactive + +{-------------------------------------------------------------------- + Events and reactive values +--------------------------------------------------------------------} + +-- Bogus EqProp instance. TODO: replace with a random equality test, such +-- that the collection of all generated tests covers equality. + +instance (Bounded t, Eq t, Eq a, EqProp t, EqProp a) => EqProp (EventG t a) where + a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b) + where + f = take 20 . eFutures + +-- TODO: work less and reach further per (=-=). + +arbitraryE :: (Num t, Ord t, Bounded t, Arbitrary t, Arbitrary u) => Gen (EventG t u) +arbitraryE = frequency + [ -- (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList) + (4, liftA futuresE futureList) + ] + where + -- earliestFuture = Future . (,) (Max MinBound) + -- addStart = (:).earliestFuture + futureList = futureListFinite + -- frequency [(10, futureListFinite), (1,futureListInf)] + futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary +-- futureListInf = +-- liftA2 (zipWith future) (resize 10 nondecreasingInf) +-- (infiniteList arbitrary) + +instance (Arbitrary t, Ord t, Bounded t, Num t, Arbitrary a) => Arbitrary (EventG t a) where + arbitrary = arbitraryE + +instance (CoArbitrary t, CoArbitrary a) => CoArbitrary (EventG t a) where + coarbitrary = coarbitrary . eFuture + +---- + +-- Arbitrary works just like pairs: + +-- instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where +-- arbitrary = liftA2 Stepper arbitrary arbitrary +-- coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a + +instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where + arbitrary = liftA2 Stepper arbitrary arbitrary + +instance (CoArbitrary t, CoArbitrary a) => CoArbitrary (ReactiveG t a) where + coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a + +instance (Ord t, Bounded t) => Model (ReactiveG t a) (t -> a) where + model = rat + +instance (Ord t, Bounded t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a) + where + (=-=) = (=-=) `on` model + +-- Initial value of a 'Reactive' +rInit :: ReactiveG t a -> a +rInit (a `Stepper` _) = a + + +{-------------------------------------------------------------------- + Instances +--------------------------------------------------------------------} + +instance (Ord t, Bounded t) => Monoid (EventG t a) where + mempty = Event mempty + mappend = inEvent2 merge + +-- Standard instance for Applicative of Monoid +instance (Ord t, Bounded t, Monoid a) => Monoid (ReactiveG t a) where + mempty = pure mempty + mappend = liftA2 mappend + +-- | Merge two 'Future' reactives into one. +merge :: (Ord t, Bounded t) => Binop (FutureG t (ReactiveG t a)) + +-- The following two lines seem to be too strict and are causing +-- reactive to lock up. I.e. the time argument of one of these +-- must have been _|_, so when we pattern match against it, we +-- block. +-- +-- On the other hand, they patch a massive space leak in filterE. Perhaps +-- there's an unamb solution. + +u `merge` v = + assuming (isNeverF u) v `unamb` + assuming (isNeverF v) u `unamb` + (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) + +-- TODO: redefine via parIdentity from Data.Unamb + +-- u `merge` v | isNever u = v +-- | isNever v = u + +-- Future (Max MaxBound,_) `merge` v = v +-- u `merge` Future (Max MaxBound,_) = u + +-- u `merge` v = +-- (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) + +-- What's going on in this 'merge' definition? Try two different +-- future paths. If u arrives before v (or simultaneously), then +-- begin as u begins and then merge v with the rest of u. Otherwise, +-- begin as v begins and then merge u with the rest of v. Because of +-- the left-bias, make sure u fragments are always the first argument +-- to merge and v fragments are always the second. + + +-- Define functor instances in terms of each other. +instance Functor (EventG t) where + fmap = inEvent.fmap.fmap + +instance Functor (ReactiveG t) where + fmap f ~(a `Stepper` e) = f a `stepper` fmap f e + +-- standard instance +instance (Ord t, Bounded t) => Applicative (EventG t) where + pure = return + (<*>) = ap +-- _ <*> (Event (Future (Max MaxBound,_))) = mempty +-- x <*> y = x `ap` y + +-- standard instance +instance (Ord t, Bounded t) => Alternative (EventG t) where + { empty = mempty; (<|>) = mappend } + +instance (Ord t, Bounded t) => Zip (ReactiveG t) where + -- zip :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b) + (c `Stepper` ce) `zip` (d `Stepper` de) = + (c,d) `accumR` pairEdit (ce,de) + +instance (Ord t, Bounded t) => Applicative (ReactiveG t) where + pure a = a `stepper` mempty + -- Standard definition. See 'Zip'. + rf <*> rx = zipWith ($) rf rx + +-- A wonderful thing about the <*> definition for ReactiveG is that it +-- automatically caches the previous value of the function or argument +-- when the argument or function changes. + + +instance (Ord t, Bounded t) => Monad (EventG t) where + return a = Event (pure (pure a)) + e >>= f = joinE (fmap f e) + + +-- From Jules Bean (quicksilver): + +-- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a +-- joinE (Event u) = +-- Event . join $ +-- fmap (\ (e `Stepper` ee) -> +-- let (Event uu) = (e `mappend` joinE ee) in uu) +-- u + +-- plus some fiddling: + +joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a + +joinE (Event u) = Event (u >>= eFuture . g) + where + g (e `Stepper` ee) = e `mappend` joinE ee + +-- joinE = inEvent (>>= eFuture . g) +-- where +-- g (e `Stepper` ee) = e `mappend` joinE ee + + +-- | Experimental specialization of 'joinMaybes'. +justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a +justE ~(Event (Future (t, mb `Stepper` e'))) = + assuming (t == maxBound) mempty `unamb` + (inEvent.inFuture.first) (max t) $ + case mb of + Nothing -> justE e' + Just a -> Event (Future (t, a `Stepper` justE e')) + + +-- This definition is much more efficient than the following. + +-- justE = (>>= maybe mzero return) + +-- On the other hand, this simpler definition inserts the necessary max +-- applications so that we needn't find a Just in order to have a lower bound. + +-- TODO: find and fix the inefficiency. + + + + + +-- | Experimental specialization of 'filterMP'. +filterE :: (Ord t, Bounded t) => (a -> Bool) -> EventG t a -> EventG t a +filterE p m = justE (liftM f m) + where + f a | p a = Just a + | otherwise = Nothing + + +{- + +-- happy a t b. Same as (a `mappend` b) except takes advantage of knowledge +-- that t is a lower bound for the occurences of b. This allows for extra +-- laziness. +happy :: (Ord t) => EventG t a -> + Time t -> + EventG t a -> + EventG t a +happy a t b = + assuming (isNeverE a) b `unamb` + assuming (isNeverF b) a `unamb` + happy' a t b ... + + +happy a (Max MaxBound) _ = a +happy (Event (Future (Max MaxBound, _))) _ b = b +happy a@(Event (Future (t0, e `Stepper` ee'))) t b + | t0 <= t = (Event (Future (t0, e `Stepper` (happy ee' t b)))) + | otherwise = a `mappend` b + +-- Note, joinE should not be called with an infinite list of events that all +-- occur at the same time. It can't decide which occurs first. +joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a +joinE (Event (Future (Max MaxBound, _))) = mempty +joinE (Event (Future (t0h, e `Stepper` ((Event (Future (Max MaxBound, _))))))) + = adjustE t0h e +joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _))))))) + = happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee')) +-} + +{- +-- Note, joinE should not be called with an infinite list of events that all +-- occur at the same time. It can't decide which occurs first. +joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a +joinE (Event (Future (t0h, e `Stepper` ee'))) = + assuming (t0h == maxBound) mempty $ + adjustE t0h (e `mappend` joinE ee') + +-- TODO: revisit this def. + + +-- Original Version: +-- joinE (Event (Future (t0h, e `Stepper` ee'))) = +-- adjustE t0h e `mappend` adjustTopE t0h (joinE ee') + +adjustTopE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1 + +-- adjustTopE t0h = (inEvent.inFuture.first) (max t0h) + +adjustTopE t0h ~(Event (Future (tah, r))) = + Event (Future (t0h `max` tah,r)) + +adjustE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1 + +adjustE _ e@(Event (Future (Max MaxBound, _))) = e + +adjustE t0h (Event (Future (tah, a `Stepper` e))) = + Event (Future (t1h,a `Stepper` adjustE t1h e)) + where + t1h = t0h `max` tah + +-} + +-- The two-caseness of adjustE prevents the any info from coming out until +-- tah is known to be Max or non-Max. Problem? + +-- Is the MaxBound case really necessary? + +-- TODO: add adjustE explanation. What's going on and why t1 in the +-- recursive call? David's comment: +-- If we have an event [t1, t2] we know t2 >= t1 so (max t t2) == (max (max t t1) t2). +-- See http://hpaste.org/11518 for a def that doesn't change the lower bound. +-- +-- What I remember is that this function is quite subtle w.r.t laziness. +-- There are some notes in the paper. If i find instead that a simpler +-- definition is possible, so much the better. + +-- Here's an alternative to joinE that is less strict, and doesn't cause +-- reactive to lock up. Need to verify correctness. (Does lock up with +-- the mappend optimization that eliminates a space/time leak.) +{- +joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a +joinE (Event (Future (t0h, ~(e `Stepper` ee')))) = + adjustE t0h (e `mappend` joinE ee') + +adjustE t0h (Event (Future (tah, ~(a `Stepper` e)))) = + Event (Future (t1h,a `Stepper` adjustE t1h e)) + where + t1h = t0h `max` tah +-} + + +-- These two joinE defs both lock up in my tests. + + +instance (Ord t, Bounded t) => MonadPlus (EventG t) where + { mzero = mempty; mplus = mappend } + +-- Standard instance for Applicative w/ join +instance (Ord t, Bounded t) => Monad (ReactiveG t) where + return = pure + r >>= f = joinR (f <$> r) + + +-- -- Temporary +-- justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a +-- justE = joinMaybes + +-- filterE :: (Ord t, Bounded t, Show a) => (a -> Bool) -> EventG t a -> EventG t a +-- filterE = filterMP + +{- + +-- | Pass through the 'Just' occurrences, stripped. Experimental +-- specialization of 'joinMaybes'. +justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a +justE (Event (Future (ta, Just a `Stepper` e'))) = + Event (Future (ta, a `Stepper` justE e')) +justE (Event (Future (ta, Nothing `Stepper` e'))) = + adjustE ta (justE e') + +-- The adjustE lets consumers know that the resulting event occurs no +-- earlier than ta. + +-- | Pass through values satisfying a given predicate. Experimental +-- specialization of 'filterMP'. +filterE :: (Ord t, Show a) => (a -> Bool) -> EventG t a -> EventG t a + +-- filterE p e = joinMaybes (f <$> e) +-- where +-- f a | p a = Just a +-- | otherwise = Nothing + +filterE _ e@(Event (Future (Max MaxBound, _))) = e + +filterE p (Event (Future (ta, a `Stepper` e'))) = + adjustTopE ta $ + if p a then + Event (Future (ta, a `Stepper` filterE p e')) + else filterE p e' +-} + +-- The adjustTopE ta guarantees a lower bound even before we've looked at a. + +-- filterE p (Event (Future (ta, a `Stepper` e'))) +-- | p a = Event (Future (ta, a `Stepper` filterE p e')) +-- | otherwise = adjustTopE ta (filterE p e') + +-- filterE p (Event (Future (ta, a `Stepper` e'))) = h (filterE p e') +-- where +-- h | p a = -- trace ("pass " ++ show a) $ +-- \ e'' -> Event (Future (ta, a `Stepper` e'')) +-- | otherwise = -- trace ("skip " ++ show a) $ +-- adjustTopE ta + +-- Or maybe move the adjustTopE to the second filterE + +-- adjustTopE t0h = (inEvent.inFuture.first) (max t0h) + + +-- Laziness problem: no information at all can come out of filterE's +-- result until @p a@ is known. + +-- filterE p ~(Event (Future (ta, a `Stepper` e'))) = +-- Event (Future (ta', r')) +-- where +-- ta' +-- +-- if p a then +-- Event (Future (ta, a `Stepper` filterE p e')) +-- else +-- adjustE ta (filterE p e') + + +{-------------------------------------------------------------------- + Operations on events and reactive values +--------------------------------------------------------------------} + +-- | Reactive value from an initial value and a new-value event. +stepper :: a -> EventG t a -> ReactiveG t a +stepper = Stepper + +-- -- | Turn a reactive value into an event, with the initial value +-- -- occurring at -Infinity. +-- -- +-- -- Oops: breaks the semantic abstraction of 'Reactive' as a step +-- function. +-- rToE :: (Ord t, Bounded t) => ReactiveG t a -> EventG t a +-- rToE (a `Stepper` e) = pure a `mappend` e + +-- | Switch between reactive values. +switcher :: (Ord t, Bounded t) => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a +r `switcher` e = join (r `stepper` e) + +-- | Reactive 'join' (equivalent to 'join' but slightly more efficient, I think) +joinR :: (Ord t, Bounded t) => ReactiveG t (ReactiveG t a) -> ReactiveG t a + +joinR ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u + where + u = ((`switcher` e') <$> ur) `mappend` (join <$> urr) + +-- The following simpler definition is wrong. It keeps listening to @e@ +-- even after @er@ has occurred. +-- joinR ((a `Stepper` e) `Stepper` er) = +-- a `stepper` (e `mappend` join (rToE <$> er)) + +-- e :: EventG t a +-- er :: EventG t (ReactiveG t a) +-- +-- rToE <$> er ::: EventG t (EventG t a) +-- join (rToE <$> er) ::: EventG t a + + +-- | Access occurrence times in an event. See also 'withTimeGR'. +withTimeGE :: EventG t a -> EventG t (a, Time t) +withTimeGE = inEvent $ inFuture $ \ (t,r) -> (t, withTimeGR t r) + +-- | Access occurrence times in a reactive value. See also 'withTimeGE'. +withTimeGR :: Time t -> ReactiveG t a -> ReactiveG t (a, Time t) +withTimeGR t (a `Stepper` e) = (a,t) `Stepper` withTimeGE e + +-- | Convert a temporally monotonic list of futures to an event. See also +-- the specialization 'listE' +listEG :: (Ord t, Bounded t) => [(t,a)] -> EventG t a +listEG = futuresE . map (uncurry future) + +-- | Convert a temporally monotonic list of futures to an event +futuresE :: (Ord t, Bounded t) => [FutureG t a] -> EventG t a +futuresE [] = mempty +futuresE (Future (t,a) : futs) = + -- trace ("l2E: "++show t) $ + Event (Future (t, a `stepper` futuresE futs)) + +-- TODO: redefine 'futuresE' as a fold +-- futuresE = foldr (\ fut e -> Event ((`stepper` e) <$> fut)) mempty + +-- TODO: hide futuresE. currently exported for use in TVal. If I move to +-- Internal/Reactive, I have to move the monoid instance there, which +-- requires moving others as well. + +-- | Convert a temporally monotonic stream of futures to an event. Like +-- 'futuresE' but it can be lazier, because there's not empty case. +futureStreamE :: (Ord t, Bounded t) => Stream (FutureG t a) -> EventG t a +futureStreamE (~(Cons (Future (t,a)) futs)) = + Event (Future (t, a `stepper` futureStreamE futs)) + +-- | Event at given times. See also 'atTimeG'. +atTimesG :: (Ord t, Bounded t) => [t] -> EventG t () +atTimesG = listEG . fmap (flip (,) ()) + +-- | Single-occurrence event at given time. +atTimeG :: (Ord t, Bounded t) => t -> EventG t () +atTimeG = atTimesG . pure + +-- | Snapshot a reactive value whenever an event occurs and apply a +-- combining function to the event and reactive's values. +snapshotWith :: (Ord t, Bounded t) => + (a -> b -> c) -> ReactiveG t b -> EventG t a -> EventG t c + +-- snapshotWith f e r = joinMaybes $ fmap h (e `snap` r) +-- where +-- h (Nothing,_) = Nothing +-- h (Just a ,b) = Just (f a b) + +-- -- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@ +-- -- didn't. +-- snap :: forall a b t. (Ord t, Bounded t) => +-- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b) +-- (b0 `Stepper` eb) `snap` ea = +-- assuming (isNeverE ea) mempty $ +-- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb) +-- where +-- fa :: a -> Unop (Maybe a, b) +-- fb :: b -> Unop (Maybe a, b) +-- fa a (_,b) = (Just a , b) +-- fb b _ = (Nothing, b) + +-- This next version from Chuan-kai Lin, so that snapshot is lazy enough +-- for recursive cases. It leaks when the reactive changes faster than +-- the event occurs. + +snapshotWith f r e = + fmap snap $ accumE seed $ fmap advance $ withTimeGE e + where snap (a, sr) = f a (rInit sr) + seed = (error "snapshotWith seed", r) + advance (a, t) (_, sr) = (a, skipRT sr t) + +-- | Skip reactive values until the given time. +skipRT :: (Ord t, Bounded t) => ReactiveG t a -> Time t -> ReactiveG t a +r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start = + if t < start then r1 `skipRT` start else r + +-- From Beelsebob: + +-- snapshotWith f r e@(Event (Future (t,_ `Stepper` ne))) = +-- Event (Future (t, v' `stepper` snapshotWith f r ne)) +-- where +-- Event (Future (_,v' `Stepper` _)) = snapshotWith' f r e +-- snapshotWith' f' r' e' = joinMaybes $ fmap h (r' `snap` e') +-- where +-- h (Nothing,_) = Nothing +-- h (Just a ,b) = Just (f' a b) + + + +-- | Accumulating event, starting from an initial value and a +-- update-function event. See also 'accumR'. +accumE :: a -> EventG t (a -> a) -> EventG t a +accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e' + +-- | Reactive value from an initial value and an updater event. See also +-- 'accumE'. +accumR :: a -> EventG t (a -> a) -> ReactiveG t a +a `accumR` e = a `stepper` (a `accumE` e) + +-- | Just the first occurrence of an event. +once :: (Ord t, Bounded t) => EventG t a -> EventG t a +once = (inEvent.fmap) (pure . rInit) + +-- | Extract a future representing the first occurrence of the event together +-- with the event of all occurrences after that one. +eventOcc :: (Ord t) => EventG t a -> FutureG t (a, EventG t a) +eventOcc (Event fut) = (\ (Stepper a e) -> (a,e)) <$> fut + + +-- | Access the remainder with each event occurrence. +withRestE :: EventG t a -> EventG t (a, EventG t a) +withRestE = (inEvent.fmap) $ + \ (a `Stepper` e') -> (a,e') `stepper` withRestE e' + + +-- | Truncate first event at first occurrence of second event. +untilE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t a +ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb + +-- | Truncate first event at the given time. +untilET :: (Ord t, Bounded t) => EventG t a -> Time t -> EventG t a + + +-- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t = +-- if ta < t then +-- Event (Future (ta, a `Stepper` (e' `untilET` t))) +-- else +-- mempty + +-- Hm. I doubt that the definition above gives sufficient temporal +-- laziness. No information can come out of the result until the value of +-- @ta < t@ is determined, which is usually at about time @ta `min` t@. + +-- So, try the following definition instead. It immediately provides +-- lower bounds of both @ta@ and @t@ as lower bounds of the constructed +-- event occurrences. + +Event (Future ~(ta, a `Stepper` e')) `untilET` t = + Event (Future (ta', a `Stepper` (e' `untilET` t))) + where + ta' = (ta `min` t) `max` (if ta < t then ta else maxBound) + +-- I'm not sure about @<@ vs @<=@ above. + + +-- | Sample a reactive value at a sequence of monotonically non-decreasing +-- times. Deprecated, because it does not reveal when value is known to +-- be repeated in the output. Those values won't be recomputed, but they +-- may be re-displayed. +rats :: (Ord t, Bounded t) => ReactiveG t a -> [t] -> [a] -- increasing times + +_ `rats` [] = [] + +r@(a `Stepper` Event (Future (tr',r'))) `rats` ts@(t:ts') + | ftime t <= tr' = a : r `rats` ts' + | otherwise = r' `rats` ts + +-- Just for testing +rat :: (Ord t, Bounded t) => ReactiveG t a -> t -> a +rat r = head . rats r . (:[]) + + +{-------------------------------------------------------------------- + Other instances +--------------------------------------------------------------------} + +-- Standard instances +instance (Monoid_f f, Ord t, Bounded t) => Monoid_f (ReactiveG t :. f) where + { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) } +instance (Ord t, Bounded t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip + +instance Unzip (ReactiveG t) where {fsts = fmap fst; snds = fmap snd} + +-- Standard instances +instance (Ord t, Bounded t) => Monoid_f (EventG t) where + { mempty_f = mempty ; mappend_f = mappend } +instance (Ord t, Bounded t) => Monoid ((EventG t :. f) a) where + { mempty = O mempty; mappend = inO2 mappend } +instance (Ord t, Bounded t) => Monoid_f (EventG t :. f) where + { mempty_f = mempty ; mappend_f = mappend } +instance (Ord t, Bounded t, Cozip f) => Zip (EventG t :. f) where + zip = cozip + +-- Standard instance for functors +instance Unzip (EventG t) where {fsts = fmap fst; snds = fmap snd} + + +{-------------------------------------------------------------------- + Comonadic stuff +--------------------------------------------------------------------} + +instance Copointed (EventG t) where + -- E a -> F (R a) -> R a -> a + extract = extract . extract . eFuture + +-- Here's the plan for 'duplicate': +-- +-- E a -> F (R a) -> F (R (R a)) -> F (F (R (R a))) +-- -> F (R (F (R a))) -> E (F (R a)) -> E (E a) + + +instance Monoid t => Comonad (EventG t) where + duplicate = + fmap Event . Event . fmap frTOrf . duplicate . fmap duplicate . eFuture + +-- This frTOrf definition type-checks. Is it what we want? +frTOrf :: FutureG t (ReactiveG t a) -> ReactiveG t (FutureG t a) +frTOrf ~(Future (ta,e)) = (Future . (,) ta) <$> e + +-- TODO: Reconsider E = F :. R . Didn't work with absolute time. What +-- about relative time? + +instance (Ord t, Bounded t) => Pointed (ReactiveG t) where + point = (`stepper` mempty) + +-- TODO: I think we can bypass mempty and so eliminate the Ord +-- constraint. If so, remove Ord tr from 'time' in Behavior. + +instance Copointed (ReactiveG t) where + -- extract = extract . rat + -- Semantically: extract == extract . rat == (`rat` mempty) But mempty + -- is the earliest time (since I'm using the Max monoid *), so here's a + -- cheap alternative that also doesn't require Ord t: + extract (a `Stepper` _) = a + +-- extract r == extract (rat r) == rat r mempty + +-- * Moreover, mempty is the earliest time in the Sum monoid on +-- non-negative values, for relative-time behaviors. + +instance Monoid t => Comonad (ReactiveG t) where + duplicate r@(_ `Stepper` Event u) = + r `Stepper` Event (duplicate <$> u) + +-- TODO: Prove the morphism law: +-- +-- fmap rat . rat . dup == dup . rat + +-- Reactive is like the stream comonad +-- TODO: try again letting events and reactives be streams of futures. + + +{-------------------------------------------------------------------- + To be moved elsewhere +--------------------------------------------------------------------} + +-- | Pass through @Just@ occurrences. +joinMaybes :: MonadPlus m => m (Maybe a) -> m a +joinMaybes = (>>= maybe mzero return) + +-- | Pass through values satisfying @p@. +filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a +filterMP p m = joinMaybes (liftM f m) + where + f a | p a = Just a + | otherwise = Nothing + +-- Alternatively: +-- filterMP p m = m >>= guarded p +-- where +-- guarded p x = guard (p x) >> return x + + +-- | Apply a given function inside the results of other functions. +-- Equivalent to '(.)', but has a nicer reading when composed +result :: (b -> b') -> ((a -> b) -> (a -> b')) +result = (.) + + +{-------------------------------------------------------------------- + Tests +--------------------------------------------------------------------} + +-- TODO: Define more types like ApTy, use in batch below. Move to checkers. +type ApTy f a b = f (a -> b) -> f a -> f b + +batch :: TestBatch +batch = ( "Reactive.PrimReactive" + , concatMap unbatch + [ + -- monad associativity fails + -- , monad (undefined :: EventG NumT (NumT,T,NumT)) + monoid (undefined :: EventG NumT T) + , monoid (undefined :: ReactiveG NumT [T]) + , monad (undefined :: ReactiveG NumT (NumT,T,NumT)) +-- , ("occurence count", +-- [("joinE", joinEOccuranceCount)] +-- ) + , ("monotonicity", + [ monotonicity2 "<*>" + ((<*>) :: ApTy (EventG NumT) T T) +{- + , monotonicity2 "adjustE" (adjustE + :: Time NumT + -> EventG NumT NumT + -> EventG NumT NumT) +-} + , monotonicity "join" (join + :: EventG NumT (EventG NumT T) + -> EventG NumT T) + , monotonicity "withTimeGE" (withTimeGE + :: EventG NumT T + -> EventG NumT (T, Time NumT)) + , monotonicity "once" (once + :: EventG NumT T + -> EventG NumT T) + , monotonicity2 "accumE" (accumE + :: T + -> EventG NumT (T -> T) + -> EventG NumT T) + , monotonicity2 "mappend" (mappend + :: EventG NumT T + -> EventG NumT T + -> EventG NumT T) + , monotonicity2 "mplus" (mplus + :: EventG NumT T + -> EventG NumT T + -> EventG NumT T) + , monotonicity2 "<|>" ((<|>) + :: EventG NumT T + -> EventG NumT T + -> EventG NumT T) + , monotonicity2 "fmap" (fmap + :: (T -> T) + -> EventG NumT T + -> EventG NumT T) +-- ,monotonicity2 "flip (>>=)" (flip (>>=)) +-- ,monotonicity2 (flip snapshot) "flip snapshot" + ]) + , ("order preservation", + [ simulEventOrder "once" (once + :: EventG NumT NumT + -> EventG NumT NumT) + ]) + ] + ) + +monoid_E :: TestBatch +monoid_E = monoid (undefined :: EventG NumT T) + + +-- joinEOccuranceCount :: Property +-- joinEOccuranceCount = +-- forAll (finiteEvent $ finiteEvent arbitrary +-- :: Gen (EventG NumT (EventG NumT T))) +-- ((==) <$> (sum . map (length . toListE_) . toListE_) +-- <*> (length . toListE_ . joinE)) + +{- +toListE :: EventG t a -> [FutureG t a] +toListE (Event (Future (Max MaxBound, _ ))) = [] +toListE (Event (Future (t0 , v `Stepper` e'))) = Future (t0,v) : toListE e' + +toListE_ :: EventG t a -> [a] +toListE_ = map futVal . toListE +-} + +monotonicity :: (Show a, Arbitrary a, Arbitrary t + ,Num t, Ord t, Bounded t, Ord t', Bounded t') + => String -> (EventG t a -> EventG t' a') + -> (String,Property) +monotonicity n f = (n, property $ monotoneTest f) + +monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t + ,Num t, Ord t, Bounded t, Ord t', Bounded t') + => String -> (b -> EventG t a -> EventG t' a') + -> (String,Property) +monotonicity2 n f = (n, property $ monotoneTest2 f) + +monotoneTest :: (Ord t', Bounded t') => + (EventG t a -> EventG t' a') + -> EventG t a + -> Bool +monotoneTest f e = unsafePerformIO ( (evaluate (isMonotoneE . f $ e)) + `race` slowTrue) + +monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t + ,Num t, Ord t, Bounded t, Ord t', Bounded t') + => (b -> EventG t a -> EventG t' a') + -> (b , EventG t a) -> Bool +monotoneTest2 f (x,e) = + unsafePerformIO ( (evaluate (isMonotoneE (x `f` e))) + `race` slowTrue) + +slowTrue :: IO Bool +slowTrue = do threadDelay 10 + return True + +-- TODO: Replace this stuff with a use of delay from Data.Later in checkers. + + +isMonotoneE :: (Ord t, Bounded t) => EventG t a -> Bool +isMonotoneE = liftA2 (||) isNeverE + ((uncurry isMonotoneR') . unFuture . eFuture) + +isMonotoneE' :: (Ord t, Bounded t) => (Time t) -> EventG t a -> Bool +isMonotoneE' t = + liftA2 (||) isNeverE + ((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture) + +isMonotoneR :: (Ord t, Bounded t) => ReactiveG t a -> Bool +isMonotoneR (_ `Stepper` e) = isMonotoneE e + +isMonotoneR' :: (Ord t, Bounded t) => Time t -> ReactiveG t a -> Bool +isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e + +simulEventOrder :: ( Arbitrary t, Num t, Ord t, Bounded t + , Arbitrary t', Num t', Ord t', Bounded t' + , Num t'', Ord t'', Bounded t'' + , Num t''', Ord t''', Bounded t''') + => String -> (EventG t t' -> EventG t'' t''') + -> (String, Property) +simulEventOrder n f = + (n,forAll genEvent (isStillOrderedE . f)) + where + genEvent :: ( Arbitrary t1, Num t1, Ord t1, Bounded t1 + , Arbitrary t2, Num t2, Ord t2, Bounded t2) + => Gen (EventG t1 t2) + genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing + increasing) + isStillOrderedE :: ( Num t1, Ord t1, Bounded t1 + , Num t2, Ord t2, Bounded t2) => EventG t1 t2 -> Bool + isStillOrderedE = + liftA2 (||) isNeverE + (isStillOrderedR . futVal . eFuture) + + isStillOrderedR (a `Stepper` e) = + isStillOrderedE' a e + + isStillOrderedE' a = + liftA2 (||) isNeverE + (isStillOrderedR' a . futVal . eFuture) + + isStillOrderedR' a (b `Stepper` e) = + a < b && isStillOrderedE' b e + +-- An infinite event. handy for testing. +infE :: EventG NumT NumT +infE = futuresE (zipWith future [1..] [1..]) + diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Reactive.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, TypeOperators + , FlexibleInstances, TypeFamilies + #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : FRP.Reactive.Reactive +-- Copyright : (c) Conal Elliott 2008 +-- License : GNU AGPLv3 (see COPYING) +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Simple reactive values. Adds some extra functionality on top of +-- "FRP.Reactive.PrimReactive" +---------------------------------------------------------------------- + +module FRP.Reactive.Reactive + ( + module FRP.Reactive.PrimReactive + , ImpBounds, exactNB, {-TimeFinite,-} TimeT, ITime, Future + , traceF + -- * Event + , Event + , withTimeE, withTimeE_ + , atTime, atTimes, listE + , {-mbsEvent,-} zipE, scanlE, monoidE + , firstRestE, firstE, restE + , remainderR, snapRemainderE, onceRestE + , withPrevE, withPrevEWith, withNextE, withNextEWith + , mealy, mealy_, countE, countE_, diffE + -- * Reactive values + , Reactive + , snapshot_, snapshot, whenE + , scanlR, monoidR, eitherE, maybeR, flipFlop, countR + , splitE, switchE + , integral, sumR + -- * Re-export + , exact + -- * Tests + , batch + ) where + +import Control.Applicative +import Control.Arrow (first,second) +import Control.Monad +import Data.Monoid +import Debug.Trace (trace) + +-- import Test.QuickCheck +import Test.QuickCheck.Checkers +import Test.QuickCheck.Classes () + +-- vector-space +import Data.VectorSpace +import Data.AffineSpace + +-- TypeCompose +import Data.Zip (pairEdit) + +import Data.Max +import Data.AddBounds +import FRP.Reactive.Future hiding (batch) +import FRP.Reactive.PrimReactive hiding (batch) +import FRP.Reactive.Improving hiding (batch) + +-- -- | The type of finite time values +-- type TimeFinite = Double + +-- | The type of time values with additional min & max elements. +type TimeT = Double +-- type TimeT = AddBounds TimeFinite + +type ImpBounds t = Improving (AddBounds t) + +-- | Exact & finite content of an 'ImpBounds' +exactNB :: ImpBounds t -> t +exactNB = unNo . exact + where + unNo (NoBound t) = t + unNo _ = error "exactNB: unNo on MinBound or maxBound" + +-- TODO: when I switch to relative time, I won't need MinBound, so +-- introduce a HasInfinity class and use infinity in place of maxBound + +-- | Improving times, as used for time values in 'Event', 'Reactive', +-- and 'ReactiveB'. +type ITime = ImpBounds TimeT + +-- type ITime = Improving TimeT + +-- | Type of future values. Specializes 'FutureG'. +type Future = FutureG ITime + +-- -- | Sink, e.g., for an event handler +-- type Sink a = SinkG Time a + + +-- | Trace the elements of a functor type. +traceF :: Functor f => (a -> String) -> f a -> f a +traceF shw = fmap (\ a -> trace (shw a) a) + +-- traceShowF :: (Functor f,Show a) => f a -> f a +-- traceShowF = traceF show + + +{-------------------------------------------------------------------- + Events +--------------------------------------------------------------------} + +-- | Events, specialized to improving doubles for time +type Event = EventG ITime + +-- | Access occurrence times in an event. See 'withTimeGE' for more +-- general notions of time. +-- +-- > withTimeE :: Event a -> Event (a, TimeT) +withTimeE :: Ord t => + EventG (ImpBounds t) d -> EventG (ImpBounds t) (d, t) +withTimeE e = second (exactNB.timeT) <$> withTimeGE e + +-- | Access occurrence times in an event. Discard the rest. See also +-- 'withTimeE'. +-- +-- > withTimeE_ :: Event a -> Event TimeT +withTimeE_ :: Ord t => + EventG (ImpBounds t) d -> EventG (ImpBounds t) t +withTimeE_ = (result.fmap) snd withTimeE + +timeT :: Ord t => Time t -> t +timeT (Max t) = t + +-- timeT (Max (NoBound t)) = t +-- timeT _ = error "timeT: non-finite time" + +-- | Single-occurrence event at given time. See 'atTimes' and 'atTimeG'. +atTime :: TimeT -> Event () +atTime = atTimes . pure + +-- atTime = atTimeG . exactly . NoBound + +-- | Event occuring at given times. See also 'atTime' and 'atTimeG'. +atTimes :: [TimeT] -> Event () +atTimes = atTimesG . fmap (exactly . NoBound) + + +-- | Convert a temporally monotonic list of timed values to an event. See also +-- the generalization 'listEG' +listE :: [(TimeT,a)] -> Event a +listE = listEG . fmap (first (exactly . NoBound)) + +-- | Generate a pair-valued event, given a pair of initial values and a +-- pair of events. See also 'pair' on 'Reactive'. Not quite a 'zip', +-- because of the initial pair required. +zipE :: (Ord t, Bounded t) => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d) +zipE cd cde = cd `accumE` pairEdit cde + +-- | Like 'scanl' for events. +scanlE :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> EventG t a +scanlE f a e = a `accumE` (flip f <$> e) + +-- | Accumulate values from a monoid-typed event. Specialization of +-- 'scanlE', using 'mappend' and 'mempty'. +monoidE :: (Ord t, Bounded t, Monoid o) => EventG t o -> EventG t o +monoidE = scanlE mappend mempty + + + +-- | Decompose an event into its first occurrence value and a remainder +-- event. See also 'firstE' and 'restE'. +firstRestE :: (Ord t, Bounded t) => EventG t a -> (a, EventG t a) +firstRestE = futVal . eventOcc + +-- | Extract the first occurrence value of an event. See also +-- 'firstRestE' and 'restE'. +firstE :: (Ord t, Bounded t) => EventG t a -> a +firstE = fst . firstRestE + +-- | Extract the remainder an event, after its first occurrence. See also +-- 'firstRestE' and 'firstE'. +restE :: (Ord t, Bounded t) => EventG t a -> EventG t a +restE = snd . firstRestE + + + +-- | Remaining part of an event. See also 'withRestE'. +remainderR :: (Ord t, Bounded t) => EventG t a -> ReactiveG t (EventG t a) +remainderR e = e `stepper` (snd <$> withRestE e) + + +-- | Tack remainders a second event onto values of a first event. Occurs +-- when the first event occurs. +snapRemainderE :: (Ord t, Bounded t) => + EventG t b -> EventG t a -> EventG t (a, EventG t b) +snapRemainderE = snapshot . remainderR + +-- snapRemainderE eb = snapshot (remainderR eb) + +-- eb `snapRemainderE` ea = remainderR eb `snapshot` ea + +-- withTailE ea eb = error "withTailE: undefined" ea eb + + +-- | Convert an event into a single-occurrence event, whose occurrence +-- contains the remainder. +onceRestE :: (Ord t, Bounded t) => EventG t a -> EventG t (a, EventG t a) +onceRestE = once . withRestE + + + +-- | Pair each event value with the previous one. The second result is +-- the old one. Nothing will come out for the first occurrence of @e@, +-- but if you have an initial value @a@, you can do @withPrevE (pure a +-- `mappend` e)@. +withPrevE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a) +withPrevE e = (joinMaybes . fmap combineMaybes) $ + (Nothing,Nothing) `accumE` fmap (shift.Just) e + where + -- Shift newer value into (new,old) pair if present. + shift :: u -> (u,u) -> (u,u) + shift newer (new,_) = (newer,new) + combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v) + combineMaybes = uncurry (liftA2 (,)) + + +-- | Same as 'withPrevE', but allow a function to combine the values. +-- Provided for convenience. +withPrevEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b +withPrevEWith f e = fmap (uncurry f) (withPrevE e) + + +-- | Pair each event value with the next one one. The second result is +-- the next one. +withNextE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a) +withNextE = (result.fmap.second) firstE withRestE +-- Alt. def. +-- withNextE = fmap (second firstE) . withRestE + +-- | Same as 'withNextE', but allow a function to combine the values. +-- Provided for convenience. +withNextEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b +withNextEWith f e = fmap (uncurry f) (withNextE e) + + +-- | Mealy-style state machine, given initial value and transition +-- function. Carries along event data. See also 'mealy_'. +mealy :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t (b,s) +mealy s0 f = scanlE h (b0,s0) + where + b0 = error "mealy: no initial value" + h (_,s) b = (b, f s) + +-- | Mealy-style state machine, given initial value and transition +-- function. Forgetful version of 'mealy'. +mealy_ :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t s +mealy_ = (result.result.result.fmap) snd mealy + +-- mealy_ s0 f e = snd <$> mealy s0 f e + + +-- | Count occurrences of an event, remembering the occurrence values. +-- See also 'countE_'. +countE :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t (b,n) +countE = mealy 0 (+1) + +-- | Count occurrences of an event, forgetting the occurrence values. See +-- also 'countE'. +countE_ :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t n +countE_ = (result.fmap) snd countE + +-- countE_ e = snd <$> countE e + +-- | Difference of successive event occurrences. See 'withPrevE' for a +-- trick to supply an initial previous value. +diffE :: (Ord t, Bounded t, AffineSpace a) => + EventG t a -> EventG t (Diff a) +diffE = withPrevEWith (.-.) + +-- -- | Returns an event whose occurrence's value corresponds with the input +-- -- event's previous occurence's value. +-- delayE :: Event a -> Event a +-- delayE = withPrevEWith (flip const) + +-- I suspect that delayE will only be used to hide implementation +-- problems, so I removed it. - Conal + +{-------------------------------------------------------------------- + Reactive extras (defined via primitives) +--------------------------------------------------------------------} + +-- | Reactive values, specialized to improving doubles for time +type Reactive = ReactiveG ITime + +-- -- | Compatibility synonym (for ease of transition from DataDriven) +-- type Source = Reactive + + +-- | Snapshot a reactive value whenever an event occurs. +snapshot :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t (a,b) +snapshot = snapshotWith (,) + +-- | Like 'snapshot' but discarding event data (often @a@ is '()'). +snapshot_ :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t b +snapshot_ = snapshotWith (flip const) + +-- Alternative implementations +-- e `snapshot_` src = snd <$> (e `snapshot` src) +-- snapshot_ = (result.result.fmap) snd snapshot + +-- | Filter an event according to whether a reactive boolean is true. +whenE :: (Ord t, Bounded t) => EventG t a -> ReactiveG t Bool -> EventG t a +whenE e = joinMaybes . fmap h . flip snapshot e + where + h (a,True) = Just a + h (_,False) = Nothing + +-- | Like 'scanl' for reactive values. See also 'scanlE'. +scanlR :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a +scanlR f a e = a `stepper` scanlE f a e + +-- | Accumulate values from a monoid-valued event. Specialization of +-- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'. +monoidR :: (Ord t, Bounded t, Monoid a) => EventG t a -> ReactiveG t a +monoidR = scanlR mappend mempty + +-- Equivalently, +-- monoidR = stepper mempty . monoidE + +-- | Combine two events into one. +eitherE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t (Either a b) +eitherE ea eb = ((Left <$> ea) `mappend` (Right <$> eb)) + +-- | Start out blank ('Nothing'), latching onto each new @a@, and blanking +-- on each @b@. If you just want to latch and not blank, then use +-- 'mempty' for @lose@. +maybeR :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t (Maybe a) +maybeR get lose = + Nothing `stepper` ((Just <$> get) `mappend` (Nothing <$ lose)) + +-- | Flip-flopping reactive value. Turns true when @ea@ occurs and false +-- when @eb@ occurs. +flipFlop :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t Bool +flipFlop ea eb = + False `stepper` ((True <$ ea) `mappend` (False <$ eb)) + +-- TODO: redefine maybeR and flipFlop in terms of eitherE. + +-- | Count occurrences of an event. See also 'countE'. +countR :: (Ord t, Bounded t, Num n) => EventG t a -> ReactiveG t n +countR e = 0 `stepper` countE_ e + +-- | Partition an event into segments. +splitE :: (Ord t, Bounded t) => EventG t b -> EventG t a -> EventG t (a, EventG t b) +eb `splitE` ea = h <$> (eb `snapRemainderE` withRestE ea) + where + h ((a,ea'),eb') = (a, eb' `untilE` ea') + +-- | Switch from one event to another, as they occur. (Doesn't merge, as +-- 'join' does.) +switchE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a +switchE = join . fmap (uncurry untilE) . withRestE + + +-- | Euler integral. +integral :: forall v t. (VectorSpace v, AffineSpace t, Scalar v ~ Diff t) => + t -> Event t -> Reactive v -> Reactive v +integral t0 newT r = sumR (snapshotWith (*^) r deltaT) + where + deltaT :: Event (Diff t) + deltaT = diffE (pure t0 `mappend` newT) + +-- TODO: find out whether this integral works recursively. If not, then +-- fix the implementation, rather than changing the semantics. (No +-- "delayed integral".) + +sumR :: (Ord t, Bounded t) => AdditiveGroup v => EventG t v -> ReactiveG t v +sumR = scanlR (^+^) zeroV + + +{---------------------------------------------------------- + Tests +----------------------------------------------------------} + +batch :: TestBatch +batch = ( "FRP.Reactive.Reactive" + , concatMap unbatch + [ + -- Write some tests! + ] + ) diff --git a/src/FRP/Reactive/SImproving.hs b/src/FRP/Reactive/SImproving.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/SImproving.hs @@ -0,0 +1,173 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.SImproving +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy +-- in an Abstract Data Type with Deterministic Semantics\". +-- +-- This implementation is simple but not efficient, as it accumulates lots +-- of lower bounds. +---------------------------------------------------------------------- + +module Reactive.SImproving + ( + Improving(..), exactly, exact, improveMbs + -- * Misc speculation tools + , spec, specNY, specYY, start + ) where + +import Data.Function (on) +-- import Debug.Trace + +import Control.Parallel (par) + +-- | Progressive information about a value (e.g., a time). Represented as +-- a non-empty list of monotonically non-decreasing values. The last one +-- is the actual value. (The operations here ensure that the values are +-- strictly increasing, but they only rely on non-decreasing.) +newtype Improving a = Imp { unImp :: [a] } deriving Show + +-- | Apply a unary function inside an 'Improving' representation. +inImp :: ([a] -> [b]) -> (Improving a -> Improving b) +inImp f = Imp . f . unImp + +-- | Apply a unary function inside an 'Improving' representation. +inImp2 :: ([a] -> [b] -> [c]) -> (Improving a -> Improving b -> Improving c) +inImp2 f = inImp . f . unImp + +-- | A known improving value (which doesn't really improve) +exactly :: Ord a => a -> Improving a +exactly = Imp . (:[]) + +-- | Extract an exact value from an improving value +exact :: Improving a -> a +exact = last . unImp + +instance Eq a => Eq (Improving a) where + (==) = (==) `on` exact + +instance Ord a => Ord (Improving a) where + Imp xs `compare` Imp ys = -- trace "Improving: compare" $ + xs `compares` ys + -- experimental. probably eliminate. + Imp xs <= Imp ys = xs `leq` ys + min = inImp2 shortMerge + max = inImp2 (specNY monotonicAppend) + +-- This one wasn't in the Improving Values papers. Here so that +-- 'compare', '(<=)', etc are defined on Improving. +compares :: Ord a => [a] -> [a] -> Ordering +compares [] _ = error "compares: emptied first argument" +compares _ [] = error "compares: emptied second argument" +compares [x] (y:_) | x < y = LT +compares (x:_) [y] | x > y = GT +compares [x] [y] = compare x y +-- we know x >= y and length ys >= 2 +compares xs@[_] (_:ys') = compares xs ys' +-- we know x <= y and length xs >= 2 +compares (_:xs') ys@[_] = compares xs' ys +-- neither list is down to last element. progress where less is known. +compares xs@(x:xs') ys@(y:ys') | x == y = compares xs' ys' + | x < y = compares xs' ys + | otherwise = compares xs ys' + +-- Hm! The test I really want is (<=), which can get an answer based on +-- slightly less information than compares. + +leq :: Ord a => [a] -> [a] -> Bool +leq [] _ = error "leq: emptied first argument" +leq _ [] = error "leq: emptied second argument" +leq [x] (y:_) | x <= y = True +leq (x:_) [y] | x > y = False +leq [x] [y] = x <= y +-- we know x > y and length ys >= 2 +leq xs@[_] (_:ys') = leq xs ys' +-- we know x <= y and length xs >= 2 +leq (_:xs') ys@[_] = leq xs' ys +-- neither list is down to last element. progress where less is known. +leq xs@(x:xs') ys@(y:ys') | x == y = leq xs' ys' + | x < y = leq xs' ys + | otherwise = leq xs ys' + +-- leq didn't fix the bug I'm finding in phooey (src/Examples/Monad, t5) +-- when using SReactive instead of PrimReactive in Data/Reactive. +-- Probably remove leq later. + + +shortMerge :: Ord a => [a] -> [a] -> [a] +shortMerge [] _ = [] +shortMerge _ [] = [] +shortMerge xs@(x:xs') ys@(y:ys') + | x == y = x : shortMerge xs' ys' + | x < y = x : shortMerge xs' ys + | otherwise = y : shortMerge xs ys' + +monotonicAppend :: Ord a => [a] -> [a] -> [a] +-- monotonicAppend [x] ys = x : dropWhile (<= x) ys +-- monotonicAppend (x:xs') ys = x : monotonicAppend xs' ys +-- monotonicAppend [] _ = error "monotonicAppend: empty list" + +-- From "Encapsulating nondeterminacy in an abstract data type with +-- deterministic semantics" +monotonicAppend xs ys = xs ++ dropWhile (<= last xs) ys + + +-- TODO: consider trimming ys as we go, rather than later. However, I +-- have a fuzzy understanding of why spec_max and not just max in the +-- papers. + +-- | Interpret 'Nothing' values as lower bounds +improveMbs :: [(t, Maybe a)] -> [(Improving t, a)] +improveMbs = foldr f [] + where + f (t,Just a ) qs = (Imp [t],a) : qs + f (t,Nothing) ~((Imp ts', a) : qs') = (Imp (t:ts'), a) : qs' + -- f (_,Nothing) [] = error "improveMbs: input ends in a Nothing" + +-- The lazy pattern (~) above is essential for laziness. It also +-- complicates giving an error message if the input ends in a Nothing. + +-- improveMbs [] = [] +-- improveMbs ((t,Just a ) : ps') = (Imp [{-tr True-} t],a) : improveMbs ps' +-- improveMbs ((t,Nothing) : ps') = (Imp ({-tr False-} t:ts'), a) : qs' +-- where +-- (Imp ts', a) : qs' = improveMbs ps' + +-- tr :: (Show x, Show t) => x -> t -> t +-- tr x t = t +-- -- trace (show (t, x)) t + +-- improveMbs = foldr f [] +-- where +-- f (t,Just a ) qs = (Imp [t],a) : qs +-- f (t,Nothing) qs = +-- case qs of ((Imp ts', a) : qs') -> (Imp (t:ts'), a) : qs' +-- [] -> error "improveMbs: input ends in a Nothing" + +-- TODO: re-think the case of input ending in a Nothing. + + +---- Misc + +spec :: (a -> b) -> (a -> b) +spec f a = a `par` f a + +specNY :: (a -> b -> c) -> (a -> b -> c) +specNY f a = spec (f a) + +specYY :: (a -> b -> c) -> (a -> b -> c) +specYY f a = spec (spec f a) + +start :: [a] -> [a] +start [] = [] +start (x:xs) = specYY (:) x (start xs) + +-- Hm. Does this specNY really do anything? How far does 'par' evaluate? +-- Probably to WHNF, which wouldn't help much, would it? And I don't +-- understand the point yet. Read further in the paper. diff --git a/src/FRP/Reactive/Sorted.hs b/src/FRP/Reactive/Sorted.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/Sorted.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -Wall #-} + +---------------------------------------------------------------------- +-- | +-- Module : Data.Sorted +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Sorted lists: experimental (unused) +---------------------------------------------------------------------- + +module Reactive.Sorted where + +import Data.Monoid +import Data.List (sort) +import Control.Applicative +import Control.Monad + +newtype Sorted a = Sort { unSort :: [a] } -- non-decreasing values + +-- | Apply a unary function within the event representation. +inSort :: ([a] -> [b]) -> (Sorted a -> Sorted b) +inSort f = Sort . f . unSort + +-- | Apply a binary function within the event representation. +inSort2 :: ([a] -> [b] -> [c]) -> (Sorted a -> Sorted b -> Sorted c) +inSort2 f = inSort . f . unSort + + +instance Ord a => Monoid (Sorted a) where + mempty = Sort [] + mappend = inSort2 merge + +-- | Merge two ordered lists into an ordered list. +merge :: Ord a => [a] -> [a] -> [a] +[] `merge` vs = vs +us `merge` [] = us +us@(u:us') `merge` vs@(v:vs') = + (u `min` v) : if u <= v then us' `merge` vs else us `merge` vs' + +-- Alternatively, +-- +-- us@(u:us') `merge` vs@(v:vs') = +-- if u <= v then +-- u : (us' `merge` vs ) +-- else +-- v : (us `merge` vs') +-- +-- The definition used instead is more productive. It produces a cons +-- cell immediately and can even produce partial information about @u +-- `min` v@ before it's known which is smaller. + +class FunctorOrd h where + fmapO :: (Ord a, Ord b) => (a -> b) -> h a -> h b + +class FunctorOrd h => ApplicativeOrd h where + pureO :: Ord a => a -> h a + (<*?>) :: (Ord a, Ord b) => h (a -> b) -> h a -> h b + +class MonadOrd h where + returnO :: Ord a => a -> h a + -- does joinO need Ord (h a) ? + joinO :: Ord a => h (h a) -> h a + +instance FunctorOrd Sorted where + fmapO f = inSort (sort . fmap f) + +instance ApplicativeOrd Sorted where + pureO a = Sort (pure a) + (<*?>) = inSort2 $ (fmap.fmap) sort (<*>) + +instance MonadOrd Sorted where + returnO = pureO + joinO = inSort $ sort . join . fmap unSort diff --git a/src/FRP/Reactive/VectorSpace.hs b/src/FRP/Reactive/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Reactive/VectorSpace.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances + , TypeFamilies + #-} + +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +module FRP.Reactive.VectorSpace( ) where + +import FRP.Reactive.Behavior +import Control.Applicative + +import Data.VectorSpace + +instance AdditiveGroup v => AdditiveGroup (Behavior v) where + zeroV = pure zeroV + (^+^) = liftA2 (^+^) + negateV = liftA negateV + +instance VectorSpace v => VectorSpace (Behavior v) where + type Scalar (Behavior v) = Scalar v + (*^) s = fmap (s *^) diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,3 @@ +-- Run tests. ghc --make Test.hs -o test -threaded ; ./test + +import Test.Reactive diff --git a/src/Test/Integ.hs b/src/Test/Integ.hs new file mode 100644 --- /dev/null +++ b/src/Test/Integ.hs @@ -0,0 +1,52 @@ +-- Simple test of recursive integrals, from Beelsebob + +import Control.Arrow (first) + +import Data.Max +import Data.AddBounds +import FRP.Reactive.Behavior +import FRP.Reactive.PrimReactive +import FRP.Reactive.Internal.Reactive +import FRP.Reactive.Internal.Behavior +import FRP.Reactive.Future +import FRP.Reactive +import FRP.Reactive.Improving + + +-- For ticker +import FRP.Reactive.Internal.Clock +import FRP.Reactive.Internal.TVal +import System.IO.Unsafe + + +tick = atTimes [0,0.01 .. 2] +it = integral tick + +ib = 1 + it ib :: Behavior Double +e' = atTimes [0,0.1 .. 1.1] + +-- [(0.0,1.0),(0.1,1.1046221254112045),(0.2,1.2081089504435316),(0.30000000000000004,1.3345038765672335),(0.4000000000000001,1.4741225085031893),(0.5000000000000001,1.6283483384592894),(0.6000000000000001,1.7987096025387035),(0.7000000000000001,1.9868944241538458),(0.8,2.1947675417764927),(0.9,2.424388786780674),(1.0,2.67803349447676),(1.1,2.7048138294215276)] + +i1 = occs (ib `snapshot_` e') + +itst b = occs (it b `snapshot_` e') + +occs :: Event a -> [(TimeT, a)] +occs = map (first (unNo . exact . getMax) . unFuture) . eFutures + where + unNo (NoBound a) = a + +-- [(0.0,0.0),(0.1,9.999999999999996e-2),(0.2,0.19),(0.30000000000000004,0.2900000000000001),(0.4000000000000001,0.3900000000000002),(0.5000000000000001,0.49000000000000027),(0.6000000000000001,0.5900000000000003),(0.7000000000000001,0.6900000000000004),(0.8,0.7900000000000005),(0.9,0.8900000000000006),(1.0,0.9900000000000007),(1.1,1.0000000000000007)] + +i2 = itst 1 + +-- K 0.0 `Stepper` (1.0e-2,K 1.0e-2)->(2.0e-2,K 2.0e-2)->(3.0e-2,K 3.0e-2)->(3.9999999999999994e-2,K 3.9999999999999994e-2)->(4.999999999999999e-2,K 4.999999999999999e-2)->(5.9999999999999984e-2,K 5.9999999999999984e-2)->(6.999999999999998e-2,K 6.999999999999998e-2)->(7.999999999999997e-2,K 7.999999999999997e-2)->(8.999999999999997e-2,K 8.999999999999997e-2)->(9.999999999999996e-2,K 9.999999999999996e-2)->(0.10999999999999996,K 0.10999999999999996)->(0.11999999999999995,K 0.11999999999999995)->(0.12999999999999995,K 0.12999999999999995)->(0.13999999999999996,K 0.13999999999999996)->(0.14999999999999997,K 0.14999999999999997)->(0.15999999999999998,K 0.15999999999999998)->(0.16999999999999998,K 0.16999999999999998)->(0.18,K 0.18)->(0.19,K 0.19)->(0.2,K 0.2)-> ... + +r2 = unb (it 1) + +main = print i1 + +-- Integration seems much slower than i'd expect it to be, even in the +-- non-recursive case. Recursive and non-recursive examples slow down as +-- they go. + diff --git a/src/Test/Merge.hs b/src/Test/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Test/Merge.hs @@ -0,0 +1,89 @@ +-- Tracking down a problem with event merging + +import Data.Monoid (mappend) +import Control.Applicative ((<$>)) + +import FRP.Reactive.Improving +import FRP.Reactive.Future +import FRP.Reactive.PrimReactive +import FRP.Reactive.Reactive +import FRP.Reactive.Internal.Future +import FRP.Reactive.Internal.Reactive + + +-- (Imp 1.0,1)->(Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined +e1 = listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)] + +-- (Imp 1.5,100)->(Imp 2.5,200) +e2 = listEG [(exactly 1.5, 100), (exactly 2.5, 200)] + +-- (Imp *** Exception: Prelude.undefined +e3 = listEG [(after 2.5, 200)] + +-- (Imp 1.5,100)->(Imp 2.3,200)->(Imp *** Exception: Prelude.undefined +e3' = listEG [(exactly 1.5, 100), (exactly 2.3, 200), (after 2.5, 300)] + +-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.5,200)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined +e4 = e1 `mappend` e2 + +-- (Imp 1.0,1)->(Imp 2.0,2): after: comparing after +e5 = e1 `mappend` e3 + +-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.3,200): after: comparing after +e5' = e1 `mappend` e3' + +-- (Imp 3.0,3)->(Imp *** Exception: Prelude.undefined +f1 = eFuture e1 + +-- +f2 = eFuture e2 + +-- (Imp 3.0,3)->(Imp *** Exception: Prelude.undefined +f4 = f1 `mappend` f3 + +-- : after: comparing after +f5 = f1 `merge` f3 + +-- : after: comparing after +f5' = eFuture e5 + + + +-- + +type Binop a = a -> a -> a + +mergeLR, mergeL, mergeR :: (Ord s) => Binop (FutureG s (ReactiveG s b)) + +-- Same as 'merge' +u `mergeLR` v = + (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v) + +u `mergeL` v = inFutR (`merge` v) <$> u + +u `mergeR` v = inFutR (u `merge`) <$> v + +-- inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b)) +-- -> (ReactiveG s b -> ReactiveG t b) + + +-- : after: comparing after +f6 = f1 `mergeLR` f3 + +-- : after: comparing after +f7 :: Future (Reactive Integer) +f7 = f1 `mergeL` f3 + +-- : after: comparing after +f7' = q <$> f1 + where + q (a `Stepper` Event u') = a `Stepper` Event (u' `merge` f3) diff --git a/src/Test/Reactive.hs b/src/Test/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reactive.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Test.TestReactive +-- Copyright : (c) Conal Elliott 2008 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Gather up QuickCheck tests for Reactive +---------------------------------------------------------------------- + +module Test.Reactive (batches,main) where + +-- import Test.QuickCheck + +import Test.QuickCheck.Checkers + +-- import qualified Data.Unamb + +import qualified FRP.Reactive.Future +import qualified FRP.Reactive.PrimReactive +import qualified FRP.Reactive.Reactive +import qualified FRP.Reactive.Fun + +batches :: [TestBatch] +batches = [ FRP.Reactive.Future.batch + , FRP.Reactive.PrimReactive.batch + , FRP.Reactive.Reactive.batch + , FRP.Reactive.Fun.batch + ] + +main :: IO () +main = mapM_ quickBatch batches diff --git a/src/Test/SimpleFilter.hs b/src/Test/SimpleFilter.hs new file mode 100644 --- /dev/null +++ b/src/Test/SimpleFilter.hs @@ -0,0 +1,92 @@ +-- Tracking down a problem with event merging + +import Data.Monoid +import Control.Applicative (pure,(<$>)) +import Control.Monad (join) + +import Data.Unamb + +import Data.Max +import Data.AddBounds +import FRP.Reactive.Improving +import FRP.Reactive.Future +import FRP.Reactive.PrimReactive -- hiding (filterE) +import FRP.Reactive.Reactive -- hiding (filterE) +import FRP.Reactive.Internal.Future +import FRP.Reactive.Internal.Reactive + +-- For neverE +import FRP.Reactive.Internal.Clock +import FRP.Reactive.Internal.TVal +import System.IO.Unsafe + + +negateOdds :: Event Int -> Event Int +negateOdds e = + (negate <$> filterE odd e) `mappend` (filterE even e) + +en :: TimeT -> Improving (AddBounds TimeT) +en = exactly . NoBound + +an :: TimeT -> Improving (AddBounds TimeT) +an = after . NoBound + +t :: (Bounded t, Eq t) => Int -> EventG t a -> [FutureG t a] +t n = take n . eFutures + +e7 :: Event Int +e7 = listEG [(en 1,1),(en 2,2),(en 3,3),(an 4,17)] +t7 = t 3 e7 + +e8 = filterE odd e7 +t8 = t 2 e8 + +e9 = negate <$> e8 +t9 = t 2 e9 + +e10 = filterE even e7 +t10 = t 1 e10 + +e11 = e9 `mappend` e10 +t11 = t 3 e11 + +e12 = filterE (const True) e7 +t12 = t 3 e12 + +e13 = filterE (const True) e7 `mappend` mempty +t13 = t 3 e13 + +e14 = filterE (const True) e7 `mappend` listEG [(an 5, error "five")] +t14 = t 3 e14 + +-- One occurrence out per second +e15 = filterE (const True) e7 `mappend` neverE +t15 = t 3 e15 + +-- This one finishes fine. +e16 = filterE (const True) e7 `mappend` listEG [(maxBound, error "maxed out")] +t16 = t 3 e16 + +e17 = e7 `mappend` neverE +t17 = t 3 e17 + + +-- Semantically equivalent to mappend +neverE :: Event a +neverE = unsafePerformIO $ + do c <- makeClock + (_,never) <- makeEvent c + return never + +-- as expected: [ paddlePosR +-- 0.0 `Stepper` (1.0,5.0e-2)->(2.0,0.0)->(3.0,5.0e-2)->(*** Exception: Prelude.undefined +-- *FRP.Reactive.Behavior FRP.Reactive.Reactive FRP.Reactive.Improving FRP.Reactive.Fun FRP.Reactive.Internal.Fun> paddlePosR `FRP.Reactive.Reactive.snapshot_` (listEG [(exactly (2.5 :: TimeT), ()),(exactly 3.5, ())]) +-- (2.5,0.0)->(3.5,0.0) + +-- I was unable to reproduce the error: + +import FRP.Reactive.Improving +import FRP.Reactive.PrimReactive +import FRP.Reactive.Reactive + +r :: Reactive Int +r = 0 `stepper` listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)] + +e :: Event () +e = listEG [(exactly 2.5, ()),(exactly 3.5, ())] + +e1 :: Event Int +e1 = r `snapshot_` e + +-- (Imp 2.5,2)->(Imp 3.5,3) + +e2 :: EventG ITime (Maybe (), Int) +e2 = r `snap` e + +-- (Imp 1.0,(Nothing,1))->(Imp 2.0,(Nothing,2))->(Imp 2.5,(Just (),2))->(Imp 3.0,(Nothing,3))->(Imp 3.5,(Just (),3))->(Imp *** Exception: Prelude.undefined