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