reactive 0.5.0.1 → 0.11.5
raw patch · 45 files changed
Files
- COPYING +661/−0
- Makefile +1/−0
- README +32/−0
- announce +9/−0
- changes.tw +29/−0
- reactive.cabal +74/−28
- src/Data/AddBounds.hs +159/−0
- src/Data/Fun.hs +0/−62
- src/Data/Future.hs +0/−171
- src/Data/Max.hs +30/−0
- src/Data/Min.hs +28/−0
- src/Data/PairMonad.hs +40/−0
- src/Data/Reactive.hs +0/−498
- src/Data/SFuture.hs +0/−195
- src/Examples.hs +311/−0
- src/FRP/Reactive.hs +49/−0
- src/FRP/Reactive/Behavior.hs +342/−0
- src/FRP/Reactive/Fun.hs +151/−0
- src/FRP/Reactive/Future.hs +224/−0
- src/FRP/Reactive/Improving.hs +215/−0
- src/FRP/Reactive/Internal/Behavior.hs +80/−0
- src/FRP/Reactive/Internal/Chan.hs +149/−0
- src/FRP/Reactive/Internal/Clock.hs +57/−0
- src/FRP/Reactive/Internal/Fun.hs +18/−0
- src/FRP/Reactive/Internal/Future.hs +86/−0
- src/FRP/Reactive/Internal/IVar.hs +122/−0
- src/FRP/Reactive/Internal/Misc.hs +20/−0
- src/FRP/Reactive/Internal/Reactive.hs +258/−0
- src/FRP/Reactive/Internal/Serial.hs +35/−0
- src/FRP/Reactive/Internal/TVal.hs +276/−0
- src/FRP/Reactive/Internal/Timing.hs +112/−0
- src/FRP/Reactive/LegacyAdapters.hs +26/−0
- src/FRP/Reactive/Num-inc.hs +112/−0
- src/FRP/Reactive/Num.hs +115/−0
- src/FRP/Reactive/PrimReactive.hs +957/−0
- src/FRP/Reactive/Reactive.hs +390/−0
- src/FRP/Reactive/SImproving.hs +173/−0
- src/FRP/Reactive/Sorted.hs +77/−0
- src/FRP/Reactive/VectorSpace.hs +21/−0
- src/Test.hs +3/−0
- src/Test/Integ.hs +52/−0
- src/Test/Merge.hs +89/−0
- src/Test/Reactive.hs +35/−0
- src/Test/SimpleFilter.hs +92/−0
- src/Test/Snap.hs +28/−0
+ COPYING view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU 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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.++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+<http://www.gnu.org/licenses/>.
+ Makefile view
@@ -0,0 +1,1 @@+include ../cho-cabal-make.inc
+ README view
@@ -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
+ announce view
@@ -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
+ changes.tw view
@@ -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 <hask>switcher</hask>. Didn't terminate. Thanks to Ivan Tomac for the bug report.++=== Version 0.1 ===++* Added <hask>Never</hask> constructor for Future. Allows optimizations, including a huge improvement for <hask>(>>=)</hask> on <hask>Event</hask> (which had been piling up <hask>never</hask>s).+* removed <code>-threaded</code> comment+* added <hask>traceR</hask> (reactive value tracing)+* use idler in <code>src/Examples.hs</code> (for single-threaded use of wxHaskell)++=== Version 0.0 ===++* New project.
reactive.cabal view
@@ -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\", <http://conal.net/papers/push-pull-frp/>. .+ 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: <http://haskell.org/haskellwiki/reactive> .- 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
+ src/Data/AddBounds.hs view
@@ -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"
− src/Data/Fun.hs
@@ -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
− src/Data/Future.hs
@@ -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 <http://en.wikipedia.org/wiki/Futures_and_promises>.--- --- 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
+ src/Data/Max.hs view
@@ -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)
+ src/Data/Min.hs view
@@ -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)
+ src/Data/PairMonad.hs view
@@ -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?
− src/Data/Reactive.hs
@@ -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
− src/Data/SFuture.hs
@@ -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 <http://en.wikipedia.org/wiki/Futures_and_promises>.--- --- 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
+ src/Examples.hs view
@@ -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)+
+ src/FRP/Reactive.hs view
@@ -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 ()
+ src/FRP/Reactive/Behavior.hs view
@@ -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"
+ src/FRP/Reactive/Fun.hs view
@@ -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)))])+ ]+ )
+ src/FRP/Reactive/Future.hs view
@@ -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 <http://en.wikipedia.org/wiki/Futures_and_promises>.+-- +-- 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
+ src/FRP/Reactive/Improving.hs view
@@ -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+-- <http://conal.net/blog/semantic-editor-combinators>.+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.+
+ src/FRP/Reactive/Internal/Behavior.hs view
@@ -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+-- <http://conal.net/blog/posts/simplifying-semantics-with-type-class-morphisms/>.+-- +-- * '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
+ src/FRP/Reactive/Internal/Chan.hs view
@@ -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)
+ src/FRP/Reactive/Internal/Clock.hs view
@@ -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)
+ src/FRP/Reactive/Internal/Fun.hs view
@@ -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
+ src/FRP/Reactive/Internal/Future.hs view
@@ -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 = "<never>"+-- | otherwise = "<" ++ show t ++ "," ++ show a ++ ">"+ show u | isNeverF u = "<never>"+ 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
+ src/FRP/Reactive/Internal/IVar.hs view
@@ -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 <int-e@gmx.de>+-- 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++-}
+ src/FRP/Reactive/Internal/Misc.hs view
@@ -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
+ src/FRP/Reactive/Internal/Reactive.hs view
@@ -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'+
+ src/FRP/Reactive/Internal/Serial.hs view
@@ -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)
+ src/FRP/Reactive/Internal/TVal.hs view
@@ -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)+ )+++{-+-}
+ src/FRP/Reactive/Internal/Timing.hs view
@@ -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??"
+ src/FRP/Reactive/LegacyAdapters.hs view
@@ -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)+
+ src/FRP/Reactive/Num-inc.hs view
@@ -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
+ src/FRP/Reactive/Num.hs view
@@ -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
+ src/FRP/Reactive/PrimReactive.hs view
@@ -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..]) +
+ src/FRP/Reactive/Reactive.hs view
@@ -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!+ ]+ )
+ src/FRP/Reactive/SImproving.hs view
@@ -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.
+ src/FRP/Reactive/Sorted.hs view
@@ -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
+ src/FRP/Reactive/VectorSpace.hs view
@@ -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 *^)
+ src/Test.hs view
@@ -0,0 +1,3 @@+-- Run tests. ghc --make Test.hs -o test -threaded ; ./test++import Test.Reactive
+ src/Test/Integ.hs view
@@ -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.+
+ src/Test/Merge.hs view
@@ -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)<interactive>: after: comparing after+e5 = e1 `mappend` e3++-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.3,200)<interactive>: after: comparing after+e5' = e1 `mappend` e3'++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+f1 = eFuture e1++-- <NoBound Imp 1.5,100 `Stepper` (Imp 2.5,200)>+f2 = eFuture e2++-- <NoBound Imp *** Exception: Prelude.undefined+f3 = eFuture e3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined+f4 = f1 `mappend` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f5 = f1 `merge` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: 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)+++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f6 = f1 `mergeLR` f3++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f7 :: Future (Reactive Integer)+f7 = f1 `mergeL` f3++-- <NoBound Imp *** Exception: Prelude.undefined+f8 = f1 `mergeR` f3+++f7' :: Future (Reactive Integer)++-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after+f7' = q <$> f1+ where+ q (a `Stepper` Event u') = a `Stepper` Event (u' `merge` f3)
+ src/Test/Reactive.hs view
@@ -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
+ src/Test/SimpleFilter.hs view
@@ -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: [<Imp NoBound C-c C-c+tN = t 1 neverE++-- Imp NoBound C-c C-c+tinf :: ITime+tinf = getMax (futTime (head tN))++-- True+p1 = en 0 <= tinf++-- GT+p2 = compareI tinf (NoBound 0)
+ src/Test/Snap.hs view
@@ -0,0 +1,28 @@+-- From Beelsebob's: http://hpaste.org/13096++-- *FRP.Reactive.Behavior FRP.Reactive.Reactive FRP.Reactive.Improving FRP.Reactive.Fun FRP.Reactive.Internal.Fun> 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