packages feed

reflex 0.3.2 → 0.9.4.1

raw patch · 73 files changed

Files

+ ChangeLog.md view
@@ -0,0 +1,215 @@+# Revision history for reflex++## 0.9.4.1++* Bug fix for `CausalityLoopException`s caused by incorrect coincidence and merge height invalidation by @parenthetical in [#536](https://github.com/reflex-frp/reflex/pull/536).+* Space leak fixed: Applicative combination of Behaviors, with at least one never changing, no longer causes unbounded memory growth by @parenthetical in [#535](https://github.com/reflex-frp/reflex/pull/535).+* Stray debug print removed from non-debug builds.++## 0.9.4.0++* Add note about `requesting` semantics by @LightAndLight in https://github.com/reflex-frp/reflex/pull/508+* Dropped lens by @ilyakooo0 in https://github.com/reflex-frp/reflex/pull/463+* Build with ghc(js) 9.8.2 + 9.10.1 + 9.12.2 by @ymeister in https://github.com/reflex-frp/reflex/pull/502+* headless: Add MonadThrow (Performable m) by @ali-abrar in https://github.com/reflex-frp/reflex/pull/523+* Don't check in newSubscriberCoincidenceInner whether occRef is already set by @parenthetical in https://github.com/reflex-frp/reflex/pull/496+* Always enable Template Haskell by @Ericson2314 in https://github.com/reflex-frp/reflex/pull/484++## 0.9.3.4++* Support random 1.3++## 0.9.3.3++* Add support for GHC 9.12+* Loosen version bounds++## 0.9.3.2++* Add support for witherable 0.5++## 0.9.3.1++* Add support for GHC 9.8 and 9.10++## 0.9.3.0++* Headless Host: Generalize to allow returning arbitrary types++## 0.9.2.0++* Add MonadMask, MonadCatch, MonadThrow instances++## 0.9.1.0++* Headless Host: Add some MonadSample, MonadHold, and MonadFix instances++## 0.9.0.1++* Add support for ghc-9.6++## 0.9.0.0++* Breaking Change: Filter updates to `listWithKey` child widgets so that changes to the input Map don't cause spurious updates to unaffected children. This imposes an `Eq` constraint on the child values.+* Expose all Requester internals in Reflex.Requester.Base.Internal+* [Add EventWriter instance for RequesterT #469](https://github.com/reflex-frp/reflex/pull/469)++## 0.8.2.2++* Require witherable >= 0.4 and, hence, a newer monoidal-containers+* Support newer constraints-extras (0.4)++## 0.8.2.1++* Fix build for GHC 9.2+* Require patch >= 0.0.7.0++## 0.8.2.0++* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.++## 0.8.1.1++* Allow newer hlint for older GHCs, and add upper bound for newer GHCs++## 0.8.1.0++* Add support for GHC 8.10+* Drop support for GHC < 8.4++## 0.8.0.0++* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.++## 0.7.2.0 -- *Deprecated*++* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.+* Extend some dependency version bounds+* Fix HLint 3 test++## 0.7.1.1++*Backport release*.+Changes do not carry forward to 0.7.2.0.++* Add support for GHC 8.10+* Drop support for GHC < 8.4+* Extend some dependency version bounds+* Fix HLint 3 test++## 0.7.1.0++* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.+* ([#420](https://github.com/reflex-frp/reflex/pull/420)) Add a [`Data.Zip.Unzip`](https://hackage.haskell.org/package/semialign-1.1/docs/Data-Zip.html#t:Unzip) instance for `Event`.+* ([#419](https://github.com/reflex-frp/reflex/pull/419)) Add `distributeIntMapOverDynPure` and `joinDynThroughIntMap` as convenience functions for working with `Dynamic` `IntMap`s.+++## 0.7.0.0++* Add lifting instances for most classes to `Reflex.Profiled.Profiled`. ([#398](https://github.com/reflex-frp/reflex/pull/398))+* Class `MonadQuery t q m` now has a `Monad m` superclass constraint. ([#400](https://github.com/reflex-frp/reflex/pull/400))+* **(Breaking change)** Rename class `MonadBehaviorWriter` -> `BehaviorWriter` for consistency with `EventWriter`/`DynamicWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))+* Introduce deprecated alias `MonadBehaviorWriter = BehaviorWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))+* Fix bug in spider where event subscriptions would be prematurely finalized due to over-aggressive inlining. ([#409](https://github.com/reflex-frp/reflex/pull/409))+* Add instances of `PerformEvent` and `TriggerEvent` for `MaybeT`. ([#395](https://github.com/reflex-frp/reflex/pull/395))++## 0.6.4.1++* Fix a bug in the Reflex Profiled transformer where+  `Reflex.Class.mergeIncrementalG` and+  `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced+  itself instead of the inner transformed timeline, causing an+  infinite loop.++## 0.6.4++* Support GHC 8.8++* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation++* The `Reflex.Patch.*` modules were moved to the `patch` library.+  They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here.++* Additional instances for `Query` classes for basic types.++* Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging+  code for performance and for cyclic dependencies between events++## 0.6.3++* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.+  They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively.++* Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`.++* Add missing `NotReady` instances:+   - `instance NotReady (SpiderTimeline x) (SpiderHost x)`+   - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))`++## 0.6.2.4++* Update to monoidal-containers 0.6++## 0.6.2.3++* Add an upper-bound to witherable++## 0.6.2.2++* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not.++* Update version bounds to fix some CI failures++* Add travis CI configuration++## 0.6.2.1++* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`+  functor:+    * `fan` to `fanG`+    * `EventSelectorG` for `fanG` result selector.++* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.+    * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)+    * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic++* Generalize merging functions:+  `merge` to `mergeG`,+  `mergeIncremental` to `mergeIncrementalG`,+  `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.++* Generalize distribute function:+    `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,++## 0.6.2.0++* Fix `holdDyn` so that it is lazy in its event argument+  These produce `DMap`s  whose values needn't be `Identity`.++* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).++* Fix `holdDyn` so that it is lazy in its event argument.++## 0.6.1.0++* Re-export all of `Data.Map.Monoidal`++* Fix `QueryT` and `RequesterT` tests++## 0.6.0.0 -- 2019-03-20++* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.++* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.++* Remove many deprecated functions.++* Add a `Num` instance for `Dynamic`.++* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.++* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.++* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.++* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.
+ Quickref.md view
@@ -0,0 +1,315 @@+# Reflex Quick(ish) Reference++## Typeclasses++Many Reflex functions operate in monadic context `m a`, where the monad 'm' supports various additional typeclasses such as MonadWidget, MonadHold, or MonadSample in addition to Monad itself.  The actual 'm' in use will be determined by the top-level entry point of the FRP host (such as Reflex-Dom -- see the bottom of the Reflex-Dom quick reference for details).++The function signatures here have been simplified by removing many typeclass constraints and adding simple annotations to each function.  Also the ubiquitous 't' type parameter has been removed.++Some of these functions are *pure*:  They operate on Events, Behaviors, or Dynamics uniformly without regard to the "current time".  Other functions must operate in some monadic context, because they produce a result "as of now"  (e.g., any function that takes an "initial" value, or returns a "current" value).  Annotations are used to distinguish these cases:++```haskell+[ ]   -- Pure function+[S]   -- Function runs in any monad supporting MonadSample+[H]   -- Function runs in any monad supporting MonadHold+```+Since MonadHold depends on MonadSample, any [S] function also runs in [H] context.++## Functions producing Event++```haskell+-- Trivial Event+[ ]   never   ::              Event a++-- Extract Event from Dynamic+[ ]   updated :: Dynamic a -> Event a++-- Transform Event to Event using function+[ ]   fmap      :: (a ->       b) ->        Event a -> Event b+[ ]   fmapMaybe :: (a -> Maybe b) ->        Event a -> Event b+[ ]   ffilter   :: (a ->    Bool) ->        Event a -> Event a+[ ]   ffor      ::        Event a -> (a ->       b) -> Event b+[ ]   fforMaybe ::        Event a -> (a -> Maybe b) -> Event b+[ ]   <$        ::              a ->        Event b -> Event a++-- Event to identical Event with debug trace.  (Only prints if Event is ultimately used.)+[ ]   traceEvent     :: Show a => String -> Event a -> Event a+[ ]   traceEventWith ::    (a -> String) -> Event a -> Event a++-- Transform Event to Event by sampling Behavior or Dynamic+[ ]   gate                       ::                     Behavior Bool -> Event a -> Event a+[ ]   tag                        ::                        Behavior a -> Event b -> Event a+[ ]   tagPromptlyDyn             ::                         Dynamic a -> Event b -> Event a+[ ]   attach                     ::                        Behavior a -> Event b -> Event (a, b)+[ ]   attachPromptlyDyn          ::                         Dynamic a -> Event b -> Event (a, b)+[ ]   attachWith                 :: (a -> b ->       c) -> Behavior a -> Event b -> Event c+[ ]   attachPromptlyDynWith      :: (a -> b ->       c) ->  Dynamic a -> Event b -> Event c+[ ]   attachWithMaybe            :: (a -> b -> Maybe c) -> Behavior a -> Event b -> Event c+[ ]   attachPromptlyDynWithMaybe :: (a -> b -> Maybe c) ->  Dynamic a -> Event b -> Event c+[ ]   <@>                        ::                 Behavior (a -> b) -> Event a -> Event b+[ ]   <@                         ::                        Behavior a -> Event b -> Event a++-- Combine multiple Events+[ ]   <>         ::      Semigroup a => Event a -> Event a -> Event a+[ ]   difference ::                     Event a -> Event b -> Event a+[ ]   align      ::                     Event a -> Event b -> Event (These a b)+[ ]   alignWith  :: (These a b -> c) -> Event a -> Event b -> Event c+      -- Note align functions from Data.Align in semialign package+[ ]   mergeWith  :: (a -> a -> a) -> [Event a] -> Event a+[ ]   leftmost   :: [Event a] -> Event a+[ ]   mergeList  :: [Event a] -> Event (NonEmpty a)+[ ]   merge      :: GCompare k => DMap k Event -> Event (DMap k Identity)+[ ]   mergeMap   :: Ord k => Map k (Event a) -> Event (Map k a)++-- Efficient one-to-many fanout+[ ]   fanMap    :: Ord k      => Event (Map k a)         -> EventSelector (Const2 k a)+[ ]   fan       :: GCompare k => Event (DMap k Identity) -> EventSelector k+[ ]   select    ::                                          EventSelector k -> k a -> Event a+[ ]   fanEither :: Event (Either a b) -> (Event a, Event b)+[ ]   fanThese  :: Event (These a b)  -> (Event a, Event b)++-- Event to Event via function that can sample current values+[ ]   push       :: (a -> m (Maybe b)) -> Event a -> Event b+[ ]   pushAlways :: (a -> m        b ) -> Event a -> Event b+      -- Note supplied function operates in [H] context++-- Split Event into next occurrence and all other future occurrences, as of now.+[H]   headE     :: Event a -> m (Event a)+[H]   tailE     :: Event a -> m (Event a)+[H]   headTailE :: Event a -> m (Event a, Event a)+```++## Functions producing Behavior++```haskell+-- Trivial Behavior+[ ]   constant ::              a ->    Behavior a++-- Extract Behavior from Dynamic+[ ]   current  ::      Dynamic a ->    Behavior a++-- Create Behavior with given initial value, updated when the Event fires.+[H]   hold     :: a ->   Event a -> m (Behavior a)++-- Transform Behavior to Behavior using function+[ ]   fmap ::               (a -> b) ->        Behavior a -> Behavior b+[ ]   ffor ::             Behavior a ->          (a -> b) -> Behavior b+[ ]   <*>  ::      Behavior (a -> b) ->        Behavior a -> Behavior b+[ ]   >>=  ::             Behavior a -> (a -> Behavior b) -> Behavior b+[ ]   <>   :: Monoid a => Behavior a ->        Behavior a -> Behavior a+-- ... plus many more due to typeclass membership++-- Combine multiple behaviors via applicative instance+[ ]   ffor2 :: Behavior a -> Behavior b ->               (a -> b -> c)      -> Behavior c+[ ]   ffor3 :: Behavior a -> Behavior b -> Behavior c -> (a -> b -> c -> d) -> Behavior d++-- Behavior to Behavior by sampling current values+[S]   sample :: Behavior a -> m a+[ ]   pull   ::               m a -> Behavior a+      -- Note supplied value is in [S] context+```++## Functions producing Dynamic++```haskell+-- Trivial Dynamic+[ ]   constDyn ::                                  a            ->    Dynamic a++-- Create Dynamic with given initial value, updated (various ways) when the Event fires.+[H]   holdDyn       ::                             a -> Event a -> m (Dynamic a)+[H]   foldDyn       :: (a -> b ->           b ) -> b -> Event a -> m (Dynamic b)+[H]   foldDynMaybe  :: (a -> b ->     Maybe b ) -> b -> Event a -> m (Dynamic b)+[H]   foldDynM      :: (a -> b -> m'        b ) -> b -> Event a -> m (Dynamic b)+[H]   foldDynMaybeM :: (a -> b -> m' (Maybe b)) -> b -> Event a -> m (Dynamic b)+      -- Note m' supplies [H] context++-- Initial value is 0; counts Event firings from now.+[H]   count :: Num b => Event a -> m (Dynamic b)+-- Initial Bool value is supplied; toggles at each Event firing.+[H]   toggle :: Bool -> Event a -> m (Dynamic Bool)++-- Transform Dynamic to Dynamic using function+[ ]   ffor         ::   Dynamic a ->  (a -> b) -> Dynamic b+[ ]   fmap         :: (a ->    b) -> Dynamic a -> Dynamic b+[ ]   splitDynPure ::           Dynamic (a, b) -> (Dynamic a, Dynamic b)++-- Combine multiple Dynamics+[ ]   mconcat                   :: Monoid a => [Dynamic a] -> Dynamic a+[ ]   distributeDMapOverDynPure :: GCompare k => DMap (WrapArg Dynamic k) -> Dynamic (DMap k)+[ ]   <*>                       ::           Dynamic (a -> b) ->        Dynamic a -> Dynamic b+[ ]   >>=                       ::                  Dynamic a -> (a -> Dynamic b) -> Dynamic b+[ ]   zipDynWith                :: (a -> b -> c) -> Dynamic a -> Dynamic b        -> Dynamic c++-- Combine multiple dynamics via applicative instance+[ ]   ffor2 :: Dynamic a -> Dynamic b ->              (a -> b -> c)      -> Dynamic c+[ ]   ffor3 :: Dynamic a -> Dynamic b -> Dynamic c -> (a -> b -> c -> d) -> Dynamic d++-- Efficient one-to-many fanout+[ ]   demux   :: Ord k => Dynamic k -> Demux k+[ ]   demuxed :: Eq k  =>              Demux k -> k -> Dynamic Bool++-- Dynamic to Dynamic, removing updates w/o value change+[H]   holdUniqDyn   :: Eq a => Dynamic a -> m (Dynamic a)+[H]   holdUniqDynBy :: (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)++-- Dynamic to identical Dynamic with debug trace.  (Only prints if Dynamic is ultimately used.)+[ ]   traceDyn     :: Show a => String -> Dynamic a -> Dynamic a+[ ]   traceDynWith ::    (a -> String) -> Dynamic a -> Dynamic a+```++## Flattening functions++These functions flatten nested types such as Event-of-Event, Behavior-of-Event, Event-of-Behavior etc, removing the outer wrapper.++For Events, the returned Event fires whenever the latest Event supplied by the wrapper fires.  There are differences in how the functions handle *coincidences* -- situations where the old or new Event fires at the same instant that we switch from old to new.  In some cases, the output Event tracks the old Event at the instant of switchover, while in other cases it tracks the new Event.++```haskell+-- Flatten Behavior-of-Event to Event.  Old Event is used during switchover.+[ ]   switch            ::                  Behavior (Event a)  ->    Event a++-- Flatten Dynamic-of-Event to Event.  New Event is used immediately.+[ ]   switchDyn         ::                   Dynamic (Event a)  ->    Event a++-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.+[ ]   coincidence       ::                     Event (Event a)  ->    Event a++-- Flatten Behavior-of-Behavior to Behavior. Behavior is an instance of Monad,+-- so the 'join' function from 'Control.Monad' suffices. The output of 'join' is+-- a Behavior whose value is equal to the current value of the current value of+-- the input.+[ ]   join              ::                Behavior (Behavior a) ->    Behavior a+++-- Flatten Dynamic-of-Dynamic to Dynamic.  New Dynamic is used immediately.+-- Output updated whenever inner OR outer Dynamic updates.+[ ]   join              ::          Dynamic        (Dynamic a)  ->  Dynamic a+[ ]   joinDynThroughMap :: Ord k => Dynamic (Map k (Dynamic a)) ->  Dynamic (Map k a)++-- Analogous to 'hold':  Create a Behavior that is initially identical to the+-- supplied Behavior.  Updated to track a new Behavior whenever the Event fires.+[H]   switcher          ::    Behavior a -> Event (Behavior a)  -> m (Behavior a)++-- Similar to above, for Events.  Created Event initially tracks the first argument.+-- At switchover, the output Event immediately tracks the new Event.+[H]   switchHold        ::       Event a ->    Event (Event a)  -> m (Event a)+```++## Typeclasses to introspect and modify an FRP network.++The functions mentioned above are used to create a static FRP network.+There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network.++The typeclasses and their associated annotations include:++- `PostBuild`+    Fire an Event when an FRP network has been set up.+    ```haskell+    [B]   -- Function runs in any monad supporting PostBuild+    ```++- `Adjustable`+    Use Events to add or remove pieces of an FRP network.+    ```haskell+    [A]   -- Function runs in any monad supporting Adjustable+    ```++- `TriggerEvent`+    Create new externally-fired Events from within an FRP network.+    ```haskell+    [T]   -- Function runs in any monad supporting TriggerEvent+    ```++- `PerformEvent`+    Use Events to trigger IO actions and to collect their results.+    ```haskell+    [P]   -- Function runs in any monad supporting PerformEvent+    ```++## Startup++```haskell+-- One-shot Event that is triggered once the FRP network has been built+[B]   getPostBuild :: m (Event ())+```++## Collection management functions++```haskell+-- Turn a Dynamic key/value map into a set of dynamically-changing widgets.+[H,A,B]   listWithKey :: Ord k =>+            Dynamic (Map k v) -> (k -> Dynamic v -> m        a ) -> m (Dynamic (Map k a))++-- Same as above where the widget constructor doesn't care about the key.+[H,A,B]   list        :: Ord k =>+            Dynamic (Map k v) -> (     Dynamic v -> m        a ) -> m (Dynamic (Map k a))++-- Even simpler version where there are no keys and we just use a list.+[H,A,B]   simpleList  ::+            Dynamic       [v] -> (     Dynamic v -> m        a ) -> m (Dynamic       [a])++-- Like listWithKey specialized for widgets returning (Event a).+[H,A,B]   listViewWithKey :: Ord k =>+            Dynamic (Map k v) -> (k -> Dynamic v -> m (Event a)) -> m (Event   (Map k a))++-- Create a dynamically-changing set of widgets, one of which is selected at any time.+[H,A,B]   selectViewListWithKey_ :: Ord k => Dynamic k ->+            Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)++-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.+[H,A]     listWithKeyShallowDiff :: Ord k =>+            Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))+```++## Creating new events from within an FRP network.++```haskell+-- Create a new Event and a function that will cause the Event to fire, from within an FRP network+[T]   newTriggerEvent      :: m (Event a, a -> IO ())+```++## Connecting to the real world (I/O)++```haskell+-- Run side-effecting actions in Event when it occurs; returned Event contains+-- results. Side effects run in the (Performable m) monad which is associated with+-- the (PerformEvent t m) typeclass constraint.+-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.+[P]   performEvent        :: Event (Performable m a )                 -> m (Event a)++-- Just run side-effects; no return Event+[P]   performEvent_       :: Event (Performable m ())                 -> m ()++-- Actions run asynchronously; actions are given a callback to send return values+[P,T]   performEventAsync :: Event ((a -> IO ()) -> Performable m ()) -> m (Event a)+```++### Time++```haskell+-- Create Event at given interval with given basis time.+[P,T]   tickLossy :: NominalDiffTime -> UTCTime -> m (Event t TickInfo)++-- Delay an Event's occurrences by a given amount in seconds.+[P,T]   delay :: NominalDiffTime -> Event t a -> m (Event t a)+```++## Networks++```haskell+-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a)++[A]     runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)++-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.+-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,+-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).+[P,A]   networkView :: Dynamic (m a) -> m (Event a)++-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the+-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an+-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.+[H,A]   networkHold :: m a -> Event (m a) -> m (Dynamic a)++-- Render a placeholder network to be shown while another network is not yet done building+[P,A]   untilReady :: m a -> m b -> m (a, Event b)+```
+ README.md view
@@ -0,0 +1,24 @@+# [Reflex](https://reflex-frp.org/)++[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)++Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse.++Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.++**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**++## Resources++* [Official Website](https://reflex-frp.org)+* [Quick Reference](Quickref.md)+* [Reflex-DOM](https://github.com/reflex-frp/reflex-dom): A framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps.+* [Obelisk](https://github.com/obsidiansystems/obelisk#obelisk): A framework built on Reflex and Reflex-DOM for functional reactive web and mobile applications, with batteries included.+* [Get started with Reflex](https://github.com/reflex-frp/reflex-platform)+* [#reflex-frp:matrix.org](https://matrix.to/#/#reflex-frp:matrix.org): Official Matrix room+* [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)+* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)++## Hacking++From the root of a [Reflex Platform](https://github.com/reflex-frp/reflex-platform) checkout, run `./scripts/hack-on haskell-overlays/reflex-packages/dep/reflex`. This will check out the reflex source code into the `haskell-overlays/reflex-packages/dep/reflex` directory. You can then point that checkout at your fork, make changes, etc. Use the `./try-reflex` or `./scripts/work-on` scripts to start a shell in which you can test your changes.
+ bench-cbits/checkCapability.c view
@@ -0,0 +1,208 @@+#include <Rts.h>++// The InCall structure represents either a single in-call from C to+// Haskell, or a worker thread.+typedef struct InCall_ {+    StgTSO *   tso;             // the bound TSO (or NULL for a worker)++    StgTSO *   suspended_tso;   // the TSO is stashed here when we+                                // make a foreign call (NULL otherwise);++    Capability *suspended_cap;  // The capability that the+                                // suspended_tso is on, because+                                // we can't read this from the TSO+                                // without owning a Capability in the+                                // first place.++    SchedulerStatus  rstat;     // return status+    StgClosure **    ret;       // return value++    struct Task_ *task;++    // When a Haskell thread makes a foreign call that re-enters+    // Haskell, we end up with another Task associated with the+    // current thread.  We have to remember the whole stack of InCalls+    // associated with the current Task so that we can correctly+    // save & restore the InCall on entry to and exit from Haskell.+    struct InCall_ *prev_stack;++    // Links InCalls onto suspended_ccalls, spare_incalls+    struct InCall_ *prev;+    struct InCall_ *next;+} InCall;++typedef struct Task_ {+#if defined(THREADED_RTS)+    OSThreadId id;              // The OS Thread ID of this task++    Condition cond;             // used for sleeping & waking up this task+    Mutex lock;                 // lock for the condition variable++    // this flag tells the task whether it should wait on task->cond+    // or just continue immediately.  It's a workaround for the fact+    // that signalling a condition variable doesn't do anything if the+    // thread is already running, but we want it to be sticky.+    HsBool wakeup;+#endif++    // This points to the Capability that the Task "belongs" to.  If+    // the Task owns a Capability, then task->cap points to it.  If+    // the task does not own a Capability, then either (a) if the task+    // is a worker, then task->cap points to the Capability it belongs+    // to, or (b) it is returning from a foreign call, then task->cap+    // points to the Capability with the returning_worker queue that this+    // this Task is on.+    //+    // When a task goes to sleep, it may be migrated to a different+    // Capability.  Hence, we always check task->cap on wakeup.  To+    // syncrhonise between the migrater and the migratee, task->lock+    // must be held when modifying task->cap.+    struct Capability_ *cap;++    // The current top-of-stack InCall+    struct InCall_ *incall;++    uint32_t n_spare_incalls;+    struct InCall_ *spare_incalls;++    HsBool    worker;          // == rtsTrue if this is a worker Task+    HsBool    stopped;         // this task has stopped or exited Haskell++    // So that we can detect when a finalizer illegally calls back into Haskell+    HsBool running_finalizers;++    // Links tasks on the returning_tasks queue of a Capability, and+    // on spare_workers.+    struct Task_ *next;++    // Links tasks on the all_tasks list; need ACQUIRE_LOCK(&all_tasks_mutex)+    struct Task_ *all_next;+    struct Task_ *all_prev;++} Task;++struct Capability_ {+    // State required by the STG virtual machine when running Haskell+    // code.  During STG execution, the BaseReg register always points+    // to the StgRegTable of the current Capability (&cap->r).+    StgFunTable f;+    StgRegTable r;++    uint32_t no;  // capability number.++    // The Task currently holding this Capability.  This task has+    // exclusive access to the contents of this Capability (apart from+    // returning_tasks_hd/returning_tasks_tl).+    // Locks required: cap->lock.+    Task *running_task;++    // true if this Capability is running Haskell code, used for+    // catching unsafe call-ins.+    HsBool in_haskell;++    // Has there been any activity on this Capability since the last GC?+    uint32_t idle;++    HsBool disabled;++    // The run queue.  The Task owning this Capability has exclusive+    // access to its run queue, so can wake up threads without+    // taking a lock, and the common path through the scheduler is+    // also lock-free.+    StgTSO *run_queue_hd;+    StgTSO *run_queue_tl;++    // Tasks currently making safe foreign calls.  Doubly-linked.+    // When returning, a task first acquires the Capability before+    // removing itself from this list, so that the GC can find all+    // the suspended TSOs easily.  Hence, when migrating a Task from+    // the returning_tasks list, we must also migrate its entry from+    // this list.+    InCall *suspended_ccalls;++    // One mutable list per generation, so we don't need to take any+    // locks when updating an old-generation thunk.  This also lets us+    // keep track of which closures this CPU has been mutating, so we+    // can traverse them using the right thread during GC and avoid+    // unnecessarily moving the data from one cache to another.+    bdescr **mut_lists;+    bdescr **saved_mut_lists; // tmp use during GC++    // block for allocating pinned objects into+    bdescr *pinned_object_block;+    // full pinned object blocks allocated since the last GC+    bdescr *pinned_object_blocks;++    // per-capability weak pointer list associated with nursery (older+    // lists stored in generation object)+    StgWeak *weak_ptr_list_hd;+    StgWeak *weak_ptr_list_tl;++    // Context switch flag.  When non-zero, this means: stop running+    // Haskell code, and switch threads.+    int context_switch;++    // Interrupt flag.  Like the context_switch flag, this also+    // indicates that we should stop running Haskell code, but we do+    // *not* switch threads.  This is used to stop a Capability in+    // order to do GC, for example.+    //+    // The interrupt flag is always reset before we start running+    // Haskell code, unlike the context_switch flag which is only+    // reset after we have executed the context switch.+    int interrupt;++    // Total words allocated by this cap since rts start+    // See [Note allocation accounting] in Storage.c+    W_ total_allocated;++#if defined(THREADED_RTS)+    // Worker Tasks waiting in the wings.  Singly-linked.+    Task *spare_workers;+    uint32_t n_spare_workers; // count of above++    // This lock protects:+    //    running_task+    //    returning_tasks_{hd,tl}+    //    wakeup_queue+    //    inbox+    Mutex lock;++    // Tasks waiting to return from a foreign call, or waiting to make+    // a new call-in using this Capability (NULL if empty).+    // NB. this field needs to be modified by tasks other than the+    // running_task, so it requires cap->lock to modify.  A task can+    // check whether it is NULL without taking the lock, however.+    Task *returning_tasks_hd; // Singly-linked, with head/tail+    Task *returning_tasks_tl;++    // Messages, or END_TSO_QUEUE.+    // Locks required: cap->lock+    Message *inbox;++    SparkPool *sparks;++    // Stats on spark creation/conversion+    SparkCounters spark_stats;+#if !defined(mingw32_HOST_OS)+    // IO manager for this cap+    int io_manager_control_wr_fd;+#endif+#endif++    // Per-capability STM-related data+    StgTVarWatchQueue *free_tvar_watch_queues;+    StgTRecChunk *free_trec_chunks;+    StgTRecHeader *free_trec_headers;+    uint32_t transaction_tokens;+} // typedef Capability is defined in RtsAPI.h+  // We never want a Capability to overlap a cache line with anything+  // else, so round it up to a cache line size:+#ifndef mingw32_HOST_OS+  ATTRIBUTE_ALIGNED(64)+#endif+  ;++HsBool myCapabilityHasOtherRunnableThreads() {+  return rts_unsafeGetMyCapability()->run_queue_hd == END_TSO_QUEUE ? HS_BOOL_FALSE : HS_BOOL_TRUE;+}
bench/Main.hs view
@@ -1,38 +1,34 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}++-- The instance for NFData (TVar a) is an orphan, but necessary here+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Main where -import Data.Functor.Misc-import Control.Monad.Primitive-import Control.Monad.IO.Class-import Data.Dependent.Sum import Control.Concurrent.STM-import Control.Applicative-import System.IO.Unsafe-import Data.IORef import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad+import Control.Monad.Identity+import Control.Monad.IO.Class+import Criterion.Main+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum+import Data.Functor.Misc+import Data.IORef+import Data.Maybe (fromJust) import Reflex import Reflex.Host.Class-import System.Mem-import System.IO-import Criterion.Main -import qualified Data.Traversable as T--import qualified Data.Dependent.Map as DM-- main :: IO () main = defaultMain   [ bgroup "micro" micros ] -instance NFData (IORef a) where-  rnf x = seq x ()- instance NFData (TVar a) where   rnf x = seq x () @@ -40,15 +36,14 @@ instance NFData (WHNF a) where   rnf (WHNF a) = seq a () -withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark+withSetup :: NFData b => String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->   bench name . nfIO $ runSpiderHost (action a) -withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark+withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->   bench name . whnfIO $ runSpiderHost (action a) - micros :: [Benchmark] micros =   [ bench "newIORef" $ whnfIO $ void $ newIORef ()@@ -71,40 +66,41 @@     (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)   , withSetupWHNF "fireEventsOnly"     (newEventWithTriggerRef >>= subscribePair)-    (\(subd, trigger) -> do-        Just key <- liftIO $ readIORef trigger-        fireEvents [key :=> (42 :: Int)])+    (\(_, trigger) -> do+        key <- fromJust <$> liftIO (readIORef trigger)+        fireEvents [key :=> Identity (42 :: Int)])   , withSetupWHNF "fireEventsAndRead(head/merge1)"     (setupMerge 1 >>= subscribePair)-    (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+    (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)   , withSetupWHNF "fireEventsAndRead(head/merge100)"     (setupMerge 100 >>= subscribePair)-    (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+    (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)   , withSetupWHNF "fireEventsAndRead(head/merge10000)"       (setupMerge 10000 >>= subscribePair)-      (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+      (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)   , withSetupWHNF "fireEventsOnly(head/merge100)"     (setupMerge 100 >>= subscribePair)-    (\(subd, t:riggers) -> do-        Just key <- liftIO $ readIORef t-        fireEvents [key :=> (42 :: Int)])-  , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev-  , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample    +    (\(_, t:_) -> do+        key <- fromJust <$> liftIO (readIORef t)+        fireEvents [key :=> Identity (42 :: Int)])+  , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev+  , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample   ]  setupMerge :: Int-           -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),-                         [IORef (Maybe (EventTrigger Spider a))])+           -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)+                                , [IORef (Maybe (EventTrigger Spider a))]+                                ) setupMerge num = do-  (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef-  let !m = DM.fromList [WrapArg (Const2 i) :=> v | (i,v) <- zip [0..] evs]+  (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef+  let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]   pure (merge m, triggers) -subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)+subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b) subscribePair (ev, b) = (,b) <$> subscribeEvent ev -fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b-            -> SpiderHost (Maybe b)+fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b+            -> SpiderHost Global (Maybe b) fireAndRead trigger val subd = do-  Just key <- liftIO $ readIORef trigger-  fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence+  key <- fromJust <$> liftIO (readIORef trigger)+  fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
+ bench/RunAll.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Criterion.Main+import Criterion.Types++import Reflex+import Reflex.Host.Class++import Reflex.Plan.Reflex+import Reflex.TestPlan++import qualified Reflex.Bench.Focused as Focused+import Reflex.Spider.Internal (SpiderEventHandle)++import Control.Applicative+import Control.DeepSeq (NFData (..))++import Prelude+import System.IO+import System.Mem++import Control.Arrow+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Data.Bool+import Data.Function+import Data.Int+import Data.IORef+import Data.Monoid+import Data.Time.Clock+import Debug.Trace.LocationTH+import GHC.Stats+import System.Environment+import System.Mem.Weak+import System.Process+import Text.Read++import Unsafe.Coerce++import Data.Map (Map)+import qualified Data.Map as Map++type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))+++setupFiring ::   (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (EventHandle t a, Schedule t)+setupFiring p = do+  (e, s) <- runPlan p+  h <- subscribeEvent e+  return (h, s)++-- Hack to avoid the NFData constraint for EventHandle which is a synonym+newtype Ignore a = Ignore a+instance NFData (Ignore a) where+  rnf !_ = ()++instance NFData (SpiderEventHandle x a) where+  rnf !_ = ()++instance NFData (Behavior t a) where+  rnf !_ = ()++instance NFData (Firing t) where+  rnf !_ = ()++-- Measure the running time+benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO ()+benchFiring runHost tc n = runHost $ do+  let runIterations :: m a -> m ()+      runIterations test = replicateM_ (10*n) $ do+        result <- test+        liftIO $ evaluate result+  case tc of+    TestE p -> do+      (h, s) <- setupFiring p+      runIterations $ readSchedule_ s $ readEvent' h+    TestB p -> do+      (b, s) <- runPlan p+      runIterations $ readSchedule_ (makeDense s) $ sample b++waitForFinalizers :: IO ()+waitForFinalizers = do+  performGC+  x <- getCurrentTime+  isFinalized <- newIORef False+  mkWeakPtr x $ Just $ writeIORef isFinalized True+  performGC+  fix $ \loop -> do+    f <- readIORef isFinalized+    unless f $ do+      threadDelay 1+      loop++benchmarks :: [(String, Int -> IO ())]+benchmarks = implGroup "spider" runSpiderHost cases+  where+    implGroup :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> [(String, TestCase)] -> [(String, Int -> IO ())]+    implGroup name runHost = group name . fmap (second (benchFiring runHost))+    group name = fmap $ first ((name <> "/") <>)+    sub n frames = group ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames+    firing n     = group ("firing "    <> show n) $ Focused.firing n+    merging n    = group ("merging "   <> show n) $ Focused.merging n+    dynamics n   = group ("dynamics "  <> show n) $ Focused.dynamics n+    shared w     = group ("sharedInvalidators " <> show w) $ Focused.sharedInvalidators w+    cases = concat+      [ sub 100 40+      , dynamics 100+      , dynamics 1000+      , firing 1000+      , firing 10000+      , merging 10+      , merging 50+      , merging 100+      , merging 200+      , shared 30+      , shared 100+      , shared 300+      , shared 1000+      ]++pattern RunTestCaseFlag = "--run-test-case"++spawnBenchmark :: String -> Benchmark+spawnBenchmark name = bench name . toBenchmarkable $ \n -> do+  self <- getExecutablePath+  callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]++foreign import ccall unsafe "myCapabilityHasOtherRunnableThreads" myCapabilityHasOtherRunnableThreads :: IO Bool++main :: IO ()+main = do+  args <- getArgs+  case args of+    RunTestCaseFlag : t -> case t of+      [name, readMaybe -> Just count] -> do+        case lookup name benchmarks of+          Just testCase -> testCase count+        performGC+        fix $ \loop -> bool (return ()) (yield >> loop) =<< myCapabilityHasOtherRunnableThreads+        return ()+      _ -> $failure "--run-test-case: expected test name and iteration count to follow"+    _ -> defaultMainWith (defaultConfig { timeLimit = 20, csvFile = Just "dmap-original.csv", reportFile = Just "report.html" }) $ fmap (spawnBenchmark . fst) benchmarks
reflex.cabal view
@@ -1,84 +1,523 @@-Name: reflex-Version: 0.3.2-Synopsis: Higher-order Functional Reactive Programming-Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system-License: BSD3-License-file: LICENSE-Author: Ryan Trinkle-Maintainer: ryan.trinkle@gmail.com-Stability: Experimental-Category: FRP-Build-type: Simple-Cabal-version: >=1.9.2-homepage: https://github.com/ryantrinkle/reflex-bug-reports: https://github.com/ryantrinkle/reflex/issues+cabal-version:      1.22+name:               reflex+version:            0.9.4.1+license:            BSD3+license-file:       LICENSE+maintainer:         ryan.trinkle@gmail.com+author:             Ryan Trinkle+stability:          Experimental+tested-with:+    ghc ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.5 || ==9.6.1 || ==9.8.2 || ==9.10.1 || ==9.12.2 +homepage:           https://reflex-frp.org+bug-reports:        https://github.com/reflex-frp/reflex/issues+synopsis:           Higher-order Functional Reactive Programming+description:+    Interactive programs without callbacks or side-effects.+    Functional Reactive Programming (FRP) uses composable events and time-varying+    values to describe interactive systems as pure functions.+    Just like other pure functional code, functional reactive code is easier+    to get right on the first try, maintain, and reuse.+    .+    Reflex is a fully-deterministic, higher-order Functional Reactive Programming+    interface and an engine that efficiently implements that interface.+    .+    <https://reflex-frp.org>++category:           FRP+build-type:         Simple+extra-source-files:+    README.md+    Quickref.md+    ChangeLog.md++source-repository head+    type:     git+    location: https://github.com/reflex-frp/reflex++flag debug-trace-events+    description:+        Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!++    default:     False+    manual:      True++flag fast-weak+    description:+        Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default++    default:     False+    manual:      True++flag debug-propagation+    description: Enable debugging of spider internals+    default:     False+    manual:      True++flag debug-cycles+    description: Enable debugging of event cycles+    default:     False+    manual:      True++flag split-these+    description: Use split these/semialign packages+    manual:      False+    default:     True+ library-  hs-source-dirs: src-  build-depends:-    base >= 4.7 && < 4.9,-    dependent-sum == 0.2.*,-    dependent-map == 0.1.*,-    semigroups >= 0.16 && < 0.18,-    mtl >= 2.1 && < 2.3,-    containers == 0.5.*,-    these >= 0.4 && < 0.7,-    primitive >= 0.5 && < 0.7,-    template-haskell >= 2.9 && < 2.11,-    ref-tf == 0.4.*,-    exception-transformers == 0.4.*,-    transformers >= 0.2,-    transformers-compat >= 0.3,-    haskell-src-exts == 1.16.*,-    haskell-src-meta == 0.6.*,-    syb == 0.5.*+    exposed-modules:+        Control.Monad.ReaderIO+        Data.AppendMap+        Data.FastMutableIntMap+        Data.FastWeakBag+        Data.Map.Misc+        Data.WeakBag+        Reflex+        Reflex.Class+        Reflex.Adjustable.Class+        Reflex.BehaviorWriter.Base+        Reflex.BehaviorWriter.Class+        Reflex.Collection+        Reflex.Dynamic+        Reflex.Dynamic.TH+        Reflex.Dynamic.Uniq+        Reflex.DynamicWriter+        Reflex.DynamicWriter.Base+        Reflex.DynamicWriter.Class+        Reflex.EventWriter+        Reflex.EventWriter.Base+        Reflex.EventWriter.Class+        Reflex.FastWeak+        Reflex.FunctorMaybe+        Reflex.Host.Class+        Reflex.Host.Headless+        Reflex.Network+        Reflex.NotReady.Class+        Reflex.PerformEvent.Base+        Reflex.PerformEvent.Class+        Reflex.PostBuild.Base+        Reflex.PostBuild.Class+        Reflex.Profiled+        Reflex.Pure+        Reflex.Query.Base+        Reflex.Query.Class+        Reflex.Requester.Base+        Reflex.Requester.Base.Internal+        Reflex.Requester.Class+        Reflex.Spider+        Reflex.Spider.Internal+        Reflex.Time+        Reflex.TriggerEvent.Base+        Reflex.TriggerEvent.Class+        Reflex.Widget.Basic+        Reflex.Workflow -  exposed-modules:-    Reflex,-    Reflex.Spider,-    Reflex.Spider.Internal,-    Reflex.Class,-    Reflex.Dynamic,-    Reflex.Dynamic.TH,-    Reflex.Host.Class,-    Data.Functor.Misc+    reexported-modules:+        patch:Data.Functor.Misc+      , patch:Data.Patch as Reflex.Patch+      , patch:Data.Patch.Class as Reflex.Patch.Class+      , patch:Data.Patch.DMap as Reflex.Patch.DMap+      , patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove+      , patch:Data.Patch.IntMap as Reflex.Patch.IntMap+      , patch:Data.Patch.Map as Reflex.Patch.Map+      , patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove -  other-extensions: TemplateHaskell-  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+    hs-source-dirs:     src+    default-language:   Haskell2010+    ghc-options:+        -Wall -fwarn-redundant-constraints -fwarn-tabs+        -funbox-strict-fields -O2 -fspecialise-aggressively -test-suite cross-impl-  type: exitcode-stdio-1.0-  main-is: Reflex/Test/CrossImpl.hs-  other-modules:-    Reflex.Pure-  ghc-options: -O2 -main-is Reflex.Test.CrossImpl.test-  hs-source-dirs: test-  build-depends:-    base,-    reflex,-    ref-tf,-    mtl,-    containers,-    dependent-map,-    MemoTrie == 0.6.*+    build-depends:+        MemoTrie == 0.6.*+      , base >= 4.11 && < 4.22+      , bifunctors >= 5.2 && < 5.7+      , comonad >= 5.0.4 && < 5.1+      , commutative-semigroups >= 0.1 && <0.3+      , constraints >= 0.10 && <0.15+      , constraints-extras >= 0.3 && < 0.5+      , containers >= 0.6 && < 0.8+      , data-default >= 0.5 && < 0.9+      , dependent-map >= 0.3 && < 0.5+      , dependent-sum >= 0.6 && < 0.8+      , exceptions >= 0.10 && < 0.11+      , exception-transformers >= 0.4 && < 0.5+      , mmorph >= 1.0 && < 1.3+      , monad-control >= 1.0.1 && < 1.1+      , mtl >= 2.1 && < 2.4+      , patch >= 0.0.7 && < 0.1+      , prim-uniq >= 0.1.0.1 && < 0.3+      , primitive >= 0.5 && < 0.10+      , profunctors >= 5.3 && < 5.7+      , random >= 1.1 && < 1.4+      , ref-tf >= 0.4 && < 0.6+      , reflection == 2.1.*+      , semigroupoids >= 4.0 && < 7+      , stm >= 2.4 && < 2.6+      , syb >= 0.5 && < 0.8+      , time >= 1.4 && < 1.15+      , transformers >= 0.5 && < 0.7+      , unbounded-delays >= 0.1.0.0 && < 0.2+      , witherable >= 0.4 && < 0.6+      , haskell-src-exts >= 1.16 && < 1.24+      , haskell-src-meta >= 0.6 && < 0.9+      , template-haskell >= 2.9 && < 2.24 +    other-extensions:+      TemplateHaskell++    if flag(split-these)+        build-depends:+            these >=1 && <1.3+          , semialign >=1 && <1.4+          , monoidal-containers >=0.6.2.0 && <0.7++    else+        build-depends:+            these >=0.4 && <0.9+          , monoidal-containers ==0.4.0.0++    if flag(debug-trace-events)+        cpp-options:   -DDEBUG_TRACE_EVENTS+        build-depends: bytestring >=0.10.8 && <0.11++    if flag(debug-propagation)+        cpp-options:+            -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION++    if flag(debug-cycles)+        cpp-options: -DDEBUG_CYCLES++    if flag(fast-weak) && impl(ghcjs >=0)+        cpp-options: -DGHCJS_FAST_WEAK++    if impl(ghcjs)+        build-depends: ghcjs-base >=0.2 && <0.3++test-suite semantics+    type:             exitcode-stdio-1.0+    main-is:          semantics.hs+    hs-source-dirs:   test+    other-modules:+        Reflex.Bench.Focused+        Reflex.Plan.Pure+        Reflex.Plan.Reflex+        Reflex.Test+        Reflex.Test.Micro+        Reflex.TestPlan++    default-language: Haskell2010+    ghc-options:      -O2 -Wall -rtsopts+    build-depends:+        base >= 4.11 && < 4.22+      , bifunctors+      , containers+      , deepseq+      , dependent-map+      , dependent-sum+      , mtl+      , ref-tf+      , reflex+      , split+      , transformers++test-suite CrossImpl+    type:             exitcode-stdio-1.0+    main-is:          Reflex/Test/CrossImpl.hs+    hs-source-dirs:   test+    other-modules:+        Reflex.Test+        Reflex.TestPlan+        Reflex.Plan.Reflex+        Reflex.Plan.Pure++    default-language: Haskell2010+    ghc-options:      -O2 -Wall -rtsopts+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , dependent-map+      , dependent-sum+      , deepseq+      , mtl+      , transformers+      , ref-tf+      , reflex++test-suite hlint+    type:             exitcode-stdio-1.0+    main-is:          hlint.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , directory+      , filepath+      , filemanip++    if impl(ghc >=9.6)+        buildable: False++    if impl(ghc <9.2)+        build-depends: hlint (<2.1 || >=2.2.2) && <3.5++    else+        build-depends: hlint >=3.5 && <3.6++    if impl(ghcjs >=0) || arch(javascript)+        buildable: False++test-suite EventWriterT+    type:             exitcode-stdio-1.0+    main-is:          EventWriterT.hs+    hs-source-dirs:   test+    other-modules:    Test.Run+    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , deepseq+      , dependent-map+      , dependent-sum+      , lens+      , mtl+      , these+      , transformers+      , reflex+      , ref-tf++    if flag(split-these)+        build-depends: these-lens++test-suite DebugCycles+    type:             exitcode-stdio-1.0+    main-is:          DebugCycles.hs+    hs-source-dirs:   test+    other-modules:    Test.Run+    default-language: Haskell2010+    ghc-options:      -threaded+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , deepseq+      , dependent-map+      , dependent-sum+      , hspec+      , lens+      , mtl+      , these+      , transformers+      , reflex+      , ref-tf+      , witherable++    if flag(split-these)+        build-depends:+            these-lens+          , semialign++test-suite RequesterT+    type:             exitcode-stdio-1.0+    main-is:          RequesterT.hs+    hs-source-dirs:   test+    other-modules:+        Reflex.TestPlan+        Reflex.Plan.Pure+        Test.Run++    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , constraints+      , constraints-extras+      , containers+      , deepseq+      , dependent-map+      , dependent-sum+      , lens+      , mtl+      , ref-tf+      , reflex+      , text+      , these+      , transformers++    if flag(split-these)+        build-depends: these-lens++test-suite Headless+    type:             exitcode-stdio-1.0+    main-is:          Headless.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , reflex++test-suite Adjustable+    type:             exitcode-stdio-1.0+    main-is:          Adjustable.hs+    hs-source-dirs:   test+    other-modules:    Test.Run+    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , dependent-sum+      , reflex+      , ref-tf+      , these++test-suite QueryT+    type:             exitcode-stdio-1.0+    main-is:          QueryT.hs+    hs-source-dirs:   test+    other-modules:+        Test.Run+        Reflex.TestPlan+        Reflex.Plan.Reflex+        Reflex.Plan.Pure++    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , commutative-semigroups+      , containers+      , dependent-map+      , dependent-sum+      , deepseq+      , lens+      , monoidal-containers+      , mtl+      , patch+      , ref-tf+      , reflex+      , these+      , transformers++    if flag(split-these)+        build-depends:+            semialign+          , these-lens++test-suite GC-Semantics+    type:             exitcode-stdio-1.0+    main-is:          GC.hs+    hs-source-dirs:   test+    other-modules:+        Reflex.Plan.Pure+        Reflex.Plan.Reflex+        Reflex.TestPlan+        Test.Run++    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , dependent-sum+      , dependent-map+      , deepseq+      , mtl+      , patch+      , these+      , transformers+      , reflex+      , ref-tf++    if flag(split-these)+        build-depends: semialign++test-suite rootCleanup+    type:             exitcode-stdio-1.0+    main-is:          rootCleanup.hs+    hs-source-dirs:   test+    other-modules:+        Reflex.Plan.Pure+        Reflex.TestPlan+        Test.Run++    default-language: Haskell2010+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , deepseq+      , dependent-sum+      , mtl+      , reflex+      , ref-tf+      , these++test-suite behaviorLeak+    type:             exitcode-stdio-1.0+    main-is:          behaviorLeak.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -Wall -O2 -rtsopts "-with-rtsopts=-T"+    build-depends:+        base >= 4.11 && < 4.22+      , dependent-sum+      , reflex+      , ref-tf+      , primitive+ benchmark spider-bench-  type: exitcode-stdio-1.0-  hs-source-dirs: bench-  main-is: Main.hs-  ghc-options: -O2 -rtsopts-  build-depends:-    base,-    dependent-sum,-    dependent-map,-    transformers >= 0.3 && < 0.5,-    stm == 2.4.*,-    deepseq >= 1.3 && < 1.5,-    mtl,-    primitive,-    criterion == 1.1.*,-    reflex+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   bench test+    other-modules:+        Reflex.TestPlan+        Reflex.Plan.Reflex+        Reflex.Bench.Focused -source-repository head-  type: git-  location: https://github.com/ryantrinkle/reflex+    default-language: Haskell2010+    ghc-options:      -Wall -O2 -rtsopts+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , criterion+      , deepseq+      , dependent-map+      , dependent-sum+      , ref-tf+      , mtl+      , primitive+      , reflex+      , split+      , stm+      , transformers++    if arch(javascript)+        buildable: False++benchmark saulzar-bench+    type:             exitcode-stdio-1.0+    main-is:          RunAll.hs+    c-sources:        bench-cbits/checkCapability.c+    hs-source-dirs:   bench test+    other-modules:+        Reflex.TestPlan+        Reflex.Plan.Reflex+        Reflex.Bench.Focused++    default-language: Haskell2010+    ghc-options:      -Wall -O2 -rtsopts -threaded+    build-depends:+        base >= 4.11 && < 4.22+      , containers+      , criterion+      , deepseq+      , dependent-map+      , dependent-sum+      , loch-th+      , mtl+      , primitive+      , process+      , ref-tf+      , reflex+      , split+      , stm+      , time+      , transformers++    if arch(javascript)+        buildable: False
+ src/Control/Monad/ReaderIO.hs view
@@ -0,0 +1,54 @@+{-# language RoleAnnotations #-}+{-# language MultiParamTypeClasses #-}+{-# language FlexibleInstances #-}+{-# language CPP #-}++module Control.Monad.ReaderIO+  ( ReaderIO (..)+  ) where++import Control.Monad.Fix+import Control.Monad+import Control.Monad.Reader.Class+import Control.Monad.IO.Class++-- | An approximate clone of @RIO@ from the @rio@ package, but not based on+-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a+-- @nominal@ role, so we can't coerce through it when it's wrapped in some+-- other @data@ type. Ugh.+newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }+type role ReaderIO representational representational++instance Functor (ReaderIO e) where+  fmap = liftM+  {-# INLINE fmap #-}+  a <$ m = m >> pure a+  {-# INLINE (<$) #-}++instance Applicative (ReaderIO e) where+  pure a = ReaderIO $ \_ -> pure a+  {-# INLINE pure #-}+  (<*>) = ap+  {-# INLINE (<*>) #-}+#if MIN_VERSION_base(4,18,0)+  liftA2 = liftM2+  {-# INLINE liftA2 #-}+#endif++instance Monad (ReaderIO e) where+  ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e+  {-# INLINE (>>=) #-}++instance MonadFix (ReaderIO e) where+  mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e+  {-# INLINE mfix #-}++instance MonadIO (ReaderIO e) where+  liftIO m = ReaderIO $ \_ -> m+  {-# INLINE liftIO #-}++instance MonadReader e (ReaderIO e) where+  ask = ReaderIO pure+  {-# INLINE ask #-}+  local f (ReaderIO m) = ReaderIO (m . f)+  {-# INLINE local #-}
+ src/Data/AppendMap.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module:+--   Data.AppendMap+-- Description:+--   Instances and convenience functions for 'Data.Map.Monoidal'. We use+--   monoidal-containers to take advantage of its better monoid instance.+--   'Data.Map' has @mappend = union@, which is left-biased.  'MonoidalMap'+--   has @mappend = unionWith mappend@ instead.+module Data.AppendMap+  ( module Data.AppendMap+  , module Data.Map.Monoidal+  ) where++import Prelude hiding (null)++import Data.Coerce+import Data.Default+import Data.Map (Map)+import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)+import Data.Map.Monoidal+++{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}+-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap'+type AppendMap = MonoidalMap++{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}+-- | A synonym for 'getMonoidalMap'+_unAppendMap :: MonoidalMap k v -> Map k v+_unAppendMap = getMonoidalMap++-- | Pattern synonym for 'MonoidalMap'+pattern AppendMap :: Map k v -> MonoidalMap k v+pattern AppendMap m = MonoidalMap m++-- | Deletes a key, returning 'Nothing' if the result is empty.+nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)+nonEmptyDelete k vs =+  let deleted = delete k vs+  in if null deleted+       then Nothing+       else Just deleted++-- | Like 'mapMaybe' but indicates whether the resulting container is empty+mapMaybeNoNull :: (a -> Maybe b)+               -> MonoidalMap token a+               -> Maybe (MonoidalMap token b)+mapMaybeNoNull f as =+  let bs = mapMaybe f as+  in if null bs+       then Nothing+       else Just bs++-- TODO: Move instances to `Data.Patch`+-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.+showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String+showTree = coerce (Map.showTree :: Map k a -> String)++-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string.+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String+showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)++instance Default (MonoidalMap k a) where+  def = empty
+ src/Data/FastMutableIntMap.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module:+--   Data.FastMutableIntMap+-- Description:+--   A mutable version of 'IntMap'+module Data.FastMutableIntMap+  ( FastMutableIntMap+  , new+  , newEmpty+  , insert+  , isEmpty+  , getFrozenAndClear+  , size+  , applyPatch+  , PatchIntMap (..)+  , traverseIntMapPatchWithKey+  , lookup+  , forIntersectionWithImmutable_+  , for_+  , patchIntMapNewElements+  , patchIntMapNewElementsMap+  , getDeletions+  , toList+  ) where++--TODO: Pure JS version+--TODO: Fast copy to FastIntMap+--TODO: Fast patch type++import Prelude hiding (lookup)++import Control.Monad.IO.Class+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IORef+import Data.Patch.Class+import Data.Patch.IntMap++-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.+-- Operations on 'FastMutableIntMap' run in IO.+newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))++-- | Create a new 'FastMutableIntMap' out of an 'IntMap'+new :: IntMap a -> IO (FastMutableIntMap a)+new m = FastMutableIntMap <$> newIORef m++-- | Create a new empty 'FastMutableIntMap'+newEmpty :: IO (FastMutableIntMap a)+newEmpty = FastMutableIntMap <$> newIORef IntMap.empty++-- | Insert an element into a 'FastMutableIntMap' at the given key+insert :: FastMutableIntMap a -> Int -> a -> IO ()+insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v++-- | Attempt to lookup an element by key in a 'FastMutableIntMap'+lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)+lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r++-- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap'+forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()+forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do+  a <- liftIO $ readIORef r+  traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b++-- | Runs the provided action over the values of a 'FastMutableIntMap'+for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()+for_ (FastMutableIntMap r) f = do+  a <- liftIO $ readIORef r+  traverse_ f a++-- | Checks whether a 'FastMutableIntMap' is empty+isEmpty :: FastMutableIntMap a -> IO Bool+isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r++-- | Retrieves the size of a 'FastMutableIntMap'+size :: FastMutableIntMap a -> IO Int+size (FastMutableIntMap r) = IntMap.size <$> readIORef r++-- | Make an immutable snapshot of the datastructure and clear it+getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)+getFrozenAndClear (FastMutableIntMap r) = do+  result <- readIORef r+  writeIORef r IntMap.empty+  return result++-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'),+-- and returns an 'IntMap' with the modified keys and values.+applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)+applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do+  v <- readIORef r+  writeIORef r $! applyAlways p v+  return $ IntMap.intersection v m++toList :: FastMutableIntMap a -> IO [(Int, a)]+toList (FastMutableIntMap r) = IntMap.toList <$> readIORef r
+ src/Data/FastWeakBag.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+#ifdef GHCJS_FAST_WEAK+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+#endif++-- | This module defines the 'FastWeakBag' type, which represents a mutable+-- collection of items that does not cause the items to be retained in memory.+-- This is useful for situations where a value needs to be inspected or modified+-- if it is still alive, but can be ignored if it is dead.+module Data.FastWeakBag+  ( FastWeakBag+  , FastWeakBagTicket+  , empty+  , isEmpty+  , insert+  , traverse+  , traverse_+  , remove+  -- * Internal functions+  -- These will not always be available.+#ifndef GHCJS_FAST_WEAK+  , _weakBag_children --TODO: Don't export this+#endif+  ) where++import Prelude hiding (traverse)++import Control.Monad+import Control.Monad.IO.Class++#ifdef GHCJS_FAST_WEAK+import GHCJS.Types+import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)+#else+import Control.Exception+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IORef+import System.Mem.Weak+#endif++-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -+-- that is, they can still be garbage-collected.  As long as the @/a/@ values remain+-- alive, the 'FastWeakBag' will continue to refer to them.+#ifdef GHCJS_FAST_WEAK+newtype FastWeakBag a = FastWeakBag JSVal+#else+data FastWeakBag a = FastWeakBag+  { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?+  , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag'+  }+#endif++-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned.  If+-- the caller retains the ticket, the item is guranteed to stay in memory (and+-- thus in the 'FastWeakBag').  The ticket can also be used to remove the item from+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.+#ifdef GHCJS_FAST_WEAK+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal+#else+data FastWeakBagTicket a = FastWeakBagTicket+  { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)+  , _weakBagTicket_item :: {-# NOUNPACK #-} !a+  }+#endif++-- | Insert an item into a 'FastWeakBag'.+{-# INLINE insert #-}+insert :: a -- ^ The item+       -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into+       -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item+                           -- is retained and allows the item to be removed.+#ifdef GHCJS_FAST_WEAK+insert a wb = js_insert (unsafeToRawJSVal a) wb+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)+#else+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do+  a' <- evaluate a+  myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)+  let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())+  wa <- mkWeakPtr a' $ Just cleanup+  atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())+  return $ FastWeakBagTicket+    { _weakBagTicket_weakItem = wa+    , _weakBagTicket_item = a'+    }+#endif++-- | Create an empty 'FastWeakBag'.+{-# INLINE empty #-}+empty :: IO (FastWeakBag a)+#ifdef GHCJS_FAST_WEAK+empty = js_empty+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)+#else+empty = {-# SCC "empty" #-} do+  nextId <- newIORef 1+  children <- newIORef IntMap.empty+  let bag = FastWeakBag+        { _weakBag_nextId = nextId+        , _weakBag_children = children+        }+  return bag+#endif++-- | Check whether a 'FastWeakBag' is empty.+{-# INLINE isEmpty #-}+isEmpty :: FastWeakBag a -> IO Bool+#ifdef GHCJS_FAST_WEAK+isEmpty = js_isEmpty+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time+#else+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)+#endif++{-# INLINE traverse_ #-}+-- | Visit every node in the given list.  If new nodes are appended during the+-- traversal, they will not be visited.  Every live node that was in the list+-- when the traversal began will be visited exactly once; however, no guarantee+-- is made about the order of the traversal.+traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()+#ifdef GHCJS_FAST_WEAK+traverse_ wb f = do+  let go cursor = when (not $ js_isNull cursor) $ do+        val <- liftIO $ js_getTicketValue cursor+        f $ unsafeFromRawJSVal val+        go =<< liftIO (js_getNext (FastWeakBagTicket cursor))+  go =<< liftIO (js_getInitial wb)+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a+#else+traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do+  cs <- liftIO $ readIORef children+  forM_ cs $ \c -> do+    ma <- liftIO $ deRefWeak c+    mapM_ f ma+#endif++{-# DEPRECATED traverse "Use 'traverse_' instead" #-}+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()+traverse = traverse_++-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times+-- on the same 'FastWeakBagTicket'.+{-# INLINE remove #-}+remove :: FastWeakBagTicket a -> IO ()+#ifdef GHCJS_FAST_WEAK+remove = js_remove+foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here+#else+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w+#endif+--TODO: Should 'remove' also drop the reference to the item?++--TODO: can/should we provide a null FastWeakBagTicket?
− src/Data/Functor/Misc.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-}-module Data.Functor.Misc where--import Data.GADT.Compare-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Dependent.Map (DMap, DSum (..))-import qualified Data.Dependent.Map as DMap-import Data.Typeable hiding (Refl)-import Data.These-import Data.Maybe--data WrapArg :: (k -> *) -> (k -> *) -> * -> * where-  WrapArg :: f a -> WrapArg g f (g a)--instance GEq f => GEq (WrapArg g f) where-  geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b--instance GCompare f => GCompare (WrapArg g f) where-  gcompare (WrapArg a) (WrapArg b) = case gcompare a b of-    GLT -> GLT-    GEQ -> GEQ-    GGT -> GGT--data Const2 :: * -> * -> * -> * where-  Const2 :: k -> Const2 k v v-  deriving (Typeable)--instance Eq k => GEq (Const2 k v) where-  geq (Const2 a) (Const2 b) =-    if a == b-    then Just Refl-    else Nothing--instance Ord k => GCompare (Const2 k v) where-  gcompare (Const2 a) (Const2 b) = case compare a b of-    LT -> GLT-    EQ -> GEQ-    GT -> GGT--{-# INLINE sequenceDmap #-}-sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)-sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)--{-# INLINE combineDMapsWithKey #-}-combineDMapsWithKey :: forall f g h i. GCompare f => (forall a. f a -> These (g a) (h a) -> i a) -> DMap (WrapArg g f) -> DMap (WrapArg h f) -> DMap (WrapArg i f)-combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)-  where go :: [DSum (WrapArg g f)] -> [DSum (WrapArg h f)] -> [DSum (WrapArg i f)]-        go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs-        go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs-        go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of-          GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs-          GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'-          GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'--wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)-wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList--rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)-rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList--unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k-unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList--unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k-unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList--mapToDMap :: Map k v -> DMap (Const2 k v)-mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList--mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))-mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList--dmapToMap :: DMap (Const2 k v) -> Map k v-dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList
+ src/Data/Map/Misc.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}++-- | Additional functions for manipulating 'Map's.+module Data.Map.Misc+  (+  -- * Working with Maps+    diffMapNoEq+  , diffMap+  , applyMap+  , mapPartitionEithers+  , applyMapKeysSet+  ) where++import Data.Align+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.These++-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@+-- represents an association only present in @old@ but no longer present in @new@.+--+-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not.+diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)+diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case+  This _ -> Just Nothing+  These _ new -> Just $ Just new+  That new -> Just $ Just new++-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not+-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@.+--+-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between+-- @old@ and @new@ with @Nothing@.+diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)+diffMap olds news = flip Map.mapMaybe (align olds news) $ \case+  This _ -> Just Nothing+  These old new+    | old == new -> Nothing+    | otherwise -> Just $ Just new+  That new -> Just $ Just new++-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.+--+-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'.+applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v+applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)+  where (deletions, insertions) = Map.mapEither maybeToEither patch+        maybeToEither = \case+          Nothing -> Left ()+          Just r -> Right r++-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@+{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-}+mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)+mapPartitionEithers = Map.mapEither id++-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set.+--+-- Equivalent to:+--+-- @+--     applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m)+-- @+--+-- but avoids the intervening @Map@ and needs no values.+applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k+applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)+  where (insertions, deletions) = Map.partition isJust patch+
+ src/Data/WeakBag.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}++-- | This module defines the 'WeakBag' type, which represents a mutable+-- collection of items that does not cause the items to be retained in memory.+-- This is useful for situations where a value needs to be inspected or modified+-- if it is still alive, but can be ignored if it is dead.+module Data.WeakBag+  ( WeakBag+  , WeakBagTicket+  , empty+  , singleton+  , insert+  , traverse+  , traverse_+  , remove+  -- * Internal functions+  -- These will not always be available.+  , _weakBag_children --TODO: Don't export this+  ) where++import Prelude hiding (traverse)++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IORef+import System.Mem.Weak++-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them -+-- that is, they can still be garbage-collected.  As long as the @/a/@ values remain+-- alive, the 'WeakBag' will continue to refer to them.+data WeakBag a = WeakBag+  { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?+  , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ The items referenced by the WeakBag+  }++-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned.  If+-- the caller retains the ticket, the item is guranteed to stay in memory (and+-- thus in the 'WeakBag').  The ticket can also be used to remove the item from+-- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'.+data WeakBagTicket = forall a. WeakBagTicket+  { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)+  , _weakBagTicket_item :: {-# NOUNPACK #-} !a+  }++-- | Insert an item into a 'WeakBag'.+{-# INLINE insert #-}+insert :: a -- ^ The item+       -> WeakBag a -- ^ The 'WeakBag' to insert into+       -> IORef (Weak b) -- ^ An arbitrary value to be used in the following+                         -- callback+       -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed+                       -- (whether automatically by the item being garbage+                       -- collected or manually via 'remove')+       -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item+                           -- is retained and allows the item to be removed.+insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do+  a' <- evaluate a+  wbRef' <- evaluate wbRef+  myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)+  let cleanup = do+        wb <- readIORef wbRef'+        mb <- deRefWeak wb+        forM_ mb $ \b -> do+          csWithoutMe <- atomicModifyIORef children $ \cs ->+            let !csWithoutMe = IntMap.delete myId cs+            in (csWithoutMe, csWithoutMe)+          when (IntMap.null csWithoutMe) $ finalizer b+  wa <- mkWeakPtr a' $ Just cleanup+  atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())+  return $ WeakBagTicket+    { _weakBagTicket_weakItem = wa+    , _weakBagTicket_item = a'+    }++-- | Create an empty 'WeakBag'.+{-# INLINE empty #-}+empty :: IO (WeakBag a)+empty = {-# SCC "empty" #-} do+  nextId <- newIORef 1+  children <- newIORef IntMap.empty+  let bag = WeakBag+        { _weakBag_nextId = nextId+        , _weakBag_children = children+        }+  return bag++-- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with+-- 'empty', then using 'insert'.+{-# INLINE singleton #-}+singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket)+singleton a wbRef finalizer = {-# SCC "singleton" #-} do+  bag <- empty+  ticket <- insert a bag wbRef finalizer+  return (bag, ticket)++{-# INLINE traverse_ #-}+-- | Visit every node in the given list.  If new nodes are appended during the+-- traversal, they will not be visited.  Every live node that was in the list+-- when the traversal began will be visited exactly once; however, no guarantee+-- is made about the order of the traversal.+traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()+traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do+  cs <- liftIO $ readIORef children+  forM_ cs $ \c -> do+    ma <- liftIO $ deRefWeak c+    mapM_ f ma++{-# DEPRECATED traverse "Use 'traverse_' instead" #-}+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()+traverse = traverse_++-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times+-- on the same 'WeakBagTicket'.+{-# INLINE remove #-}+remove :: WeakBagTicket -> IO ()+remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w+--TODO: Should 'remove' also drop the reference to the item?++--TODO: can/should we provide a null WeakBagTicket?
src/Reflex.hs view
@@ -1,10 +1,34 @@-module Reflex ( module Reflex.Class-              , module Reflex.Dynamic-              , module Reflex.Dynamic.TH-              , module Reflex.Spider-              ) where+{-# LANGUAGE CPP #-} -import Reflex.Class-import Reflex.Dynamic-import Reflex.Dynamic.TH-import Reflex.Spider+-- | This module exports all of the commonly-used functionality of Reflex; if+-- you are just getting started with Reflex, this is probably what you want.+module Reflex+  ( module X+  ) where++import Reflex.Class as X+import Reflex.Adjustable.Class as X+import Reflex.BehaviorWriter.Base as X+import Reflex.BehaviorWriter.Class as X+import Reflex.Collection as X+import Reflex.Dynamic as X+import Reflex.EventWriter.Base as X+import Reflex.EventWriter.Class as X+import Reflex.Dynamic.TH as X+import Reflex.Dynamic.Uniq as X+import Reflex.DynamicWriter.Base as X+import Reflex.DynamicWriter.Class as X+import Reflex.NotReady.Class as X+import Reflex.PerformEvent.Base as X+import Reflex.PerformEvent.Class as X+import Reflex.PostBuild.Base as X+import Reflex.PostBuild.Class as X+import Reflex.Profiled as X+import Reflex.Query.Base as X+import Reflex.Query.Class as X+import Reflex.Requester.Base as X+import Reflex.Requester.Class as X+import Reflex.Spider as X+import Reflex.Time as X+import Reflex.TriggerEvent.Base as X+import Reflex.TriggerEvent.Class as X
+ src/Reflex/Adjustable/Class.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:+--   Reflex.Adjustable.Class+-- Description:+--   A class for actions that can be "adjusted" over time based on some 'Event'+--   such that, when observed after the firing of any such 'Event', the result+--   is as though the action was originally run with the 'Event's value.+module Reflex.Adjustable.Class+  (+  -- * The Adjustable typeclass+    Adjustable(..)+  , sequenceDMapWithAdjust+  , sequenceDMapWithAdjustWithMove+  , mapMapWithAdjustWithMove+  -- * Deprecated aliases+  , MonadAdjust+  ) where++import Control.Monad.Identity+import Control.Monad.Reader+import Data.Dependent.Map (DMap)+import Data.GADT.Compare (GCompare(..))+import qualified Data.Dependent.Map as DMap+import Data.Functor.Constant+import Data.Functor.Misc+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Map (Map)++import Reflex.Class+import Data.Patch.DMapWithMove++-- | A 'Monad' that supports adjustment over time.  After an action has been+-- run, if the given events fire, it will adjust itself so that its net effect+-- is as though it had originally been run with the new value.  Note that there+-- is some issue here with persistent side-effects: obviously, IO (and some+-- other side-effects) cannot be undone, so it is up to the instance implementer+-- to determine what the best meaning for this class is in such cases.+class (Reflex t, Monad m) => Adjustable t m | m -> t where+  runWithReplace+    :: m a+    -> Event t (m b)+    -> m (a, Event t b)++  traverseIntMapWithKeyWithAdjust+    :: (IntMap.Key -> v -> m v')+    -> IntMap v+    -> Event t (PatchIntMap v)+    -> m (IntMap v', Event t (PatchIntMap v'))++  traverseDMapWithKeyWithAdjust+    :: GCompare k+    => (forall a. k a -> v a -> m (v' a))+    -> DMap k v+    -> Event t (PatchDMap k v)+    -> m (DMap k v', Event t (PatchDMap k v'))+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $+    traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'+   where+    toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m+    toNodeInfoWithMove = \case+      ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing+      ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing+    fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m+    fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of+      From_Insert v -> Just v+      From_Delete -> Nothing+      From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"++  traverseDMapWithKeyWithAdjustWithMove+    :: GCompare k+    => (forall a. k a -> v a -> m (v' a))+    -> DMap k v+    -> Event t (PatchDMapWithMove k v)+    -> m (DMap k v', Event t (PatchDMapWithMove k v'))++instance Adjustable t m => Adjustable t (ReaderT r m) where+  runWithReplace a0 a' = do+    r <- ask+    lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'+  traverseIntMapWithKeyWithAdjust f dm0 dm' = do+    r <- ask+    lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'+  traverseDMapWithKeyWithAdjust f dm0 dm' = do+    r <- ask+    lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do+    r <- ask+    lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'++-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches+-- to the 'DMap' can add, remove, or update values.+sequenceDMapWithAdjust+  :: (GCompare k, Adjustable t m)+  => DMap k m+  -> Event t (PatchDMap k m)+  -> m (DMap k Identity, Event t (PatchDMap k Identity))+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity++-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches+-- to the 'DMap' can add, remove, update, move, or swap values.+sequenceDMapWithAdjustWithMove+  :: (GCompare k, Adjustable t m)+  => DMap k m+  -> Event t (PatchDMapWithMove k m)+  -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity++-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map'+-- can add, remove, update, move, or swap values.+mapMapWithAdjustWithMove+  :: forall t m k v v'. (Adjustable t m, Ord k)+  => (k -> v -> m v')+  -> Map k v+  -> Event t (PatchMapWithMove k v)+  -> m (Map k v', Event t (PatchMapWithMove k v'))+mapMapWithAdjustWithMove f m0 m' = do+  (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')+  return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')++--------------------------------------------------------------------------------+-- Deprecated functions+--------------------------------------------------------------------------------++{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}+-- | Synonym for 'Adjustable'+type MonadAdjust = Adjustable
+ src/Reflex/BehaviorWriter/Base.hs view
@@ -0,0 +1,219 @@+{-|+Module: Reflex.BehaviorWriter.Base+Description: Implementation of BehaviorWriter+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Reflex.BehaviorWriter.Base+  ( BehaviorWriterT (..)+  , runBehaviorWriterT+  , withBehaviorWriterT+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Morph+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Functor.Misc+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Some (Some)++#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.BehaviorWriter.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Query.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++-- | A basic implementation of 'BehaviorWriter'.+newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }+  -- The list is kept in reverse order+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadTrans+    , MFunctor+    , MonadIO+    , MonadFix+    , MonadAsyncException+    , MonadException+    , MonadCatch+    , MonadThrow+    , MonadMask+    )++-- | Run a 'BehaviorWriterT' action.  The behavior writer output will be provided+-- along with the result of the action.+runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)+runBehaviorWriterT (BehaviorWriterT a) = do+  (result, ws) <- runStateT a []+  return (result, mconcat $ reverse ws)++-- | Map a function over the output of a 'BehaviorWriterT'.+withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)+                   => (w -> w')+                   -> BehaviorWriterT t w m a+                   -> BehaviorWriterT t w' m a+withBehaviorWriterT f dw = do+  (r, d) <- lift $ do+    (r, d) <- runBehaviorWriterT dw+    let d' = fmap f d+    return (r, d')+  tellBehavior d+  return r++deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)+deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)++instance MonadRef m => MonadRef (BehaviorWriterT t w m) where+  type Ref (BehaviorWriterT t w m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where+  atomicModifyRef r = lift . atomicModifyRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where+  newEventWithTrigger = lift . newEventWithTrigger+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where+  tellBehavior w = BehaviorWriterT $ modify (w :)++instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where+  ask = lift ask+  local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a+  reader = lift . reader++instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where+  type Performable (BehaviorWriterT t w m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where+  getPostBuild = lift getPostBuild++instance MonadState s m => MonadState s (BehaviorWriterT t w m) where+  get = lift get+  put = lift . put++instance Requester t m => Requester t (BehaviorWriterT t w m) where+  type Request (BehaviorWriterT t w m) = Request m+  type Response (BehaviorWriterT t w m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where+  tellQueryIncremental = lift . tellQueryIncremental+  askQueryResult = lift askQueryResult+  queryIncremental = lift . queryIncremental++instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where+  runWithReplace a0 a' = do+    (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'+    tellBehavior . join =<< hold (snd result0) (snd <$> result')+    return (fst result0, fst <$> result')+  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust+  traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith++traverseIntMapWithKeyWithAdjustImpl+  :: forall t w v' p p' v m.+     ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)+     , Patch (p' (Behavior t w))+     , Monoid w+     , Reflex t+     , MonadHold t m+     , Functor p+     , p ~ p'+     )+  => (   (IntMap.Key -> v -> m (v', Behavior t w))+      -> IntMap v+      -> Event t (p v)+      -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))+     )+  -> (IntMap.Key -> v -> BehaviorWriterT t w m v')+  -> IntMap v+  -> Event t (p v)+  -> BehaviorWriterT t w m (IntMap v', Event t (p v'))+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do+  (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'+  let liftedResult0 = fmap fst result0+      liftedResult' = fmap (fmap fst) result'+      liftedWritten0 :: IntMap (Behavior t w)+      liftedWritten0 = fmap snd result0+      liftedWritten' = fmap (fmap snd) result'+  i <- holdIncremental liftedWritten0 liftedWritten'+  tellBehavior $ pull $ do+    m <- sample $ currentIncremental i+    mconcat . IntMap.elems <$> traverse sample m+  return (liftedResult0, liftedResult')++newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)++traverseDMapWithKeyWithAdjustImpl+  :: forall t w k v' p p' v m.+     ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)+     , Patch (p' (Some k) (Behavior t w))+     , Monoid w+     , Reflex t+     , MonadHold t m+     )+  => (   (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))+      -> DMap k v+      -> Event t (p k v)+      -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))+     )+  -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')+  -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))+  -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))+  -> DMap k v+  -> Event t (p k v)+  -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do+  (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'+  let getValue (BehaviorWriterTLoweredResult (v, _)) = v+      getWritten (BehaviorWriterTLoweredResult (_, w)) = w+      liftedResult0 = DMap.map getValue result0+      liftedResult' = ffor result' $ mapPatch getValue+      liftedWritten0 :: Map (Some k) (Behavior t w)+      liftedWritten0 = weakenDMapWith getWritten result0+      liftedWritten' = ffor result' $ weakenPatchWith getWritten+  i <- holdIncremental liftedWritten0 liftedWritten'+  tellBehavior $ pull $ do+    m <- sample $ currentIncremental i+    mconcat . Map.elems <$> traverse sample m+  return (liftedResult0, liftedResult')
+ src/Reflex/BehaviorWriter/Class.hs view
@@ -0,0 +1,29 @@+{-|+Module: Reflex.BehaviorWriter.Class+Description: This module defines the 'BehaviorWriter' class+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.BehaviorWriter.Class+  ( MonadBehaviorWriter+  , BehaviorWriter(..)+  ) where++import Control.Monad.Reader (ReaderT, lift)+import Reflex.Class (Behavior)++{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}+-- | Type synonym for 'BehaviorWriter'+type MonadBehaviorWriter = BehaviorWriter++-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'+-- and combines them monoidally to provide a 'Behavior' result.+class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where+  tellBehavior :: Behavior t w -> m ()++instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where+  tellBehavior = lift . tellBehavior
src/Reflex/Class.hs view
@@ -1,370 +1,1695 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, CPP #-}-module Reflex.Class where--import Control.Applicative-import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Control.Monad.Trans.Writer (WriterT())-import Control.Monad.Trans.Except (ExceptT())-import Control.Monad.Trans.Cont (ContT())-import Control.Monad.Trans.RWS (RWST())-import Data.List.NonEmpty (NonEmpty (..))-import Data.These-import Data.Align-import Data.GADT.Compare (GEq (..), (:~:) (..))-import Data.GADT.Show (GShow (..))-import Data.Dependent.Sum (ShowTag (..))-import Data.Map (Map)-import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))-import qualified Data.Dependent.Map as DMap-import Data.Functor.Misc-import Data.Semigroup-import Data.Traversable---- Note: must come last to silence warnings due to AMP on GHC < 7.10-import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)--import Debug.Trace (trace)--class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where-  -- | A container for a value that can change over time.  Behaviors can be sampled at will, but it is not possible to be notified when they change-  data Behavior t :: * -> *-  -- | A stream of occurrences.  During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")-  data Event t :: * -> *-  -- | An Event with no occurrences-  never :: Event t a-  -- | Create a Behavior that always has the given value-  constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of Behaviors doesn't have a negative performance impact-  -- | Create an Event from another Event; the provided function can sample Behaviors and hold Events, and use the results to produce a occurring (Just) or non-occurring (Nothing) result-  push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b-  -- | A monad for doing complex push-based calculations efficiently-  type PushM t :: * -> *-  -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes-  pull :: PullM t a -> Behavior t a-  -- | A monad for doing complex pull-based calculations efficiently-  type PullM t :: * -> *-  -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously-  merge :: GCompare k => DMap (WrapArg (Event t) k) -> Event t (DMap k) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty-  -- | Efficiently fan-out an event to many destinations.  This function should be partially applied, and then the result applied repeatedly to create child events-  fan :: GCompare k => Event t (DMap k) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here?  The combinator is worthless without it-  -- | Create an Event that will occur whenever the currently-selected input Event occurs-  switch :: Behavior t (Event t a) -> Event t a-  -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring-  coincidence :: Event t (Event t a) -> Event t a--class (Applicative m, Monad m) => MonadSample t m | m -> t where-  -- | Get the current value in the Behavior-  sample :: Behavior t a -> m a--class MonadSample t m => MonadHold t m where-  -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs-  hold :: a -> Event t a -> m (Behavior t a)--newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }------------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------instance MonadSample t m => MonadSample t (ReaderT r m) where-  sample = lift . sample--instance MonadHold t m => MonadHold t (ReaderT r m) where-  hold a0 = lift . hold a0--instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where-  sample = lift . sample--instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where-  hold a0 = lift . hold a0--instance MonadSample t m => MonadSample t (StateT s m) where-  sample = lift . sample--instance MonadHold t m => MonadHold t (StateT s m) where-  hold a0 = lift . hold a0--instance MonadSample t m => MonadSample t (ExceptT e m) where-  sample = lift . sample--instance MonadHold t m => MonadHold t (ExceptT e m) where-  hold a0 = lift . hold a0--instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where-  sample = lift . sample--instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where-  hold a0 = lift . hold a0--instance MonadSample t m => MonadSample t (ContT r m) where-  sample = lift . sample--instance MonadHold t m => MonadHold t (ContT r m) where-  hold a0 = lift . hold a0------------------------------------------------------------------------------------- Convenience functions------------------------------------------------------------------------------------- | Create an Event from another Event.--- The provided function can sample 'Behavior's and hold 'Event's.-pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b-pushAlways f = push (liftM Just . f)---- | Flipped version of 'fmap'.-ffor :: Functor f => f a -> (a -> b) -> f b-ffor = flip fmap--instance Reflex t => Functor (Behavior t) where-  fmap f = pull . liftM f . sample--instance Reflex t => Applicative (Behavior t) where-  pure = constant-  f <*> x = pull $ sample f `ap` sample x-  _ *> b = b-  a <* _ = a--instance Reflex t => Monad (Behavior t) where-  a >>= f = pull $ sample a >>= sample . f-  -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail.  Since we can't examine Behaviors other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.-  return = constant-  fail = error "Monad (Behavior t) does not support fail"--instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where-  a <> b = pull $ liftM2 (<>) (sample a) (sample b)-  sconcat = pull . liftM sconcat . mapM sample-#if MIN_VERSION_semigroups(0,17,0)-  stimes n = fmap $ stimes n-#else-  times1p n = fmap $ times1p n-#endif--instance (Reflex t, Monoid a) => Monoid (Behavior t a) where-  mempty = constant mempty-  mappend a b = pull $ liftM2 mappend (sample a) (sample b)-  mconcat = pull . liftM mconcat . mapM sample----TODO: See if there's a better class in the standard libraries already--- | A class for values that combines filtering and mapping using 'Maybe'.-class FunctorMaybe f where-  -- | Combined mapping and filtering function.-  fmapMaybe :: (a -> Maybe b) -> f a -> f b---- | Flipped version of 'fmapMaybe'.-fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b-fforMaybe = flip fmapMaybe---- | Filter 'f a' using the provided predicate.--- Relies on 'fforMaybe'.-ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a-ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing--instance Reflex t => FunctorMaybe (Event t) where-  fmapMaybe f = push $ return . f--instance Reflex t => Functor (Event t) where-  fmap f = fmapMaybe $ Just . f---- | Create a new 'Event' by combining each occurence with the next value--- of the list using the supplied function. If the list runs out of items,--- all subsequent 'Event' occurrences will be ignored.-zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)-zipListWithEvent f l e = do-  rec lb <- hold l eTail-      let eBoth = flip push e $ \o -> do-            l' <- sample lb-            return $ case l' of-              (h : t) -> Just (f h o, t)-              [] -> Nothing-      let eTail = fmap snd eBoth-      lb `seq` eBoth `seq` eTail `seq` return ()-  return $ fmap fst eBoth---- | Replace each occurrence value of the 'Event' with the value of the--- 'Behavior' at the time of that occurrence.-tag :: Reflex t => Behavior t b -> Event t a -> Event t b-tag b = pushAlways $ \_ -> sample b---- | Create a new 'Event' that combines occurences of supplied 'Event'--- with the current value of the 'Behavior'.-attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)-attach = attachWith (,)---- | Create a new 'Event' that occurs when the supplied 'Event' occurs--- by combining it with the current value of the 'Behavior'.-attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c-attachWith f = attachWithMaybe $ \a b -> Just $ f a b---- | Create a new 'Event' by combining each occurence with the current--- value of the 'Behavior'. The occurrence is discarded if the combining function--- returns Nothing-attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c-attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b---- | Alias for 'headE'-onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)-onceE = headE---- | Create a new 'Event' that only occurs on the first occurence of--- the supplied 'Event'.-headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)-headE e = do-  rec be <- hold e $ fmap (const never) e'-      let e' = switch be-      e' `seq` return ()-  return e'---- | Create a new 'Event' that occurs on all but the first occurence--- of the supplied 'Event'.-tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)-tailE e = liftM snd $ headTailE e---- | Create a tuple of two 'Event's with the first one occuring only--- the first time the supplied 'Event' occurs and the second occuring--- on all but the first occurence.-headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)-headTailE e = do-  eHead <- headE e-  be <- hold never $ fmap (const e) eHead-  return (eHead, switch be)---- | Split the supplied 'Event' into two individual 'Event's occuring--- at the same time with the respective values from the tuple.-splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)-splitE e = (fmap fst e, fmap snd e)---- | Print the supplied 'String' and the value of the 'Event' on each--- occurence. This should /only/ be used for debugging.------ Note: As with Debug.Trace.trace, the message will only be printed if--- the 'Event' is actually used.-traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a-traceEvent s = traceEventWith $ \x -> s <> ": " <> show x---- | Print the output of the supplied function on each occurence of--- the 'Event'. This should /only/ be used for debugging.------ Note: As with Debug.Trace.trace, the message will only be printed if--- the 'Event' is actually used.-traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a-traceEventWith f = push $ \x -> trace (f x) $ return $ Just x---- | Tag type for 'Either' to use it as a 'DSum'.-data EitherTag l r a where-  LeftTag :: EitherTag l r l-  RightTag :: EitherTag l r r--instance GEq (EitherTag l r) where-  geq a b = case (a, b) of-    (LeftTag, LeftTag) -> Just Refl-    (RightTag, RightTag) -> Just Refl-    _ -> Nothing--instance GCompare (EitherTag l r) where-  gcompare a b = case (a, b) of-    (LeftTag, LeftTag) -> GEQ-    (LeftTag, RightTag) -> GLT-    (RightTag, LeftTag) -> GGT-    (RightTag, RightTag) -> GEQ--instance GShow (EitherTag l r) where-  gshowsPrec _ a = case a of-    LeftTag -> showString "LeftTag"-    RightTag -> showString "RightTag"--instance (Show l, Show r) => ShowTag (EitherTag l r) where-  showTaggedPrec t n a = case t of-    LeftTag -> showsPrec n a-    RightTag -> showsPrec n a---- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.-eitherToDSum :: Either a b -> DSum (EitherTag a b)-eitherToDSum = \case-  Left a -> LeftTag :=> a-  Right b -> RightTag :=> b---- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.-dsumToEither :: DSum (EitherTag a b) -> Either a b-dsumToEither = \case-  LeftTag :=> a -> Left a-  RightTag :=> b -> Right b---- | Extract the values of a 'DMap' of 'EitherTag's.-dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)-dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of-  (Nothing, Nothing) -> Nothing-  (Just a, Nothing) -> Just $ This a-  (Nothing, Just b) -> Just $ That b-  (Just a, Just b) -> Just $ These a b---- | Create a new 'Event' that occurs if at least one of the supplied--- 'Event's occurs. If both occur at the same time they are combined--- using 'mappend'.-appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a-appendEvents e1 e2 = mergeThese mappend <$> align e1 e2--{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}-sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)-sequenceThese t = case t of-  This ma -> liftM This ma-  These ma mb -> liftM2 These ma mb-  That mb -> liftM That mb--instance (Semigroup a, Reflex t) => Monoid (Event t a) where-  mempty = never-  mappend a b = mconcat [a, b]-  mconcat = fmap sconcat . mergeList---- | Create a new 'Event' that occurs if at least one of the 'Event's--- in the list occurs. If multiple occur at the same time they are--- folded from the left with the given function.-mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a-mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es---- | Create a new 'Event' that occurs if at least one of the 'Event's--- in the list occurs. If multiple occur at the same time the value is--- the value of the leftmost event.-leftmost :: Reflex t => [Event t a] -> Event t a-leftmost = mergeWith const---- | Create a new 'Event' that occurs if at least one of the 'Event's--- in the list occurs and has a list of the values of all 'Event's--- occuring at that time.-mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)-mergeList [] = never-mergeList es = mergeWith (<>) $ map (fmap (:|[])) es---- | Create a new 'Event' combining the map of 'Event's into an--- 'Event' that occurs if at least one of them occurs and has a map of--- values of all 'Event's occuring at that time.-mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)-mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap---- | Split the event into an 'EventSelector' that allows efficient--- selection of the individual 'Event's.-fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)-fanMap = fan . fmap mapToDMap---- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to-switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)-switchPromptly ea0 eea = do-  bea <- hold ea0 eea-  let eLag = switch bea-      eCoincidences = coincidence eea-  return $ leftmost [eCoincidences, eLag]--instance Reflex t => Align (Event t) where-  nil = never-  align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]---- | Create a new 'Event' that only occurs if the supplied 'Event'--- occurs and the 'Behavior' is true at the time of occurence.-gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a-gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing---- | Create a new behavior given a starting behavior and switch to a the---   behvior carried by the event when it fires.-switcher :: (Reflex t, MonadHold t m)-        => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)-switcher b eb = pull . (sample <=< sample) <$> hold b eb+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module:+--   Reflex.Class+-- Description:+--   This module contains the Reflex interface, as well as a variety of+--   convenience functions for working with 'Event's, 'Behavior's, and other+--   signals.+module Reflex.Class+  ( module Data.Patch+    -- * Primitives+  , Reflex (..)+  , mergeInt+  , coerceBehavior+  , coerceEvent+  , coerceDynamic+  , coerceIncremental+  , MonadSample (..)+  , MonadHold (..)+    -- ** 'fan' related types+  , EventSelector (..)+  , EventSelectorG (..)+  , EventSelectorInt (..)+    -- * Convenience functions+  , constDyn+  , pushAlways+    -- ** Combining 'Event's+  , leftmost+  , merge+  , mergeIncremental+  , mergeIncrementalWithMove+  , mergeMap+  , mergeIntMap+  , mergeMapIncremental+  , mergeMapIncrementalWithMove+  , mergeIntMapIncremental+  , coincidencePatchMap+  , coincidencePatchMapWithMove+  , coincidencePatchIntMap+  , mergeList+  , mergeWith+  , difference+  , alignEventWithMaybe+    -- ** Breaking up 'Event's+  , splitE+  , fan+  , fanEither+  , fanThese+  , fanMap+  , dmapToThese+  , EitherTag (..)+  , eitherToDSum+  , dsumToEither+  , factorEvent+  , filterEventKey+    -- ** Collapsing 'Event . Event'+  , switchHold+  , switchHoldPromptly+  , switchHoldPromptOnly+  , switchHoldPromptOnlyIncremental+    -- ** Using 'Event's to sample 'Behavior's+  , tag+  , tagMaybe+  , attach+  , attachWith+  , attachWithMaybe+    -- ** Blocking an 'Event' based on a 'Behavior'+  , gate+    -- ** Combining 'Dynamic's+  , distributeDMapOverDynPure+  , distributeDMapOverDynPureG+  , distributeListOverDyn+  , distributeListOverDynWith+  , zipDyn+  , zipDynWith+    -- ** Accumulating state+  , Accumulator (..)+  , accumDyn+  , accumMDyn+  , accumMaybeDyn+  , accumMaybeMDyn+  , mapAccumDyn+  , mapAccumMDyn+  , mapAccumMaybeDyn+  , mapAccumMaybeMDyn+  , accumB+  , accumMB+  , accumMaybeB+  , accumMaybeMB+  , mapAccumB+  , mapAccumMB+  , mapAccumMaybeB+  , mapAccumMaybeMB+  , mapAccum_+  , mapAccumM_+  , mapAccumMaybe_+  , mapAccumMaybeM_+  , accumIncremental+  , accumMIncremental+  , accumMaybeIncremental+  , accumMaybeMIncremental+  , mapAccumIncremental+  , mapAccumMIncremental+  , mapAccumMaybeIncremental+  , mapAccumMaybeMIncremental+  , zipListWithEvent+  , numberOccurrences+  , numberOccurrencesFrom+  , numberOccurrencesFrom_+  , (<@>)+  , (<@)+  , tailE+  , headTailE+  , takeWhileE+  , takeWhileJustE+  , dropWhileE+  , takeDropWhileJustE+  , switcher+    -- * Debugging functions+  , traceEvent+  , traceEventWith+    -- * Unsafe functions+  , unsafeDynamic+  , unsafeMapIncremental+    -- * 'Filterable' convenience functions+  , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead+  , mapMaybe -- Re-exported for convenience+  , fmapMaybe+  , fforMaybe+  , ffilter+  , filterLeft+  , filterRight+    -- * Miscellaneous convenience functions+  , ffor+  , ffor2+  , ffor3+    -- * Deprecated functions+  , switchPromptly+  , switchPromptOnly+  -- * "Cheap" functions+  , fmapMaybeCheap+  , mapMaybeCheap+  , fmapCheap+  , fforCheap+  , fforMaybeCheap+  , pushAlwaysCheap+  , tagCheap+  , mergeWithCheap+  , mergeWithCheap'+    -- * Slow, but general, implementations+  , slowHeadE+  ) where++#ifdef MIN_VERSION_semialign+import Prelude hiding (zip, zipWith)++#if MIN_VERSION_these(0,8,0)+import Data.These.Combinators (justThese)+#endif+#if MIN_VERSION_semialign(1,1,0)+import Data.Zip (Zip (..), Unzip (..))+#endif+#endif++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.RWS (RWST)+import Control.Monad.Trans.Writer (WriterT)+import Data.Align+import Data.Bifunctor+import Data.Coerce+import Data.Default+import Data.Dependent.Map (DMap)+import Data.Dependent.Sum (DSum (..))+import qualified Data.Dependent.Map as DMap+import Data.Functor.Compose+import Data.Functor.Product+import Data.GADT.Compare (GEq (..), GCompare (..))+import Data.Foldable+import Data.Functor.Bind+import Data.Functor.Misc+import Data.Functor.Plus+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map (Map)+import Data.Semigroup (Semigroup (..))+import Data.Some (Some(Some))+import Data.String+import Data.These+import Data.Type.Coercion+import Data.Type.Equality ((:~:) (..))+import Reflex.FunctorMaybe (FunctorMaybe)+import qualified Reflex.FunctorMaybe+import Data.Patch+import qualified Data.Patch.MapWithMove as PatchMapWithMove+import Witherable (Filterable(..))+import qualified Witherable as W++import Debug.Trace (trace)++-- | The 'Reflex' class contains all the primitive functionality needed for+-- Functional Reactive Programming (FRP).  The @/t/@ type parameter indicates+-- which "timeline" is in use.  Timelines are fully-independent FRP contexts,+-- and the type of the timeline determines the FRP engine to be used.  For most+-- purposes, the 'Reflex.Spider' implementation is recommended.+class ( MonadHold t (PushM t)+      , MonadSample t (PullM t)+      , MonadFix (PushM t)+      , Functor (Dynamic t)+      , Applicative (Dynamic t) -- Necessary for GHC <= 7.8+      , Monad (Dynamic t)+      ) => Reflex t where+  -- | A container for a value that can change over time.  'Behavior's can be+  -- sampled at will, but it is not possible to be notified when they change+  data Behavior t :: Type -> Type+  -- | A stream of occurrences.  During any given frame, an 'Event' is either+  -- occurring or not occurring; if it is occurring, it will contain a value of+  -- the given type (its "occurrence type")+  data Event t :: Type -> Type+  -- | A container for a value that can change over time and allows+  -- notifications on changes.  Basically a combination of a 'Behavior' and an+  -- 'Event', with a rule that the 'Behavior' will change if and only if the+  -- 'Event' fires.+  data Dynamic t :: Type -> Type+  -- | An 'Incremental' is a more general form of  a 'Dynamic'.+  -- Instead of always fully replacing the value, only parts of it can be patched.+  -- This is only needed for performance critical code via `mergeIncremental` to make small+  -- changes to large values.+  data Incremental t :: Type -> Type+  -- | A monad for doing complex push-based calculations efficiently+  type PushM t :: Type -> Type+  -- | A monad for doing complex pull-based calculations efficiently+  type PullM t :: Type -> Type+  -- | An 'Event' with no occurrences+  never :: Event t a+  -- | Create a 'Behavior' that always has the given value+  constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of 'Behavior's doesn't have a negative performance impact+  -- | Create an 'Event' from another 'Event'; the provided function can sample+  -- 'Behavior's and hold 'Event's, and use the results to produce a occurring+  -- (Just) or non-occurring (Nothing) result+  push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b+  -- | Like 'push' but intended for functions that the implementation can consider cheap to compute for performance considerations. WARNING: The function passed to 'pushCheap' may be run multiple times without any caching.+  pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b+  -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be+  -- recomputed whenever any of the read 'Behavior's changes+  pull :: PullM t a -> Behavior t a+  -- | Merge a collection of events; the resulting 'Event' will only occur if at+  -- least one input event is occurring, and will contain all of the input keys+  -- that are occurring simultaneously++   --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty+  mergeG :: GCompare k => (forall a. q a -> Event t (v a))+         -> DMap k q -> Event t (DMap k v)++  -- | Efficiently fan-out an event to many destinations.  You should save the+  -- result in a @let@-binding, and then repeatedly 'selectG' on the result to+  -- create child events+  fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v++  -- | Create an 'Event' that will occur whenever the currently-selected input+  -- 'Event' occurs+  switch :: Behavior t (Event t a) -> Event t a+  -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring.+  --   You maybe looking for '@switchHold@ @never@' instead.+  coincidence :: Event t (Event t a) -> Event t a+  -- | Extract the 'Behavior' of a 'Dynamic'.+  current :: Dynamic t a -> Behavior t a+  -- | Extract the 'Event' of the 'Dynamic'.+  updated :: Dynamic t a -> Event t a+  -- | Create a new 'Dynamic'.  The given 'PullM' must always return the most+  -- recent firing of the given 'Event', if any.+  unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a+  -- | Create a new 'Incremental'.  The given "PullM"'s value must always change+  -- in the same way that the accumulated application of patches would change+  -- that value.+  unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p+  -- | Create a merge whose parents can change over time+  mergeIncrementalG :: GCompare k+    => (forall a. q a -> Event t (v a))+    -> Incremental t (PatchDMap k q)+    -> Event t (DMap k v)+  -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental+  mergeIncrementalWithMoveG :: GCompare k+    => (forall a. q a -> Event t (v a))+    -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)+  -- | Extract the 'Behavior' component of an 'Incremental'+  currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)+  -- | Extract the 'Event' component of an 'Incremental'+  updatedIncremental :: Patch p => Incremental t p -> Event t p+  -- | Convert an 'Incremental' to a 'Dynamic'+  incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)+  -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its+  -- occurrence type+  behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)+  -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its+  -- occurrence type+  eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)+  -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its+  -- occurrence type+  dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)+  -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its+  -- patch target and patch types.+  incrementalCoercion+    :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)+  mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)+  fanInt :: Event t (IntMap a) -> EventSelectorInt t a++-- | Efficiently fan-out an event to many destinations. You should save the+-- result in a @let@-binding, and then repeatedly 'select' on the result to+-- create child events+fan :: forall t k. (Reflex t, GCompare k)+    => Event t (DMap k Identity) -> EventSelector t k+    --TODO: Can we help enforce the partial application discipline here?  The combinator is worthless without it+fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)+  where+    fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a+    fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of+              Coercion -> coerce++--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on+-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple+-- keys simultaneously.+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never++-- | Coerce a 'Behavior' between representationally-equivalent value types+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b+coerceBehavior = coerceWith $ behaviorCoercion Coercion++-- | Coerce an 'Event' between representationally-equivalent occurrence types+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b+coerceEvent = coerceWith $ eventCoercion Coercion++-- | Coerce a 'Dynamic' between representationally-equivalent value types+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b+coerceDynamic = coerceWith $ dynamicCoercion Coercion++-- | Coerce an 'Incremental' between representationally-equivalent value types+coerceIncremental+  :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))+  => Incremental t a -> Incremental t b+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion++-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'.  The 'Behavior'+-- __must__ change when and only when the 'Event' fires, such that the+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';+-- if this is not the case, the resulting 'Dynamic' will behave+-- nondeterministically.+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a+unsafeDynamic = unsafeBuildDynamic . sample++-- | Construct a 'Dynamic' value that never changes+constDyn :: Reflex t => a -> Dynamic t a+constDyn = pure++instance (Reflex t, Default a) => Default (Dynamic t a) where+  def = pure def++-- | 'MonadSample' designates monads that can read the current value of a+-- 'Behavior'.  This includes both 'PullM' and 'PushM'.+class (Applicative m, Monad m) => MonadSample t m | m -> t where+  -- | Get the current value in the 'Behavior'+  sample :: Behavior t a -> m a++-- | 'MonadHold' designates monads that can create new 'Behavior's based on+-- 'Event's; usually this will be 'PushM' or a monad based on it.  'MonadHold'+-- is required to create any stateful computations with Reflex.+class MonadSample t m => MonadHold t m where+  -- | Create a new 'Behavior' whose value will initially be equal to the given+  -- value and will be updated whenever the given 'Event' occurs.  The update+  -- takes effect immediately after the 'Event' occurs; if the occurrence that+  -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample+  -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new+  -- one.+  hold :: a -> Event t a -> m (Behavior t a)+  default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)+  hold v0 = lift . hold v0+  -- | Create a 'Dynamic' value using the given initial value that changes every+  -- time the 'Event' occurs.+  holdDyn :: a -> Event t a -> m (Dynamic t a)+  default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)+  holdDyn v0 = lift . holdDyn v0+  -- | Create an 'Incremental' value using the given initial value that changes+  -- every time the 'Event' occurs.+  holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)+  default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)+  holdIncremental v0 = lift . holdIncremental v0+  buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)+  {-+  default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)+  buildDynamic getV0 = lift . buildDynamic getV0+  -}+  -- | Create a new 'Event' that only occurs only once, on the first occurrence of+  -- the supplied 'Event'.+  headE :: Event t a -> m (Event t a)+  -- | An event which only occurs at the current moment in time, such that:+  --+  -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e+  --+  now :: m (Event t ())+  default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())+  now = lift now++-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',+-- using the combining function to produce a patch.+accumIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> p)+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p)+accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o++-- | Similar to 'accumIncremental' but the combining function runs in 'PushM'+accumMIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> PushM t p)+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p)+accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o++-- | Similar to 'accumIncremental' but allows filtering of updates (by dropping updates when the+-- combining function produces @Nothing@)+accumMaybeIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> Maybe p)+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p)+accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o++-- | Similar to 'accumMaybeMIncremental' but the combining function runs in 'PushM'+accumMaybeMIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> PushM t (Maybe p))+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p)+accumMaybeMIncremental f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample $ currentIncremental d'+            f v o+      d' <- holdIncremental z e'+  return d'++-- | Accumulate an 'Incremental' by folding occurrences of an 'Event'+-- with a function that both accumulates and produces a value to fire+-- as an 'Event'. Returns both the accumulated value and the constructed+-- 'Event'.+mapAccumIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> (p, c))+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p, Event t c)+mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o++-- | Like 'mapAccumIncremental' but the combining function runs in 'PushM'+mapAccumMIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> PushM t (p, c))+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p, Event t c)+mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o++-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' with+-- a function that both optionally accumulates and optionally produces+-- a value to fire as a separate output 'Event'.+-- Note that because 'Nothing's are discarded in both cases, the output+-- 'Event' may fire even though the output 'Incremental' has not changed, and+-- the output 'Incremental' may update even when the output 'Event' is not firing.+mapAccumMaybeIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> (Maybe p, Maybe c))+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p, Event t c)+mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o++-- | Like 'mapAccumMaybeIncremental' but the combining function is a 'PushM' action+mapAccumMaybeMIncremental+  :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+  => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c))+  -> PatchTarget p+  -> Event t b+  -> m (Incremental t p, Event t c)+mapAccumMaybeMIncremental f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample $ currentIncremental d'+            result <- f v o+            return $ case result of+              (Nothing, Nothing) -> Nothing+              _ -> Just result+      d' <- holdIncremental z $ mapMaybe fst e'+  return (d', mapMaybe snd e')++-- | A somewhat slow implementation of 'headE'+slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)+slowHeadE e = do+  rec be <- hold e $ fmapCheap (const never) e'+      let e' = switch be+  return e'++-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a+-- key.  This is much more efficient than filtering for each key with+-- 'mapMaybe'.+newtype EventSelector t k = EventSelector+  { -- | Retrieve the 'Event' for the given key.  The type of the 'Event' is+    -- determined by the type of the key, so this can be used to fan-out+    -- 'Event's whose sub-'Event's have different types.+    --+    -- Using 'EventSelector's and the 'fan' primitive is far more efficient than+    -- (but equivalent to) using 'mapMaybe' to select only the relevant+    -- occurrences of an 'Event'.+    select :: forall a. k a -> Event t a+  }++newtype EventSelectorG t k v = EventSelectorG+  { -- | Retrieve the 'Event' for the given key.  The type of the 'Event' is+    -- determined by the type of the key, so this can be used to fan-out+    -- 'Event's whose sub-'Event's have different types.+    --+    -- Using 'EventSelector's and the 'fan' primitive is far more efficient than+    -- (but equivalent to) using 'mapMaybe' to select only the relevant+    -- occurrences of an 'Event'.+    selectG :: forall a. k a -> Event t (v a)+  }++-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually+-- filtering by key.+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++instance MonadSample t m => MonadSample t (ReaderT r m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (ReaderT r m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where+  sample = lift . sample++instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance MonadSample t m => MonadSample t (StateT s m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (StateT s m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance MonadSample t m => MonadSample t (ExceptT e m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (ExceptT e m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where+  sample = lift . sample++instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++instance MonadSample t m => MonadSample t (ContT r m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (ContT r m) where+  hold a0 = lift . hold a0+  holdDyn a0 = lift . holdDyn a0+  holdIncremental a0 = lift . holdIncremental a0+  buildDynamic a0 = lift . buildDynamic a0+  headE = lift . headE+  now = lift now++--------------------------------------------------------------------------------+-- Convenience functions+--------------------------------------------------------------------------------++-- | Create an 'Event' from another 'Event'.  The provided function can sample+-- 'Behavior's and hold 'Event's.+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b+pushAlways f = push (fmap Just . f)++-- | Flipped version of 'fmap'.+ffor :: Functor f => f a -> (a -> b) -> f b+ffor = flip fmap++-- | Rotated version of 'liftA2'.+ffor2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c+ffor2 a b f = liftA2 f a b++-- | Rotated version of 'liftA3'.+ffor3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d+ffor3 a b c f = liftA3 f a b c++instance Reflex t => Applicative (Behavior t) where+  pure = constant+  f <*> x = pull $ sample f `ap` sample x+  _ *> b = b+  a <* _ = a++instance Reflex t => Apply (Behavior t) where+  (<.>) = (<*>)++instance Reflex t => Bind (Behavior t) where+  (>>-) = (>>=)++instance (Reflex t, Fractional a) => Fractional (Behavior t a) where+  (/) = liftA2 (/)+  fromRational = pure . fromRational+  recip = fmap recip++instance Reflex t => Functor (Behavior t) where+  fmap f = pull . fmap f . sample++instance (Reflex t, IsString a) => IsString (Behavior t a) where+  fromString = pure . fromString++instance Reflex t => Monad (Behavior t) where+  a >>= f = pull $ sample a >>= sample . f+  -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail.  Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.+#if !MIN_VERSION_base(4,13,0)+  fail = error "Monad (Behavior t) does not support fail"+#endif++instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where+  a <> b = pull $ liftM2 (<>) (sample a) (sample b)+  sconcat = pull . fmap sconcat . mapM sample+  stimes n = fmap $ stimes n++instance (Reflex t, Monoid a) => Monoid (Behavior t a) where+  mempty = constant mempty+  mconcat = pull . fmap mconcat . mapM sample++instance (Reflex t, Num a) => Num (Behavior t a) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  abs = fmap abs+  fromInteger = pure . fromInteger+  negate = fmap negate+  signum = fmap signum++instance (Num a, Reflex t) => Num (Dynamic t a) where+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger+  negate = fmap negate+  (-) = liftA2 (-)++-- | Alias for 'mapMaybe'+fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b+fmapMaybe = mapMaybe++-- | Flipped version of 'mapMaybe'.+fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b+fforMaybe = flip mapMaybe++-- | Filter 'f a' using the provided predicate.+ffilter :: Filterable f => (a -> Bool) -> f a -> f a+ffilter = W.filter++-- | Filter 'Left's from 'f (Either a b)' into 'a'.+filterLeft :: Filterable f => f (Either a b) -> f a+filterLeft = mapMaybe (either Just (const Nothing))++-- | Filter 'Right's from 'f (Either a b)' into 'b'.+filterRight :: Filterable f => f (Either a b) -> f b+filterRight = mapMaybe (either (const Nothing) Just)++-- | Left-biased event union (prefers left event on simultaneous+-- occurrence).+instance Reflex t => Alt (Event t) where+  ev1 <!> ev2 = leftmost [ev1, ev2]++-- | 'Event' intersection. Only occurs when both events are co-incident.+instance Reflex t => Apply (Event t) where+  evf <.> evx = mapMaybe f (align evf evx) where+    f (These g a) = Just (g a)+    f _           = Nothing+++-- | 'Event' intersection (convenient interface to 'coincidence').+instance Reflex t => Bind (Event t) where+  evx >>- f = coincidence (f <$> evx)+  join = coincidence++instance Reflex t => Functor (Event t) where+  {-# INLINE fmap #-}+  fmap f = mapMaybe $ Just . f+  {-# INLINE (<$) #-}+  x <$ e = fmapCheap (const x) e++-- TODO Remove this instance+instance Reflex t => FunctorMaybe (Event t) where+  {-# INLINE fmapMaybe #-}+  fmapMaybe = mapMaybe++instance Reflex t => Filterable (Event t) where+  {-# INLINE mapMaybe #-}+  mapMaybe f = push $ return . f++-- | Never: @'zero' = 'never'@.+instance Reflex t => Plus (Event t) where+  zero = never++-- | Replace each occurrence value of the 'Event' with the value of the+-- 'Behavior' at the time of that occurrence.+tag :: Reflex t => Behavior t b -> Event t a -> Event t b+tag b = pushAlways $ \_ -> sample b++-- | Replace each occurrence value of the 'Event' with the value of the+-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if+-- it is 'Nothing', drop the occurrence.+tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b+tagMaybe b = push $ \_ -> sample b++-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the+-- current value of the 'Behavior'.+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)+attach = attachWith (,)++-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by+-- combining it with the current value of the 'Behavior'.+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c+attachWith f = attachWithMaybe $ \a b -> Just $ f a b++-- | Create a new 'Event' by combining each occurrence with the current value of+-- the 'Behavior'. The occurrence is discarded if the combining function returns+-- Nothing+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b++-- | Create a new 'Event' that occurs on all but the first occurrence of the+-- supplied 'Event'.+tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)+tailE e = snd <$> headTailE e++-- | Create a tuple of two 'Event's with the first one occurring only the first+-- time the supplied 'Event' occurs and the second occurring on all but the first+-- occurrence.+headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)+headTailE e = do+  eHead <- headE e+  be <- hold never $ fmap (const e) eHead+  return (eHead, switch be)++-- | Take the streak of occurrences starting at the current time for which the+-- event returns 'True'.+--+-- Starting at the current time, fire all the occurrences of the 'Event' for+-- which the given predicate returns 'True'.  When first 'False' is returned,+-- do not fire, and permanently stop firing, even if 'True' values would have+-- been encountered later.+takeWhileE+  :: forall t m a+  .  (Reflex t, MonadFix m, MonadHold t m)+  => (a -> Bool)+  -> Event t a+  -> m (Event t a)+takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v++-- | Take the streak of occurrences starting at the current time for which the+-- event returns 'Just b'.+--+-- Starting at the current time, fire all the occurrences of the 'Event' for+-- which the given predicate returns 'Just b'.  When first 'Nothing' is returned,+-- do not fire, and permanently stop firing, even if 'Just b' values would have+-- been encountered later.+takeWhileJustE+  :: forall t m a b+  .  (Reflex t, MonadFix m, MonadHold t m)+  => (a -> Maybe b)+  -> Event t a+  -> m (Event t b)+takeWhileJustE f e = do+  rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of+            Nothing -> Left never+            Just b  -> Right b+      eFirstBad <- headE eBad+      e' <- switchHold e eFirstBad+  return eTrue++-- | Drop the streak of occurrences starting at the current time for which the+-- event returns 'True'.+--+-- Starting at the current time, do not fire all the occurrences of the 'Event'+-- for which the given predicate returns 'True'.  When 'False' is first+-- returned, do fire, and permanently continue firing, even if 'True' values+-- would have been encountered later.+dropWhileE+  :: forall t m a+  .  (Reflex t, MonadFix m, MonadHold t m)+  => (a -> Bool)+  -> Event t a+  -> m (Event t a)+dropWhileE f e = snd <$> takeDropWhileJustE (\v -> guard (f v) $> v) e++-- | Both take and drop the streak of occurrences starting at the current time+-- for which the event returns 'Just b'.+--+-- For the left event, starting at the current time, fire all the occurrences+-- of the 'Event' for which the given function returns 'Just b'.  When+-- 'Nothing' is returned, do not fire, and permanently stop firing, even if+-- 'Just b' values would have been encountered later.+--+-- For the right event, do not fire until the first occurrence where the given+-- function returns 'Nothing', and fire that one and all subsequent+-- occurrences. Even if the function would have again returned 'Just b', keep+-- on firing.+takeDropWhileJustE+  :: forall t m a b+  . (Reflex t, MonadFix m, MonadHold t m)+  => (a -> Maybe b)+  -> Event t a+  -> m (Event t b, Event t a)+takeDropWhileJustE f e = do+  rec let (eBad, eGood) = fanEither $ ffor e' $ \a -> case f a of+            Nothing -> Left ()+            Just b  -> Right b+      eFirstBad <- headE eBad+      e' <- switchHold e (never <$ eFirstBad)+  eRest <- switchHoldPromptOnly never (e <$ eFirstBad)+  return (eGood, eRest)++-- | Split the supplied 'Event' into two individual 'Event's occurring at the+-- same time with the respective values from the tuple.+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)+splitE e = (fmap fst e, fmap snd e)++-- | Print the supplied 'String' and the value of the 'Event' on each+-- occurrence. This should /only/ be used for debugging.+--+-- Note: As with Debug.Trace.trace, the message will only be printed if the+-- 'Event' is actually used.+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x++-- | Print the output of the supplied function on each occurrence of the+-- 'Event'. This should /only/ be used for debugging.+--+-- Note: As with Debug.Trace.trace, the message will only be printed if the+-- 'Event' is actually used.+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x++instance (Semigroup a, Reflex t) => Semigroup (Event t a) where+  (<>) = alignWith (mergeThese (<>))+  sconcat = fmap sconcat . mergeList . toList+  stimes n = fmap $ stimes n++instance (Semigroup a, Reflex t) => Monoid (Event t a) where+  mempty = never+  mappend = (<>)+  mconcat = fmap sconcat . mergeList++-- | Create a new 'Event' that occurs if at least one of the 'Event's in the+-- list occurs. If multiple occur at the same time they are folded from the left+-- with the given function.+{-# INLINE mergeWith #-}+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a+mergeWith = mergeWith' id++{-# INLINE mergeWith' #-}+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)+                  . mergeInt+                  . IntMap.fromDistinctAscList+                  $ zip [0 :: Int ..] es++-- | Create a new 'Event' that occurs if at least one of the 'Event's in the+-- list occurs. If multiple occur at the same time the value is the value of the+-- leftmost event.+{-# INLINE leftmost #-}+leftmost :: Reflex t => [Event t a] -> Event t a+leftmost = mergeWith const++-- | Create a new 'Event' that occurs if at least one of the 'Event's in the+-- list occurs and has a list of the values of all 'Event's occurring at that+-- time.+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)+mergeList [] = never+mergeList es = mergeWithFoldCheap' id es++unsafeMapIncremental+  :: (Reflex t, Patch p, Patch p')+  => (PatchTarget p -> PatchTarget p')+  -> (p -> p')+  -> Incremental t p+  -> Incremental t p'+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a++-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that+-- occurs if at least one of them occurs and has a map of values of all 'Event's+-- occurring at that time.+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap++-- | Like 'mergeMap' but for 'IntMap'.+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap++-- | Create a merge whose parents can change over time+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)++-- | Create a merge whose parents can change over time+mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)+mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id)++-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)++-- | Split the event into separate events for 'Left' and 'Right' values.+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)+fanEither e =+  let justLeft = either Just (const Nothing)+      justRight = either (const Nothing) Just+  in (mapMaybe justLeft e, mapMaybe justRight e)++-- | Split the event into separate events for 'This' and 'That' values,+-- allowing them to fire simultaneously when the input value is 'These'.+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)+fanThese e =+  let this (This x) = Just x+      this (These x _) = Just x+      this _ = Nothing+      that (That y) = Just y+      that (These _ y) = Just y+      that _ = Nothing+  in (mapMaybe this e, mapMaybe that e)++-- | Split the event into an 'EventSelector' that allows efficient selection of+-- the individual 'Event's.+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)+fanMap = fan . fmap mapToDMap++-- | Switches to the new event whenever it receives one. Only the old event is+-- considered the moment a new one is switched in; the output event will fire at+-- that moment only if the old event does.+--+-- Because the simultaneous firing case is irrelevant, this function imposes+-- laxer "timing requirements" on the overall circuit, avoiding many potential+-- cyclic dependency / metastability failures. It's also more performant. Use+-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you+-- are absolutely sure you need to act on the new event in the coincidental+-- case.+switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchHold ea0 eea = switch <$> hold ea0 eea++-- | Switches to the new event whenever it receives one. Whenever a new event is+-- provided, if it is firing, its value will be the resulting event's value; if+-- it is not firing, but the old one is, the old one's value will be used.+--+-- 'switchHold', by always forwarding the old event the moment it is switched+-- out, avoids many potential cyclic dependency problems / metastability+-- problems. It's also more performant. Use it instead unless you are sure you+-- cannot.+switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchHoldPromptly ea0 eea = do+  bea <- hold ea0 eea+  let eLag = switch bea+      eCoincidences = coincidence eea+  return $ leftmost [eCoincidences, eLag]++-- | switches to a new event whenever it receives one.  At the moment of+-- switching, the old event will be ignored if it fires, and the new one will be+-- used if it fires; this is the opposite of 'switch', which will use only the+-- old value.+--+-- 'switchHold', by always forwarding the old event the moment it is switched+-- out, avoids many potential cyclic dependency problems / metastability+-- problems. It's also more performant. Use it instead unless you are sure you+-- cannot.+switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchHoldPromptOnly e0 e' = do+  eLag <- switch <$> hold e0 e'+  return $ coincidence $ leftmost [e', eLag <$ eLag]++-- | When the given outer event fires, condense the inner events into the contained patch.  Non-firing inner events will be replaced with deletions.+coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case+  Nothing -> fmapCheap (const Nothing) e+  Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]++-- | See 'coincidencePatchMap'+coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case+  Nothing -> fmapCheap (const Nothing) e+  Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]++-- | See 'coincidencePatchMap'+coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of+  PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->+    ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }+  PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->+    ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }+  PatchMapWithMove.From_Insert ev -> leftmost+    [ fforCheap ev $ \v ->+        ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }+    , fforCheap e $ \_ ->+        ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }+    ]++-- | Given a 'PatchTarget' of events (e.g., a 'Map' with 'Event' values) and an event of 'Patch'es+-- (e.g., a 'PatchMap' with 'Event' values), produce an 'Event' of the 'PatchTarget' type that+-- fires with the patched value.+switchHoldPromptOnlyIncremental+  :: forall t m p pt w+  .  ( Reflex t+     , MonadHold t m+     , Patch (p (Event t w))+     , PatchTarget (p (Event t w)) ~ pt (Event t w)+     , Patch (p w)+     , PatchTarget (p w) ~ pt w+     , Monoid (pt w)+     )+  => (Incremental t (p (Event t w)) -> Event t (pt w))+  -> (Event t (p (Event t w)) -> Event t (p w))+  -> pt (Event t w)+  -> Event t (p (Event t w))+  -> m (Event t (pt w))+switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do+  lag <- mergePatchIncremental <$> holdIncremental e0 e'+  pure $ ffor (align lag (coincidencePatch e')) $ \case+    This old -> old+    That new -> new `applyAlways` mempty+    These old new -> new `applyAlways` old++instance Reflex t => Align (Event t) where+  nil = never+#if MIN_VERSION_these(0, 8, 0)+instance Reflex t => Semialign (Event t) where+#endif+  align = alignEventWithMaybe Just++#ifdef MIN_VERSION_semialign+#if MIN_VERSION_semialign(1,1,0)+instance Reflex t => Zip (Event t) where+#endif+  zip x y = mapMaybe justThese $ align x y+#endif++#ifdef MIN_VERSION_semialign+#if MIN_VERSION_semialign(1,1,0)+instance Reflex t => Unzip (Event t) where+  unzip = splitE+#endif+#endif++-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and+-- the 'Behavior' is true at the time of occurrence.+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing++-- | Create a new behavior given a starting behavior and switch to the behavior+-- carried by the event when it fires.+switcher :: (Reflex t, MonadHold t m)+        => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)+switcher b eb = pull . (sample <=< sample) <$> hold b eb++instance (Reflex t, IsString a) => IsString (Dynamic t a) where+  fromString = pure . fromString++-- | Combine two 'Dynamic's.  The result will change whenever either (or both)+-- input 'Dynamic' changes.  Equivalent to @zipDynWith (,)@.+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)+zipDyn = zipDynWith (,)++-- | Combine two 'Dynamic's with a combining function.  The result will change+-- whenever either (or both) input 'Dynamic' changes.+-- More efficient than 'liftA2'.+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c+zipDynWith f da db =+  let eab = align (updated da) (updated db)+      ec = flip push eab $ \o -> do+        (a, b) <- case o of+          This a -> do+            b <- sample $ current db+            return (a, b)+          That b -> do+            a <- sample $ current da+            return (a, b)+          These a b -> return (a, b)+        return $ Just $ f a b+  in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec++instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where+  (<>) = zipDynWith (<>)+  stimes n = fmap $ stimes n++instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where+  mconcat = distributeListOverDynWith mconcat+  mempty = constDyn mempty++-- | This function converts a 'DMap' whose elements are 'Dynamic's into a+-- 'Dynamic' 'DMap'.  Its implementation is more efficient than doing the same+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic++-- | This function converts a 'DMap' whose elements are 'Dynamic's into a+-- 'Dynamic' 'DMap'.  Its implementation is more efficient than doing the same+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.+distributeDMapOverDynPureG+  :: forall t k q v. (Reflex t, GCompare k)+  => (forall a. q a -> Dynamic t (v a))+  -> DMap k q -> Dynamic t (DMap k v)+distributeDMapOverDynPureG nt dm = case DMap.toList dm of+  [] -> constDyn DMap.empty+  [k :=> v] -> DMap.singleton k <$> nt v+  _ ->+    let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm+        edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm+        result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do+          olds <- sample $ current result+          return $ DMap.unionWithKey (\_ _ new -> new) olds news+    in result++-- | Convert a list of 'Dynamic's into a 'Dynamic' list.+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]+distributeListOverDyn = distributeListOverDynWith id++-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b+distributeListOverDynWith f =+  fmap (f . map fromDSum . DMap.toAscList) .+  distributeDMapOverDynPure .+  DMap.fromDistinctAscList .+  zipWith toDSum [0..]+  where+    toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)+    toDSum k v = Const2 k :=> v+    fromDSum :: DSum (Const2 Int a) Identity -> a+    fromDSum (Const2 _ :=> Identity v) = v++-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs+-- unless the second supplied 'Event' occurs simultaneously.+difference :: Reflex t => Event t a -> Event t b -> Event t a+difference = alignEventWithMaybe $ \case+  This a -> Just a+  _ -> Nothing++-- | Zips two values by taking the union of their shapes and combining with the provided function.+-- 'Nothing' values are dropped.+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c+alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $+  merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]++-- | Produces an 'Event' that fires only when the input event fires with a 'DSum' key that+-- matches the provided key.+filterEventKey+  :: forall t m k v a.+     ( Reflex t+     , MonadFix m+     , MonadHold t m+     , GEq k+     )+  => k a+  -> Event t (DSum k v)+  -> m (Event t (v a))+filterEventKey k kv' = do+  let f :: DSum k v -> Maybe (v a)+      f (newK :=> newV) = case newK `geq` k of+        Just Refl -> Just newV+        Nothing -> Nothing+  takeWhileJustE f kv'++-- | "Factor" the input 'DSum' 'Event' to produce an 'Event' which+-- fires when the 'DSum' key changes and contains both the value of the+-- 'DSum' at switchover and an 'Event' of values produced by subsequent+-- firings of the input 'Event' that do not change the 'DSum' key.+factorEvent+  :: forall t m k v a.+     ( Reflex t+     , MonadFix m+     , MonadHold t m+     , GEq k+     )+  => k a+  -> Event t (DSum k v)+  -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))+factorEvent k0 kv' = do+  key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv'+  let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case+        Some oldKey -> case newKey `geq` oldKey of+          Just Refl -> return Nothing+          Nothing -> do+            newInner <- filterEventKey newKey kv'+            return $ Just $ newKey :=> Pair newVal (Compose newInner)+  eInitial <- filterEventKey k0 kv'+  return (eInitial, update)++--------------------------------------------------------------------------------+-- Accumulator+--------------------------------------------------------------------------------++-- | An 'Accumulator' type can be built by accumulating occurrences of an+-- 'Event'.+#if __GLASGOW_HASKELL__ < 802+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}+#endif+class Reflex t => Accumulator t f | f -> t where+  accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)+  accum f = accumMaybe $ \v o -> Just $ f v o+  accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)+  accumM f = accumMaybeM $ \v o -> Just <$> f v o+  accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)+  accumMaybe f = accumMaybeM $ \v o -> return $ f v o+  accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)+  mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)+  mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o+  mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)+  mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o+  mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)+  mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o+  mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'+-- with the provided function. See 'foldDyn'.+accumDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> a)+  -> a+  -> Event t b+  -> m (Dynamic t a)+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'+-- with the provided 'PushM' action.+accumMDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t a)+  -> a+  -> Event t b+  -> m (Dynamic t a)+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'+-- with the provided function, discarding 'Nothing' results.+accumMaybeDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> Maybe a)+  -> a+  -> Event t b+  -> m (Dynamic t a)+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'+-- with the provided 'PushM' action, discarding 'Nothing' results.+accumMaybeMDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t (Maybe a))+  -> a+  -> Event t b+  -> m (Dynamic t a)+accumMaybeMDyn f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample $ current d'+            f v o+      d' <- holdDyn z e'+  return d'++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'+-- with a function that both accumulates and produces a value to fire+-- as an 'Event'. Returns both the accumulated value and an 'Event'.+mapAccumDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> (a, c))+  -> a+  -> Event t b+  -> m (Dynamic t a, Event t c)+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o++-- | Similar to 'mapAccumDyn' except that the combining function is a+-- 'PushM' action.+mapAccumMDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t (a, c))+  -> a+  -> Event t b+  -> m (Dynamic t a, Event t c)+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o++-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' with+-- a function that both optionally accumulates and optionally produces+-- a value to fire as a separate output 'Event'.+-- Note that because 'Nothing's are discarded in both cases, the output+-- 'Event' may fire even though the output 'Dynamic' has not changed, and+-- the output 'Dynamic' may update even when the output 'Event' is not firing.+mapAccumMaybeDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> (Maybe a, Maybe c))+  -> a+  -> Event t b+  -> m (Dynamic t a, Event t c)+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o++-- | Like 'mapAccumMaybeDyn' except that the combining function is a+-- 'PushM' action.+mapAccumMaybeMDyn+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t (Maybe a, Maybe c))+  -> a+  -> Event t b+  -> m (Dynamic t a, Event t c)+mapAccumMaybeMDyn f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample $ current d'+            result <- f v o+            return $ case result of+              (Nothing, Nothing) -> Nothing+              _ -> Just result+      d' <- holdDyn z $ mapMaybe fst e'+  return (d', mapMaybe snd e')++-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'+-- with the provided function.+{-# INLINE accumB #-}+accumB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> a)+  -> a+  -> Event t b+  -> m (Behavior t a)+accumB f = accumMaybeB $ \v o -> Just $ f v o++-- | Like 'accumB' except that the combining function is a 'PushM' action.+{-# INLINE accumMB #-}+accumMB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t a)+  -> a+  -> Event t b+  -> m (Behavior t a)+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o++-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'+-- with the provided function, discarding 'Nothing' results.+{-# INLINE accumMaybeB #-}+accumMaybeB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> Maybe a)+  -> a+  -> Event t b+  -> m (Behavior t a)+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o++-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action.+{-# INLINE accumMaybeMB #-}+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)+accumMaybeMB f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample d'+            f v o+      d' <- hold z e'+  return d'++-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'+-- with a function that both accumulates and produces a value to fire+-- as an 'Event'. Returns both the accumulated value and an 'Event'.+{-# INLINE mapAccumB #-}+mapAccumB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> (a, c))+  -> a+  -> Event t b+  -> m (Behavior t a, Event t c)+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o++-- | Like 'mapAccumB' except that the combining function is a 'PushM' action.+{-# INLINE mapAccumMB #-}+mapAccumMB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> PushM t (a, c))+  -> a+  -> Event t b+  -> m (Behavior t a, Event t c)+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o++-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' with+-- a function that both optionally accumulates and optionally produces+-- a value to fire as a separate output 'Event'. 'Nothing's are discarded.+{-# INLINE mapAccumMaybeB #-}+mapAccumMaybeB+  :: (Reflex t, MonadHold t m, MonadFix m)+  => (a -> b -> (Maybe a, Maybe c))+  -> a+  -> Event t b+  -> m (Behavior t a, Event t c)+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o++-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action.+{-# INLINE mapAccumMaybeMB #-}+mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)+mapAccumMaybeMB f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample d'+            result <- f v o+            return $ case result of+              (Nothing, Nothing) -> Nothing+              _ -> Just result+      d' <- hold z $ mapMaybe fst e'+  return (d', mapMaybe snd e')++-- | Accumulate occurrences of an 'Event', producing an output occurrence each+-- time.  Discard the underlying 'Accumulator'.+{-# INLINE mapAccum_ #-}+mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)+mapAccum_ f z e = do+  (_, result) <- mapAccumB f z e+  return result++-- | Accumulate occurrences of an 'Event', possibly producing an output+-- occurrence each time.  Discard the underlying 'Accumulator'.+{-# INLINE mapAccumMaybe_ #-}+mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)+mapAccumMaybe_ f z e = do+  (_, result) <- mapAccumMaybeB f z e+  return result++-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing+-- an output occurrence each time.  Discard the underlying 'Accumulator'.+{-# INLINE mapAccumM_ #-}+mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)+mapAccumM_ f z e = do+  (_, result) <- mapAccumMB f z e+  return result++-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly+-- producing an output occurrence each time.  Discard the underlying+-- 'Accumulator'.+{-# INLINE mapAccumMaybeM_ #-}+mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)+mapAccumMaybeM_ f z e = do+  (_, result) <- mapAccumMaybeMB f z e+  return result++instance Reflex t => Accumulator t (Dynamic t) where+  accumMaybeM = accumMaybeMDyn+  mapAccumMaybeM = mapAccumMaybeMDyn++instance Reflex t => Accumulator t (Behavior t) where+  accumMaybeM = accumMaybeMB+  mapAccumMaybeM = mapAccumMaybeMB++instance Reflex t => Accumulator t (Event t) where+  accumMaybeM f z e = updated <$> accumMaybeM f z e+  mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e++-- | Create a new 'Event' by combining each occurrence with the next value of the+-- list using the supplied function. If the list runs out of items, all+-- subsequent 'Event' occurrences will be ignored.+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)+zipListWithEvent f l e = do+  let f' a b = case a of+        h:t -> (Just t, Just $ f h b)+        _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?+  mapAccumMaybe_ f' l e++-- | Assign a number to each occurrence of the given 'Event', starting from 0+{-# INLINE numberOccurrences #-}+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))+numberOccurrences = numberOccurrencesFrom 0++-- | Assign a number to each occurrence of the given 'Event'+{-# INLINE numberOccurrencesFrom #-}+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))+numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))++-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values+{-# INLINE numberOccurrencesFrom_ #-}+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)+numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))++-- | This is used to sample the value of a 'Behavior' using an 'Event'.+--+-- The '<@>' operator is intended to be used in conjunction with+-- the 'Applicative' instance for 'Behavior'.+--+-- This is useful when we want to combine the values of one 'Event' and+-- the value of several 'Behavior's at the time the 'Event' is firing.+--+-- If we have:+--+-- > f  :: a -> b -> c -> d+-- > b1 :: Behavior t a+-- > b2 :: Behavior t b+-- > e  :: Event t c+--+-- then we can do:+--+-- > f <$> b1 <*> b2 <@> e :: Event t d+--+-- in order to apply the function 'f' to the relevant values.+--+-- The alternative would be something like:+--+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d+--+-- or a variation involing a custom data type to hold the combination of+-- 'Behavior's even when that combination might only ever be used by 'f'.+--+-- A more suggestive example might be:+--+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)+--+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b+(<@>) b = push $ \x -> do+  f <- sample b+  return . Just . f $ x+infixl 4 <@>++-- | An version of '<@>' that does not use the value of the 'Event'.+--+-- Alternatively, it is 'tag' in operator form.+--+-- This is useful when we want to combine the values of several+-- 'Behavior's at particular points in time using an 'Applicative'+-- style syntax.+--+-- If we have:+--+-- > g  :: a -> b -> d+-- > b1 :: Behavior t a+-- > b2 :: Behavior t b+-- > e  :: Event t c+--+-- where 'e' is firing at the points in time of interest.+--+-- Then we can use '<@':+--+-- > g <$> b1 <*> b2 <@  e :: Event t d+--+-- to combine the values of 'b1' and 'b2' at each of those points of time,+-- with the function 'g' being used to combine the values.+--+-- This is the same as '<@>' except that the 'Event' is being used only+-- to act as a trigger.+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b+(<@) = tag+infixl 4 <@++------------------+-- Cheap Functions+------------------++-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.+{-# INLINE pushAlwaysCheap #-}+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b+pushAlwaysCheap f = pushCheap (fmap Just . f)++-- | A "cheap" version of 'mapMaybe'. See the performance note on 'pushCheap'.+{-# INLINE mapMaybeCheap #-}+mapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b+mapMaybeCheap f = pushCheap $ return . f++-- | An alias for 'mapMaybeCheap'+{-# INLINE fmapMaybeCheap #-}+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b+fmapMaybeCheap = mapMaybeCheap+++-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.+{-# INLINE fforMaybeCheap #-}+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b+fforMaybeCheap = flip mapMaybeCheap++-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.+{-# INLINE fforCheap #-}+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b+fforCheap = flip fmapCheap++-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.+{-# INLINE fmapCheap #-}+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b+fmapCheap f = pushCheap $ return . Just . f++-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.+{-# INLINE tagCheap #-}+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b+tagCheap b = pushAlwaysCheap $ \_ -> sample b++-- | Merge a collection of events; the resulting 'Event' will only occur if at+-- least one input event is occurring, and will contain all of the input keys+-- that are occurring simultaneously+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)+merge = mergeG coerceEvent+{-# INLINE merge #-}++-- | Create a merge whose parents can change over time+mergeIncremental :: (Reflex t, GCompare k)+  => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)+mergeIncremental = mergeIncrementalG coerceEvent++-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental+mergeIncrementalWithMove :: (Reflex t, GCompare k)+  => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent++-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.+{-# INLINE mergeWithCheap #-}+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a+mergeWithCheap = mergeWithCheap' id++-- | A "cheap" version of 'mergeWithCheap''. See the performance note on 'pushCheap'.+{-# INLINE mergeWithCheap' #-}+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f++-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.+{-# INLINE mergeWithFoldCheap' #-}+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b+mergeWithFoldCheap' f es =+  fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)+  . mergeInt+  . IntMap.fromDistinctAscList+  $ zip [0 :: Int ..] es++--------------------------------------------------------------------------------+-- Deprecated functions+--------------------------------------------------------------------------------++{-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}+-- | See 'switchHoldPromptly'+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchPromptly = switchHoldPromptly+{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}+-- | See 'switchHoldPromptOnly'+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchPromptOnly = switchHoldPromptOnly
+ src/Reflex/Collection.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:+--   Reflex.Collection+module Reflex.Collection+  (+  -- * Widgets on Collections+    listHoldWithKey+  , listWithKey+  , listWithKeyShallowDiff+  , listViewWithKey+  , selectViewListWithKey+  , selectViewListWithKey_+  -- * List Utils+  , list+  , simpleList+  ) where++#ifdef MIN_VERSION_semialign+import Prelude hiding (zip, zipWith)+#if MIN_VERSION_semialign(1,1,0)+import Data.Zip (Zip (..))+#endif+#endif++import Control.Monad+import Control.Monad.Fix+import Data.Align+import Data.Functor.Misc+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Map.Misc+import Data.These++#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Dynamic+import Reflex.PostBuild.Class++-- | Create a set of widgets based on the provided 'Map'. When the+-- input 'Event' fires, remove widgets for keys with the value 'Nothing'+-- and add/replace widgets for keys with 'Just' values.+listHoldWithKey+  :: forall t m k v a+   . (Ord k, Adjustable t m, MonadHold t m)+  => Map k v+  -> Event t (Map k (Maybe v))+  -> (k -> v -> m a)+  -> m (Dynamic t (Map k a))+listHoldWithKey m0 m' f = do+  let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0+      dm' = fmap+        (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey+          (\k v -> ComposeMaybe $ fmap (f k) v)+        )+        m'+  (a0, a') <- sequenceDMapWithAdjust dm0 dm'++  --TODO: Move the dmapToMap to the righthand side so it doesn't get+  --fully redone every time+  fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'++--TODO: Something better than Dynamic t (Map k v) - we want something+--where the Events carry diffs, not the whole value+listWithKey+  :: forall t k v m a+   . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m, Eq v)+  => Dynamic t (Map k v)+  -> (k -> Dynamic t v -> m a)+  -> m (Dynamic t (Map k a))+listWithKey vals mkChild = do+  postBuild <- getPostBuild+  let childValChangedSelector = fanMap $ updated vals++      -- We keep track of changes to children values in the mkChild+      -- function we pass to listHoldWithKey The other changes we need+      -- to keep track of are child insertions and+      -- deletions. diffOnlyKeyChanges keeps track of insertions and+      -- deletions but ignores value changes, since they're already+      -- accounted for.+      diffOnlyKeyChanges olds news =+        flip Map.mapMaybe (align olds news) $ \case+          This _    -> Just Nothing+          These _ _ -> Nothing+          That new  -> Just $ Just new+  rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals+      let changeVals :: Event t (Map k (Maybe v))+          changeVals =+            attachWith diffOnlyKeyChanges (current sentVals) $ leftmost+              [ updated vals++              -- TODO: This should probably be added to the+              -- attachWith, not to the updated; if we were using+              -- diffMap instead of diffMapNoEq, I think it might not+              -- work+              , tag (current vals) postBuild+              ]+  listHoldWithKey Map.empty changeVals $ \k v ->+    mkChild k =<< holdUniqDyn =<< holdDyn v (select childValChangedSelector $ Const2 k)++-- | Display the given map of items (in key order) using the builder+-- function provided, and update it with the given event.  'Nothing'+-- update entries will delete the corresponding children, and 'Just'+-- entries will create them if they do not exist or send an update+-- event to them if they do.+listWithKeyShallowDiff+  :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)+  => Map k v+  -> Event t (Map k (Maybe v))+  -> (k -> v -> Event t v -> m a)+  -> m (Dynamic t (Map k a))+listWithKeyShallowDiff initialVals valsChanged mkChild = do+  let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged+  sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged+  let relevantPatch patch _ = case patch of++        -- Even if we let a Nothing through when the element doesn't+        -- already exist, this doesn't cause a problem because it is+        -- ignored+        Nothing -> Just Nothing++        -- We don't want to let spurious re-creations of items through+        Just _  -> Nothing+  listHoldWithKey+      initialVals+      (attachWith (flip (Map.differenceWith relevantPatch))+                  (current sentVals)+                  valsChanged+      )+    $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k++--TODO: Something better than Dynamic t (Map k v) - we want something+--where the Events carry diffs, not the whole value+-- | Create a dynamically-changing set of Event-valued widgets.  This+--   is like 'listWithKey', specialized for widgets returning @/Event t a/@.+--   'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in+--   this scenario, but 'listViewWithKey' flattens this to+--   @/Event t (Map k a)/@ via 'switch'.+listViewWithKey+  :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v)+  => Dynamic t (Map k v)+  -> (k -> Dynamic t v -> m (Event t a))+  -> m (Event t (Map k a))+listViewWithKey vals mkChild =+  switch . fmap mergeMap <$> listViewWithKey' vals mkChild++listViewWithKey'+  :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v)+  => Dynamic t (Map k v)+  -> (k -> Dynamic t v -> m a)+  -> m (Behavior t (Map k a))+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild++-- | Create a dynamically-changing set of widgets, one of which is+-- selected at any time.+selectViewListWithKey+  :: forall t m k v a+   . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v)+  => Dynamic t k+  -- ^ Current selection key+  -> Dynamic t (Map k v)+  -- ^ Dynamic key/value map+  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))+  -- ^ Function to create a widget for a given key from Dynamic value+  -- and Dynamic Bool indicating if this widget is currently selected+  -> m (Event t (k, a))+  -- ^ Event that fires when any child's return Event fires.  Contains+  -- key of an arbitrary firing widget.+selectViewListWithKey selection vals mkChild = do+  -- For good performance, this value must be shared across all children+  let selectionDemux = demux selection+  selectChild <- listWithKey vals $ \k v -> do+    let selected = demuxed selectionDemux k+    selectSelf <- mkChild k v selected+    return $ fmap ((,) k) selectSelf+  return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild++-- | Like 'selectViewListWithKey' but discards the value of the list+-- item widget's output 'Event'.+selectViewListWithKey_+  :: forall t m k v a+   . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v)+  => Dynamic t k+  -- ^ Current selection key+  -> Dynamic t (Map k v)+  -- ^ Dynamic key/value map+  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))+  -- ^ Function to create a widget for a given key from Dynamic value+  -- and Dynamic Bool indicating if this widget is currently selected+  -> m (Event t k)+  -- ^ Event that fires when any child's return Event fires.  Contains+  -- key of an arbitrary firing widget.+selectViewListWithKey_ selection vals mkChild =+  fmap fst <$> selectViewListWithKey selection vals mkChild++-- | Create a dynamically-changing set of widgets from a Dynamic+--   key/value map.  Unlike the 'withKey' variants, the child widgets+--   are insensitive to which key they're associated with.+list+  :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v)+  => Dynamic t (Map k v)+  -> (Dynamic t v -> m a)+  -> m (Dynamic t (Map k a))+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)++-- | Create a dynamically-changing set of widgets from a Dynamic list.+simpleList+  :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v)+  => Dynamic t [v]+  -> (Dynamic t v -> m a)+  -> m (Dynamic t [a])+simpleList xs mkChild =+  fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap+    (Map.fromList . zip [(1 :: Int) ..])+    xs
src/Reflex/Dynamic.hs view
@@ -1,183 +1,170 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}-module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update-                      , current-                      , updated-                      , constDyn-                      , holdDyn-                      , nubDyn-                      , count-                      , toggle-                      , switchPromptlyDyn-                      , tagDyn-                      , attachDyn-                      , attachDynWith-                      , attachDynWithMaybe-                      , mapDyn-                      , forDyn-                      , mapDynM-                      , foldDyn-                      , foldDynM-                      , foldDynMaybe-                      , foldDynMaybeM-                      , combineDyn-                      , collectDyn-                      , mconcatDyn-                      , distributeDMapOverDyn-                      , joinDyn-                      , joinDynThroughMap-                      , traceDyn-                      , traceDynWith-                      , splitDyn-                      , Demux-                      , demux-                      , getDemuxed-                        -- Things that probably aren't very useful:-                      , HList (..)-                      , FHList (..)-                      , distributeFHListOverDyn-                        -- Unsafe-                      , unsafeDynamic-                      ) where--import Prelude hiding (mapM, mapM_)+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -import Reflex.Class-import Data.Functor.Misc+-- |+-- Module:+--   Reflex.Dynamic+-- Description:+--   This module contains various functions for working with 'Dynamic' values.+--   'Dynamic' and its primitives have been moved to the 'Reflex' class.+module Reflex.Dynamic+  ( -- * Basics+    Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update+  , current+  , updated+  , holdDyn+  , mapDynM+  , forDynM+  , constDyn+  , count+  , toggle+  , switchDyn+  , switchPromptlyDyn+  , tagPromptlyDyn+  , attachPromptlyDyn+  , attachPromptlyDynWith+  , attachPromptlyDynWithMaybe+  , maybeDyn+  , eitherDyn+  , factorDyn+  , scanDyn+  , scanDynMaybe+  , holdUniqDyn+  , holdUniqDynBy+  , improvingMaybe+  , foldDyn+  , foldDynM+  , foldDynMaybe+  , foldDynMaybeM+  , joinDynThroughMap+  , joinDynThroughIntMap+  , traceDyn+  , traceDynWith+  , splitDynPure+  , distributeMapOverDynPure+  , distributeIntMapOverDynPure+  , distributeDMapOverDynPure+  , distributeListOverDynPure+  , Demux+  , demux+  , demuxed+    -- * Miscellaneous+    -- Things that probably aren't very useful:+  , HList (..)+  , FHList (..)+  , collectDynPure+  , RebuildSortedHList (..)+  , IsHList (..)+  , AllAreFunctors (..)+  , HListPtr (..)+  , distributeFHListOverDynPure+    -- * Unsafe+  , unsafeDynamic+  ) where -import Control.Monad hiding (mapM, mapM_, forM, forM_) import Control.Monad.Fix-import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)-import Data.These-import Data.Traversable (mapM, forM)+import Control.Monad.Identity import Data.Align-import Data.Map (Map)-import qualified Data.Map as Map import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..))-import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))-import Data.Monoid---import Data.HList (HList (..), hBuild)--data HList (l::[*]) where-    HNil  :: HList '[]-    HCons :: e -> HList l -> HList (e ': l)--infixr 2 `HCons`--type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]-type instance HRevApp '[] l = l-type instance HRevApp (e ': l) l' = HRevApp l (e ': l')--hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)-hRevApp HNil l = l-hRevApp (HCons x l) l' = hRevApp l (HCons x l')--hReverse :: HList l -> HList (HRevApp l '[])-hReverse l = hRevApp l HNil--hBuild :: (HBuild' '[] r) => r-hBuild =  hBuild' HNil--class HBuild' l r where-    hBuild' :: HList l -> r--instance (l' ~ HRevApp l '[])-      => HBuild' l (HList l') where-  hBuild' l = hReverse l--instance HBuild' (a ': l) r-      => HBuild' l (a->r) where-  hBuild' l x = hBuild' (HCons x l)---- | A container for a value that can change over time and allows notifications on changes.--- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will--- change if and only if the Event fires.-data Dynamic t a-  = Dynamic (Behavior t a) (Event t a)+import Data.Functor.Compose+import Data.Functor.Misc+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))+import Data.IntMap (IntMap)+import Data.Kind (Type)+import Data.Map (Map)+import Data.Maybe+import Data.These+import Data.Type.Equality ((:~:) (..)) -unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a-unsafeDynamic = Dynamic+import Debug.Trace (trace) --- | Extract the 'Behavior' of a 'Dynamic'.-current :: Dynamic t a -> Behavior t a-current (Dynamic b _) = b+#if !MIN_VERSION_base(4,18,0)+import Control.Monad+import Data.Monoid ((<>))+#endif --- | Extract the 'Event' of the 'Dynamic'.-updated :: Dynamic t a -> Event t a-updated (Dynamic _ e) = e+import Reflex.Class --- | 'Dynamic' with the constant supplied value.-constDyn :: Reflex t => a -> Dynamic t a-constDyn x = Dynamic (constant x) never+-- | Map a sampling function over a 'Dynamic'.+mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)+mapDynM f d = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d) --- | Create a 'Dynamic' using the initial value that changes every--- time the 'Event' occurs.-holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)-holdDyn v0 e = do-  b <- hold v0 e-  return $ Dynamic b e+-- | Flipped version of 'mapDynM'+forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b)+forDynM d f = mapDynM f d --- | Create a new 'Dynamic' that only signals changes if the values--- actually changed.-nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a-nubDyn d =-  let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)-  in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior+-- | Create a new 'Dynamic' that only signals changes if the values actually+-- changed.+holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)+holdUniqDyn = holdUniqDynBy (==) -{--instance Reflex t => Functor (Dynamic t) where-  fmap f d =-    let e' = fmap f $ updated d-        eb' = push (\b' -> liftM Just $ constant b') e'-        b0 = fmap f $ current d-    --}      +-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'+-- changes and the given function returns 'False' when given both the old and+-- the new values.+holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)+holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new) --- | Map a function over a 'Dynamic'.-mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)-mapDyn f = mapDynM $ return . f+-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)+improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))+improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing) --- | Flipped version of 'mapDyn'.-forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)-forDyn = flip mapDyn+-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'.  This+-- function does not force its input 'Dynamic' until the output 'Dynamic' is+-- forced.+scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)+scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b) --- | Map a monadic function over a 'Dynamic'.  The only monadic action that the given function can--- perform is 'sample'.-{-# INLINE mapDynM #-}-mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)-mapDynM f d = do-  let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d-      eb' = fmap constant e'-      v0 = pull $ f =<< sample (current d)-  bb' :: Behavior t (Behavior t b) <- hold v0 eb'-  let b' = pull $ sample =<< sample bb'-  return $ Dynamic b' e'+-- | Like 'scanDyn', but the the accumulator function may decline to update the+-- result 'Dynamic''s value.+scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)+scanDynMaybe z f d = do+  rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do+        b <- sample $ current d'+        return $ f a b+  return d' --- | Create a 'Dynamic' using the initial value and change it each--- time the 'Event' occurs using a folding function on the previous--- value and the value of the 'Event'.+-- | Create a 'Dynamic' using the initial value and change it each time the+-- 'Event' occurs using a folding function on the previous value and the value+-- of the 'Event'. foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)-foldDyn f = foldDynMaybe $ \o v -> Just $ f o v+foldDyn = accumDyn . flip --- | Create a 'Dynamic' using the initial value and change it each--- time the 'Event' occurs using a monadic folding function on the--- previous value and the value of the 'Event'.+-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it+-- can 'sample' existing 'Behaviors' and 'hold' new ones. foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)-foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v+foldDynM = accumMDyn . flip +-- | Create a 'Dynamic' using the provided initial value and change it each time+-- the provided 'Event' occurs, using a function to combine the old value with+-- the 'Event''s value.  If the function returns 'Nothing', the value is not+-- changed; this is distinct from returning 'Just' the old value, since the+-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire+-- in the 'Nothing' case. foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)-foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v+foldDynMaybe = accumMaybeDyn . flip +-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it+-- can 'sample' existing 'Behaviors' and 'hold' new ones. foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)-foldDynMaybeM f z e = do-  rec let e' = flip push e $ \o -> do-            v <- sample b'-            f o v-      b' <- hold z e'-  return $ Dynamic b' e'+foldDynMaybeM = accumMaybeMDyn . flip --- | Create a new 'Dynamic' that counts the occurences of the 'Event'.+-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'. count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b) count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e @@ -186,124 +173,65 @@ toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool) toggle = foldDyn (const not) --- | Switches to the new 'Event' whenever it receives one.  Switching--- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new--- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.+-- | Switches to the new 'Event' whenever it receives one. Only the old event is+-- considered the moment a new one is switched in; the output event will fire at+-- that moment if only if the old event does.+--+-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double+-- work when the outer and (new) inner fires means this imposes fewer "timing+-- requirements" and thus is far more easy to use without introducing fresh+-- failure cases. 'switchDyn' is also more performant.+switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a+switchDyn d = switch (current d)++-- | Switches to the new 'Event' whenever it receives one.  Switching occurs+-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the+-- old and new inner Events fire simultaneously, the output will fire with the+-- value of the __new__ 'Event'.+--+-- Prefer 'switchDyn' to this where possible. The timing requirements that+-- switching before imposes are likely to bring down your app unless you are+-- very careful. 'switchDyn' is also more performant. switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a switchPromptlyDyn de =   let eLag = switch $ current de       eCoincidences = coincidence $ updated de   in leftmost [eCoincidences, eLag] -{---mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)-mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb--firstE :: (Reflex t m) => [Event t a] -> m (Event t a)-firstE [] = return never-firstE (h:t) = mergeEventsLeftBiased h =<< firstE t--concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)-concatEventsWith _ [] = return never-concatEventsWith _ [e] = return e-concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es---concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t--mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)-mconcatE = concatEventsWith mappend--}---- | Split the 'Dynamic' into two 'Dynamic's, each taking the--- respective value of the tuple.-splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)-splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)---- | Merge the 'Dynamic' values using their 'Monoid' instance.-mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)-mconcatDyn es = do-  ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es-  mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm---- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of--- Dynamic values.-distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))-distributeDMapOverDyn dm = case DMap.toList dm of-  [] -> return $ constDyn DMap.empty-  [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v-  _ -> do-    let edmPre = merge $ rewrapDMap updated dm-        edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do-          let f _ = \case-                This origDyn -> sample $ current origDyn-                That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"-                These _ (Identity newVal) -> return newVal-          sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)-        dm0 :: Behavior t (DMap k) = pull $ do-          liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv-    bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm-    let bdm = pull $ sample =<< sample bbdm-    return $ Dynamic bdm edm+-- | Split a 'Dynamic' pair into a pair of 'Dynamic's+splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)+splitDynPure d = (fmap fst d, fmap snd d) --- | Merge two 'Dynamic's into a new one using the provided--- function. The new 'Dynamic' changes its value each time one of the--- original 'Dynamic's changes its value.-combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)-combineDyn f da db = do-  let eab = align (updated da) (updated db)-      ec = flip push eab $ \o -> do-        (a, b) <- case o of-          This a -> do-            b <- sample $ current db-            return (a, b)-          That b -> do-            a <- sample $ current da-            return (a, b)-          These a b -> return (a, b)-        return $ Just $ f a b-      c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)-  bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec-  let bc :: Behavior t c = pull $ sample =<< sample bbc-  return $ Dynamic bc ec+-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with+-- non-'Dynamic' elements.+distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)+distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap -{--tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a-tagInnerDyn e =-  let eSlow = push (liftM Just . sample . current) e-      eFast = coincidence $ fmap updated e-  in leftmost [eFast, eSlow]--}+-- | Convert an 'IntMap' with 'Dynamic' elements into a 'Dynamic' of an 'IntMap' with+-- non-'Dynamic' elements.+distributeIntMapOverDynPure :: (Reflex t) => IntMap (Dynamic t v) -> Dynamic t (IntMap v)+distributeIntMapOverDynPure = fmap dmapToIntMap . distributeDMapOverDynPure . intMapWithFunctorToDMap --- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value--- of the inner 'Dynamic'.-joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a-joinDyn dd =-  let b' = pull $ sample . current =<< sample (current dd)-      eOuter :: Event t a = pushAlways (sample . current) $ updated dd-      eInner :: Event t a = switch $ fmap updated (current dd)-      eBoth :: Event t a = coincidence $ fmap updated (updated dd)-      e' = leftmost [eBoth, eOuter, eInner]-  in Dynamic b' e'+-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with+-- non-'Dynamic' elements, preserving the order of the elements.+{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}+distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]+distributeListOverDynPure = distributeListOverDyn  --TODO: Generalize this to functors other than Maps -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic' -- with the current values of the 'Dynamic's in a map. joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)-joinDynThroughMap dd =-  let b' = pull $ mapM (sample . current) =<< sample (current dd)-      eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd-      eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased-      readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a-      readNonFiring = \case-        This d -> sample $ current d-        That a -> return a-        These _ a -> return a-      eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)-      e' = leftmost [eBoth, eOuter, eInner]-  in Dynamic b' e'+joinDynThroughMap = (distributeMapOverDynPure =<<) --- | Print the value of the 'Dynamic' on each change and prefix it--- with the provided string. This should /only/ be used for debugging.+-- | Combine a 'Dynamic' of an 'IntMap' of 'Dynamic's into a 'Dynamic'+-- with the current values of the 'Dynamic's in a map.+joinDynThroughIntMap :: forall t a. (Reflex t) => Dynamic t (IntMap (Dynamic t a)) -> Dynamic t (IntMap a)+joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)++-- | Print the value of the 'Dynamic' when it is first read and on each+-- subsequent change that is observed (as 'traceEvent'), prefixed with the+-- provided string. This should /only/ be used for debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something -- else in the system is depending on it.@@ -311,7 +239,8 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x  -- | Print the result of applying the provided function to the value--- of the 'Dynamic' on each change. This should /only/ be used for+-- of the 'Dynamic' when it is first read and on each subsequent change+-- that is observed (as 'traceEvent'). This should /only/ be used for -- debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something@@ -319,77 +248,130 @@ traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a traceDynWith f d =   let e' = traceEventWith f $ updated d-  in Dynamic (current d) e'+      getV0 = do+        x <- sample $ current d+        trace (f x) $ return x+  in unsafeBuildDynamic getV0 e'  -- | Replace the value of the 'Event' with the current value of the 'Dynamic' -- each time the 'Event' occurs. ----- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing--- at the same time that `d` is changing.  With `tagDyn d e`, the *new* value of `d`--- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value+-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing+-- at the same time that @/d/@ is changing.  With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@+-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value -- will be used, since the 'Behavior' won't be updated until the end of the frame. -- Additionally, this means that the output 'Event' may not be used to directly change--- the input 'Dynamic', because that would mean its value depends on itself.  When creating--- cyclic data flows, generally `tag (current d) e` is preferred.-tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a-tagDyn = attachDynWith const+-- the input 'Dynamic', because that would mean its value depends on itself.  __When creating__+-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__+tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a+tagPromptlyDyn = attachPromptlyDynWith const  -- | Attach the current value of the 'Dynamic' to the value of the -- 'Event' each time it occurs. ----- Note: `attachDyn d` is not the same as `attach (current d)`.  See 'tagDyn' for details.-attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)-attachDyn = attachDynWith (,)+-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@.  See 'tagPromptlyDyn' for details.+attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)+attachPromptlyDyn = attachPromptlyDynWith (,)  -- | Combine the current value of the 'Dynamic' with the value of the -- 'Event' each time it occurs. ----- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`.  See 'tagDyn' for details.-attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c-attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b+-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@.  See 'tagPromptlyDyn' for details.+attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c+attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b --- | Create a new 'Event' by combining the value at each occurence--- with the current value of the 'Dynamic' value and possibly--- filtering if the combining function returns 'Nothing'.+-- | Create a new 'Event' by combining the value at each occurrence with the+-- current value of the 'Dynamic' value and possibly filtering if the combining+-- function returns 'Nothing'. ----- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`.  See 'tagDyn' for details.-attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c-attachDynWithMaybe f d e =+-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@.  See 'tagPromptlyDyn' for details.+attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c+attachPromptlyDynWithMaybe f d e =   let e' = attach (current d) e   in fforMaybe (align e' $ updated d) $ \case        This (a, b) -> f a b -- Only the tagging event is firing, so use that        These (_, b) a -> f a b -- Both events are firing, so use the newer value        That _ -> Nothing -- The tagging event isn't firing, so don't fire +-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,+-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor+-- chages from 'Nothing' to 'Just' or vice-versa.  Whenever the constructor+-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track+-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the+-- existing inner 'Dynamic' will become constant, and will not change when the+-- outer constructor changes back to 'Nothing'.+maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))+maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack+  where pack = \case+          Nothing -> Left ()+          Just a -> Right a+        unpack = \case+          Left _ -> Nothing+          Right a -> Just a++-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that+-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right').+eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))+eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum+  where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)+        unpack = \case+          LeftTag :=> Compose a -> Left $ coerceDynamic a+          RightTag :=> Compose b -> Right $ coerceDynamic b++-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values.+-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner+-- 'Dynamic' represents updates within the current key.+factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)+          => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))+factorDyn d = buildDynamic (sample (current d) >>= holdKey) update  where+  update :: Event t (DSum k (Compose (Dynamic t) v))+  update = flip push (updated d) $ \(newKey :=> newVal) -> do+     (oldKey :=> _) <- sample (current d)+     case newKey `geq` oldKey of+      Just Refl -> return Nothing+      Nothing -> Just <$> holdKey (newKey :=> newVal)++  holdKey (k :=> v) = do+    inner' <- filterEventKey k (updated d)+    inner <- holdDyn v inner'+    return $ k :=> Compose inner+ -------------------------------------------------------------------------------- -- Demux -------------------------------------------------------------------------------- --- | Represents a time changing value together with an 'EventSelector'--- that can efficiently detect when the underlying Dynamic has a particular value.--- This is useful for representing data like the current selection of a long list.+-- | Represents a time changing value together with an 'EventSelector' that can+-- efficiently detect when the underlying 'Dynamic' has a particular value.+-- This is useful for representing data like the current selection of a long+-- list. -- -- Semantically,--- > getDemuxed (demux d) k === mapDyn (== k) d--- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,--- rather than /O(n)/ for mapDyn.+--+-- > demuxed (demux d) k === fmap (== k) d+--+-- However, when 'demuxed' is used multiple times, the complexity is only+-- /O(log(n))/, rather than /O(n)/ for fmap. data Demux t k = Demux { demuxValue :: Behavior t k                        , demuxSelector :: EventSelector t (Const2 k Bool)                        } --- | Demultiplex an input value to a 'Demux' with many outputs.  At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.+-- | Demultiplex an input value to a 'Demux' with many outputs.  At any given+-- time, whichever output is indicated by the given 'Dynamic' will be 'True'. demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k-demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))+demux k = Demux (current k)+                (fan $ attachWith (\k0 k1 -> if k0 == k1+                                                then DMap.empty+                                                else DMap.fromList [Const2 k0 :=> Identity False,+                                                                    Const2 k1 :=> Identity True])+                                  (current k) (updated k)) ---TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out--- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)--- mapping over the original 'Dynamic' and checking whether it is equal to the given key.-getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)-getDemuxed d k = do+-- | Select a particular output of the 'Demux'; this is equivalent to (but much+-- faster than) mapping over the original 'Dynamic' and checking whether it is+-- equal to the given key.+demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool+demuxed d k =   let e = select (demuxSelector d) (Const2 k)-  bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e-  let b = pull $ join $ sample bb-  return $ Dynamic b e+  in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e  -------------------------------------------------------------------------------- -- collectDyn@@ -397,6 +379,41 @@  --TODO: This whole section is badly in need of cleanup +-- | A heterogeneous list whose type and length are fixed statically.  This is+-- reproduced from the 'HList' package due to integration issues, and because+-- very little other functionality from that library is needed.+data HList (l::[Type]) where+  HNil  :: HList '[]+  HCons :: e -> HList l -> HList (e ': l)++infixr 2 `HCons`++type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HRevApp '[] l = l+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')++hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)+hRevApp HNil l = l+hRevApp (HCons x l) l' = hRevApp l (HCons x l')++hReverse :: HList l -> HList (HRevApp l '[])+hReverse l = hRevApp l HNil++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance (l' ~ HRevApp l '[])+      => HBuild' l (HList l') where+  hBuild' = hReverse++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)++-- | Like 'HList', but with a functor wrapping each element. data FHList f l where   FHNil :: FHList f '[]   FHCons :: f e -> FHList f l -> FHList f (e ': l)@@ -413,20 +430,26 @@   HTailPtr _ `gcompare` HHeadPtr = GGT   HTailPtr a `gcompare` HTailPtr b = a `gcompare` b +-- | A typed index into a typed heterogeneous list. data HListPtr l a where   HHeadPtr :: HListPtr (h ': t) h   HTailPtr :: HListPtr t a -> HListPtr (h ': t) a -fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))+deriving instance Eq (HListPtr l a)+deriving instance Ord (HListPtr l a)++fhlistToDMap :: forall (f :: Type -> Type) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go-  where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]+  where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]         go = \case           FHNil -> []-          FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)+          FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t) +-- | This class allows 'HList's and 'FHlist's to be built from regular lists;+-- they must be contiguous and sorted. class RebuildSortedHList l where-  rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l-  rebuildSortedHList :: [DSum (HListPtr l)] -> HList l+  rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l+  rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l  instance RebuildSortedHList '[] where   rebuildSortedFHList l = case l of@@ -438,28 +461,25 @@  instance RebuildSortedHList t => RebuildSortedHList (h ': t) where   rebuildSortedFHList l = case l of-    ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t+    ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t     _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"   rebuildSortedHList l = case l of-    ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t+    ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t     _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected" -dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l dmapToHList = rebuildSortedHList . DMap.toList -distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))-distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)-{--distributeFHListOverDyn l = do-  let ec = undefined-      c0 = pull $ sequenceFHList $ natMap (sample . current) l-  bbc <- hold c0 $ fmap constant ec-  let bc = pull $ sample =<< sample bbc-  return $ Dynamic bc ec--}+-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a+-- single 'Dynamic' whose value represents the current values of all of the+-- input 'Dynamic's.+distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)+distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l -class AllAreFunctors (f :: a -> *) (l :: [a]) where-  type FunctorList f l :: [*]+-- | Indicates that all elements in a type-level list are applications of the+-- same functor.+class AllAreFunctors (f :: a -> Type) (l :: [a]) where+  type FunctorList f l :: [Type]   toFHList :: HList (FunctorList f l) -> FHList f l   fromFHList :: FHList f l -> HList (FunctorList f l) @@ -467,28 +487,34 @@   type FunctorList f '[] = '[]   toFHList l = case l of     HNil -> FHNil+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800     _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139+#endif   fromFHList FHNil = HNil  instance AllAreFunctors f t => AllAreFunctors f (h ': t) where   type FunctorList f (h ': t) = f h ': FunctorList f t   toFHList l = case l of     a `HCons` b -> a `FHCons` toFHList b+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800     _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139+#endif   fromFHList (a `FHCons` b) = a `HCons` fromFHList b -collectDyn :: ( RebuildSortedHList (HListElems b)-              , IsHList a, IsHList b-              , AllAreFunctors (Dynamic t) (HListElems b)-              , Reflex t, MonadHold t m-              , HListElems a ~ FunctorList (Dynamic t) (HListElems b)-              ) => a -> m (Dynamic t b)-collectDyn ds =-  mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)+-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a+-- single 'Dynamic' whose value represents all the current values of the input's+-- constituent 'Dynamic's.+collectDynPure :: ( RebuildSortedHList (HListElems b)+                  , IsHList a, IsHList b+                  , AllAreFunctors (Dynamic t) (HListElems b)+                  , Reflex t+                  , HListElems a ~ FunctorList (Dynamic t) (HListElems b)+                  ) => a -> Dynamic t b+collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds --- Poor man's Generic+-- | Poor man's 'Generic's for product types only. class IsHList a where-  type HListElems a :: [*]+  type HListElems a :: [Type]   toHList :: a -> HList (HListElems a)   fromHList :: HList (HListElems a) -> a @@ -497,18 +523,24 @@   toHList (a, b) = hBuild a b   fromHList l = case l of     a `HCons` b `HCons` HNil -> (a, b)+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800     _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139+#endif  instance IsHList (a, b, c, d) where   type HListElems (a, b, c, d) = [a, b, c, d]   toHList (a, b, c, d) = hBuild a b c d   fromHList l = case l of     a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800     _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139+#endif  instance IsHList (a, b, c, d, e, f) where   type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]   toHList (a, b, c, d, e, f) = hBuild a b c d e f   fromHList l = case l of     a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800     _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139+#endif
src/Reflex/Dynamic/TH.hs view
@@ -1,50 +1,86 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-}-module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-} -import Reflex.Dynamic+-- | Template Haskell helper functions for building complex 'Dynamic' values.+module Reflex.Dynamic.TH+  ( qDynPure+  , unqDyn+  , mkDynPure+  ) where -import Language.Haskell.TH-import qualified Language.Haskell.TH.Syntax as TH-import Language.Haskell.TH.Quote-import Data.Data import Control.Monad.State+import Data.Data+import Data.Generics import qualified Language.Haskell.Exts as Hs import qualified Language.Haskell.Meta.Syntax.Translate as Hs-import Data.Monoid-import Data.Generics+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import qualified Language.Haskell.TH.Syntax as TH --- | Quote a Dynamic expression.  Within the quoted expression, you can use '$(unqDyn [| x |])' to refer to any expression 'x' of type 'Dynamic t a'; the unquoted result will be of type 'a'-qDyn :: Q Exp -> Q Exp-qDyn qe = do+#if !MIN_VERSION_base(4,18,0)+import Data.Monoid ((<>))+#endif++import Reflex.Dynamic++-- | Quote a 'Dynamic' expression.  Within the quoted expression, you can use+-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the+-- unquoted result will be of type @a@+qDynPure :: Q Exp -> Q Exp+qDynPure qe = do   e <- qe   let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d       f d = case eqT of         Just (Refl :: d :~: Exp)           | AppE (VarE m) eInner <- d           , m == 'unqMarker-          -> do n <- lift $ newName "dyn"+          -> do n <- lift $ newName "dynamicQuotedExpressionVariable"                 modify ((n, eInner):)                 return $ VarE n         _ -> gmapM f d   (e', exprsReversed) <- runStateT (gmapM f e) []   let exprs = reverse exprsReversed-      arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs-      param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs-  [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |]+      arg = foldr+        (\(_, expr) rest -> [e| FHCons $(pure expr) $rest |])+        [e| FHNil |]+        exprs+      param = foldr+        (\(name, _) rest -> [p| HCons $(pure $ VarP name) $rest |])+        [p| HNil |]+        exprs+  [| (\ $param -> $(pure e')) <$> distributeFHListOverDynPure $arg |] +-- | Antiquote a 'Dynamic' expression.  This can /only/ be used inside of a+-- 'qDyn' quotation. unqDyn :: Q Exp -> Q Exp unqDyn e = [| unqMarker $e |] --- | This type represents an occurrence of unqDyn before it has been processed by qDyn.  If you see it in a type error, it probably means that unqDyn has been used outside of a qDyn context.+-- | This type represents an occurrence of unqDyn before it has been processed+-- by qDyn.  If you see it in a type error, it probably means that unqDyn has+-- been used outside of a qDyn context. data UnqDyn --- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn+-- unqMarker must not be exported; it is used only as a way of smuggling data+-- from unqDyn to qDyn+ --TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery unqMarker :: a -> UnqDyn unqMarker = error "An unqDyn expression was used outside of a qDyn expression" -mkDyn :: QuasiQuoter-mkDyn = QuasiQuoter+-- | Create a 'Dynamic' value using other 'Dynamic's as inputs.  The result is+-- sometimes more concise and readable than the equivalent 'Applicative'-based+-- expression.  For example:+--+-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]+--+-- would have a very cumbersome 'Applicative' encoding.+mkDynPure :: QuasiQuoter+mkDynPure = QuasiQuoter   { quoteExp = mkDynExp   , quotePat = error "mkDyn: pattern splices are not supported"   , quoteType = error "mkDyn: type splices are not supported"@@ -52,15 +88,16 @@   }  mkDynExp :: String -> Q Exp-mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of+mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of   Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err-  Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e+  Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e     where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker+          antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo           antiE x = case x of-            Hs.SpliceExp se ->-              Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of-                Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v-                Hs.ParenSplice ps -> ps+            Hs.SpliceExp l se ->+              Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of+                Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v+                Hs.ParenSplice _ ps -> ps             _ -> x           reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))             | modName == modName' && occName == occName' = 'unqMarker
+ src/Reflex/Dynamic/Uniq.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | This module provides a variation of 'Dynamic' values that uses cheap+-- pointer equality checks to reduce the amount of signal propagation needed.+module Reflex.Dynamic.Uniq+  ( UniqDynamic+  , uniqDynamic+  , fromUniqDynamic+  , alreadyUniqDynamic+  ) where++import GHC.Exts++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (Applicative(..))+#endif++import Reflex.Class++-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as+-- the 'current' 'Behavior''s contents.  In order to maintain this constraint,+-- the value inside a 'UniqDynamic' is always evaluated to+-- <https://wiki.haskell.org/Weak_head_normal_form weak head normal form>.+--+-- Internally, 'UniqDynamic' uses pointer equality as a heuristic to avoid+-- unnecessary update propagation; this is much more efficient than performing+-- full comparisons.  However, when the 'UniqDynamic' is converted back into a+-- regular 'Dynamic', a full comparison is performed.+newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a }++-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.+uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a+uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do+  old <- sample $ current d --TODO: Is it better to sample ourselves here?+  return $ unsafeJustChanged old new++-- | Retrieve a normal 'Dynamic' from a 'UniqDynamic'.  This will perform a+-- final check using the output type's 'Eq' instance to ensure deterministic+-- behavior.+--+-- WARNING: If used with a type whose 'Eq' instance is not law-abiding -+-- specifically, if there are cases where @x /= x@, 'fromUniqDynamic' may+-- eliminate more 'updated' occurrences than it should.  For example, NaN values+-- of 'Double' and 'Float' are considered unequal to themselves by the 'Eq'+-- instance, but can be equal by pointer equality.  This may cause 'UniqDynamic'+-- to lose changes from NaN to NaN.+fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a+fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'+  where+    -- Only consider values different if they fail both pointer equality /and/+    -- 'Eq' equality.  This is to make things a bit more deterministic in the+    -- case of unlawful 'Eq' instances.  However, it is still possible to+    -- achieve nondeterminism by constructing elements that are identical in+    -- value, unequal according to 'Eq', and nondeterministically equal or+    -- nonequal by pointer quality.  I suspect that it is impossible to make the+    -- behavior deterministic in this case.+    superEq a b = a `unsafePtrEq` b || a == b+    e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d)++-- | Create a UniqDynamic without uniqing it on creation.  This will be slightly+-- faster than uniqDynamic when used with a Dynamic whose values are always (or+-- nearly always) different from its previous values; if used with a Dynamic+-- whose values do not change frequently, it may be much slower than uniqDynamic+alreadyUniqDynamic :: Dynamic t a -> UniqDynamic t a+alreadyUniqDynamic = UniqDynamic++unsafePtrEq :: a -> a -> Bool+unsafePtrEq a b = case a `seq` b `seq` reallyUnsafePtrEquality# a b of+  0# -> False+  _ -> True++unsafeJustChanged :: a -> a -> Maybe a+unsafeJustChanged old new =+  if old `unsafePtrEq` new+  then Nothing+  else Just new++instance Reflex t => Accumulator t (UniqDynamic t) where+  accumMaybeM f z e = do+    let f' old change = do+          mNew <- f old change+          return $ unsafeJustChanged old =<< mNew+    d <- accumMaybeMDyn f' z e+    return $ UniqDynamic d+  mapAccumMaybeM f z e = do+    let f' old change = do+          (mNew, output) <- f old change+          return (unsafeJustChanged old =<< mNew, output)+    (d, out) <- mapAccumMaybeMDyn f' z e+    return (UniqDynamic d, out)++instance Reflex t => Functor (UniqDynamic t) where+  fmap f (UniqDynamic d) = uniqDynamic $ fmap f d++instance Reflex t => Applicative (UniqDynamic t) where+  pure = UniqDynamic . constDyn+  UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b+  _ *> b = b+  a <* _ = a++instance Reflex t => Monad (UniqDynamic t) where+  UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f
+ src/Reflex/DynamicWriter.hs view
@@ -0,0 +1,7 @@+module Reflex.DynamicWriter+  {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-}+  ( module X+  ) where++import Reflex.DynamicWriter.Base as X+import Reflex.DynamicWriter.Class as X
+ src/Reflex/DynamicWriter/Base.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Reflex.DynamicWriter.Base+  ( DynamicWriterT (..)+  , runDynamicWriterT+  , withDynamicWriterT+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Morph+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Align+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.FastMutableIntMap+import Data.Functor.Misc+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Some (Some)+import Data.These++#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+import Data.Semigroup (Semigroup(..))+#endif++import Reflex.Adjustable.Class+import Reflex.Class+import Reflex.DynamicWriter.Class+import Reflex.EventWriter.Class (EventWriter, tellEvent)+import Reflex.Host.Class+import qualified Data.Patch.MapWithMove as MapWithMove+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Query.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)++mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues+  where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a+        addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m++mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)+mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues+  where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a+        addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m++mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues+  where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a+        addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove+        f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v+        f x = unsafePatchMapWithMove $+          let (p, changed) = case x of+                This p_ -> (unPatchMapWithMove p_, mempty)+                That c -> (mempty, c)+                These p_ c -> (unPatchMapWithMove p_, c)+              (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case+                MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v+                MapWithMove.From_Delete -> return MapWithMove.From_Delete+                MapWithMove.From_Move k -> case Map.lookup k changed of+                  Nothing -> return $ MapWithMove.From_Move k+                  Just v -> do+                    modify (k:)+                    return $ MapWithMove.From_Insert v+              noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved+          in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?++-- | A basic implementation of 'DynamicWriter'.+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }+  -- The list is kept in reverse order+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadTrans+    , MFunctor+    , MonadIO+    , MonadFix+    , MonadAsyncException+    , MonadException+    , MonadCatch+    , MonadThrow+    , MonadMask+    )++deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)+deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)+++instance MonadRef m => MonadRef (DynamicWriterT t w m) where+  type Ref (DynamicWriterT t w m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where+  atomicModifyRef r = lift . atomicModifyRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where+  newEventWithTrigger = lift . newEventWithTrigger+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++-- | Run a 'DynamicWriterT' action.  The dynamic writer output will be provided+-- along with the result of the action.+runDynamicWriterT :: (Monad m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)+runDynamicWriterT (DynamicWriterT a) = do+  (result, ws) <- runStateT a []+  return (result, mconcat $ reverse ws)++instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where+  tellDyn w = DynamicWriterT $ modify (w :)++instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where+  ask = lift ask+  local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a+  reader = lift . reader++instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where+  type Performable (DynamicWriterT t w m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where+  getPostBuild = lift getPostBuild++instance MonadState s m => MonadState s (DynamicWriterT t w m) where+  get = lift get+  put = lift . put++instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where+  type PrimState (DynamicWriterT t w m) = PrimState m+  primitive = lift . primitive++newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)++-- | When the execution of a 'DynamicWriterT' action is adjusted using+-- 'Adjustable', the 'Dynamic' output of that action will also be updated to+-- match.+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where+  runWithReplace a0 a' = do+    (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'+    tellDyn . join =<< holdDyn (snd result0) (snd <$> result')+    return (fst result0, fst <$> result')+  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental+  traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental+  traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove++traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), Monoid w, Reflex t, MonadHold t m)+  => (   (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))+      -> DMap k v+      -> Event t (p k v)+      -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))+     )+  -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')+  -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))+  -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))+  -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))+  -> DMap k v+  -> Event t (p k v)+  -> DynamicWriterT t w m (DMap k v', Event t (p k v'))+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do+  (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'+  let getValue (DynamicWriterTLoweredResult (v, _)) = v+      getWritten (DynamicWriterTLoweredResult (_, w)) = w+      liftedResult0 = DMap.map getValue result0+      liftedResult' = ffor result' $ mapPatch getValue+      liftedWritten0 :: Map (Some k) (Dynamic t w)+      liftedWritten0 = weakenDMapWith getWritten result0+      liftedWritten' = ffor result' $ weakenPatchWith getWritten+  --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics+  i <- holdIncremental liftedWritten0 liftedWritten'+  tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i+  return (liftedResult0, liftedResult')++traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')+  => (   (IntMap.Key -> v -> m (v', Dynamic t w))+      -> IntMap v+      -> Event t (p v)+      -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))+     )+  -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))+  -> (IntMap.Key -> v -> DynamicWriterT t w m v')+  -> IntMap v+  -> Event t (p v)+  -> DynamicWriterT t w m (IntMap v', Event t (p v'))+traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do+  (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'+  let liftedResult0 = fmap fst result0+      liftedResult' = fmap (fmap fst) result'+      liftedWritten0 :: IntMap (Dynamic t w)+      liftedWritten0 = fmap snd result0+      liftedWritten' = fmap (fmap snd) result'+  --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics+  i <- holdIncremental liftedWritten0 liftedWritten'+  tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i+  return (liftedResult0, liftedResult')++-- | Map a function over the output of a 'DynamicWriterT'.+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)+                   => (w -> w')+                   -> DynamicWriterT t w m a+                   -> DynamicWriterT t w' m a+withDynamicWriterT f dw = do+  (r, d) <- lift $ do+    (r, d) <- runDynamicWriterT dw+    let d' = fmap f d+    return (r, d')+  tellDyn d+  return r++instance Requester t m => Requester t (DynamicWriterT t w m) where+  type Request (DynamicWriterT t w m) = Request m+  type Response (DynamicWriterT t w m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where+  tellQueryIncremental = lift . tellQueryIncremental+  askQueryResult = lift askQueryResult+  queryIncremental = lift . queryIncremental++instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where+  tellEvent = lift . tellEvent
+ src/Reflex/DynamicWriter/Class.hs view
@@ -0,0 +1,26 @@+-- | This module defines the 'DynamicWriter' class.+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.DynamicWriter.Class+  ( MonadDynamicWriter+  , DynamicWriter(..)+  ) where++import Control.Monad.Reader (ReaderT, lift)+import Reflex.Class (Dynamic)++{-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-}+-- | Type synonym for 'DynamicWriter'+type MonadDynamicWriter = DynamicWriter++-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'+-- and combines them monoidally to provide a 'Dynamic' result.+class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where+  tellDyn :: Dynamic t w -> m ()++instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where+  tellDyn = lift . tellDyn
+ src/Reflex/EventWriter.hs view
@@ -0,0 +1,7 @@+module Reflex.EventWriter+  {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}+  ( module X+  ) where++import Reflex.EventWriter.Base as X+import Reflex.EventWriter.Class as X
+ src/Reflex/EventWriter/Base.hs view
@@ -0,0 +1,320 @@+-- | This module provides 'EventWriterT', the standard implementation of+-- 'EventWriter'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.EventWriter.Base+  ( EventWriterT (..)+  , runEventWriterT+  , runWithReplaceEventWriterTWith+  , sequenceDMapWithAdjustEventWriterTWith+  , mapEventWriterT+  , withEventWriterT+  ) where++import Reflex.Adjustable.Class+import Reflex.Class+import Reflex.EventWriter.Class (EventWriter, tellEvent)+import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn)+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Query.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Morph+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum (..))+import Data.Functor.Compose+import Data.Functor.Misc+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Semigroup+import Data.Some (Some)+import Data.Tuple+import Data.Type.Equality++import Unsafe.Coerce++{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}+newtype TellId w x+  = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead+  deriving (Show, Eq, Ord, Enum)++tellId :: Int -> TellId w w+tellId = TellId+{-# INLINE tellId #-}++tellIdRefl :: TellId w x -> w :~: x+tellIdRefl _ = unsafeCoerce Refl++withTellIdRefl :: TellId w x -> (w ~ x => r) -> r+withTellIdRefl tid r = case tellIdRefl tid of+  Refl -> r++instance GEq (TellId w) where+  a `geq` b =+    withTellIdRefl a $+    withTellIdRefl b $+    if a == b+    then Just Refl+    else Nothing++instance GCompare (TellId w) where+  a `gcompare` b =+    withTellIdRefl a $+    withTellIdRefl b $+    case a `compare` b of+      LT -> GLT+      EQ -> GEQ+      GT -> GGT++data EventWriterState t w = EventWriterState+  { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)+  , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order+  }++-- | A basic implementation of 'EventWriter'.+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadTrans+    , MFunctor+    , MonadFix+    , MonadIO+    , MonadException+    , MonadAsyncException+    , MonadMask+    , MonadCatch+    , MonadThrow+    )++-- | Run a 'EventWriterT' action.+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)+runEventWriterT (EventWriterT a) = do+  (result, requests) <- runStateT a $ EventWriterState (-1) []+  let combineResults :: DMap (TellId w) Identity -> w+      combineResults = sconcat+        . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps+        . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order+  return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help++instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where+  tellEvent w = EventWriterT $ modify $ \old ->+    let myId = _eventWriterState_nextId old+    in EventWriterState+       { _eventWriterState_nextId = pred myId+       , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old+       }++instance MonadSample t m => MonadSample t (EventWriterT t w m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (EventWriterT t w m) where+  {-# INLINABLE hold #-}+  hold v0 = lift . hold v0+  {-# INLINABLE holdDyn #-}+  holdDyn v0 = lift . holdDyn v0+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 = lift . holdIncremental v0+  {-# INLINABLE buildDynamic #-}+  buildDynamic a0 = lift . buildDynamic a0+  {-# INLINABLE headE #-}+  headE = lift . headE+  {-# INLINABLE now #-}+  now = lift now++instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where+  runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'+  traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap+  traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap+  traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove++instance Requester t m => Requester t (EventWriterT t w m) where+  type Request (EventWriterT t w m) = Request m+  type Response (EventWriterT t w m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++-- | Given a function like 'runWithReplace' for the underlying monad, implement+-- 'runWithReplace' for 'EventWriterT'.  This is necessary when the underlying+-- monad doesn't have a 'Adjustable' instance or to override the default+-- 'Adjustable' behavior.+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)+                               => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))+                               -> EventWriterT t w m a+                               -> Event t (EventWriterT t w m b)+                               -> EventWriterT t w m (a, Event t b)+runWithReplaceEventWriterTWith f a0 a' = do+  (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'+  tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')+  return (fst result0, fmapCheap fst result')++-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.+sequenceIntMapWithAdjustEventWriterTWith+  :: forall t m p w v v'+  .  ( Reflex t+     , MonadHold t m+     , Semigroup w+     , Functor p+     , Patch (p (Event t w))+     , PatchTarget (p (Event t w)) ~ IntMap (Event t w)+     , Patch (p w)+     , PatchTarget (p w) ~ IntMap w+     )+  => (   (IntMap.Key -> v -> m (Event t w, v'))+      -> IntMap v+      -> Event t (p v)+      -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))+     )+  -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))+  -> (Event t (p (Event t w)) -> Event t (p w))+  -> (IntMap.Key -> v -> EventWriterT t w m v')+  -> IntMap v+  -> Event t (p v)+  -> EventWriterT t w m (IntMap v', Event t (p v'))+sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do+  let f' :: IntMap.Key -> v -> m (Event t w, v')+      f' k v = swap <$> runEventWriterT (f k v)+  (children0, children') <- base f' dm0 dm'+  let result0 = fmap snd children0+      result' = fmapCheap (fmap snd) children'+      requests0 :: IntMap (Event t w)+      requests0 = fmap fst children0+      requests' :: Event t (p (Event t w))+      requests' = fmapCheap (fmap fst) children'+  e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'+  tellEvent $ fforMaybeCheap e $ \m ->+    case IntMap.elems m of+      [] -> Nothing+      h : t -> Just $ sconcat $ h :| t+  return (result0, result')++-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.+sequenceDMapWithAdjustEventWriterTWith+  :: forall t m p p' w k v v'+  .  ( Reflex t+     , MonadHold t m+     , Semigroup w+     , Patch (p' (Some k) (Event t w))+     , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)+     , GCompare k+     , Patch (p' (Some k) w)+     , PatchTarget (p' (Some k) w) ~ Map (Some k) w+     )+  => (   (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))+      -> DMap k v+      -> Event t (p k v)+      -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))+     )+  -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')+  -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))+  -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))+  -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))+  -> (forall a. k a -> v a -> EventWriterT t w m (v' a))+  -> DMap k v+  -> Event t (p k v)+  -> EventWriterT t w m (DMap k v', Event t (p k v'))+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do+  let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)+      f' k v = Compose . swap <$> runEventWriterT (f k v)+  (children0, children') <- base f' dm0 dm'+  let result0 = DMap.map (snd . getCompose) children0+      result' = fforCheap children' $ mapPatch $ snd . getCompose+      requests0 :: Map (Some k) (Event t w)+      requests0 = weakenDMapWith (fst . getCompose) children0+      requests' :: Event t (p' (Some k) (Event t w))+      requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose+  e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'+  tellEvent $ fforMaybeCheap e $ \m ->+    case Map.elems m of+      [] -> Nothing+      h : t -> Just $ sconcat $ h :| t+  return (result0, result')++instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where+  type Performable (EventWriterT t w m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance PostBuild t m => PostBuild t (EventWriterT t w m) where+  getPostBuild = lift getPostBuild++instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance MonadReader r m => MonadReader r (EventWriterT t w m) where+  ask = lift ask+  local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a+  reader = lift . reader++instance MonadRef m => MonadRef (EventWriterT t w m) where+  type Ref (EventWriterT t w m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where+  atomicModifyRef r = lift . atomicModifyRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where+  newEventWithTrigger = lift . newEventWithTrigger+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where+  tellQueryIncremental = lift . tellQueryIncremental+  askQueryResult = lift askQueryResult+  queryIncremental = lift . queryIncremental++instance DynamicWriter t w m => DynamicWriter t w (EventWriterT t v m) where+  tellDyn = lift . tellDyn++instance PrimMonad m => PrimMonad (EventWriterT t w m) where+  type PrimState (EventWriterT t w m) = PrimState m+  primitive = lift . primitive++-- | Map a function over the output of a 'EventWriterT'.+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)+                 => (w -> w')+                 -> EventWriterT t w m a+                 -> EventWriterT t w' m a+withEventWriterT f ew = do+  (r, e) <- lift $ do+    (r, e) <- runEventWriterT ew+    let e' = fmap f e+    return (r, e')+  tellEvent e+  return r++-- | Change the monad underlying an EventWriterT+mapEventWriterT+  :: (forall x. m x -> n x)+  -> EventWriterT t w m a+  -> EventWriterT t w n a+mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a
+ src/Reflex/EventWriter/Class.hs view
@@ -0,0 +1,27 @@+-- | This module defines the 'EventWriter' class.+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.EventWriter.Class+  ( EventWriter (..)+  ) where++import Control.Monad.Reader (ReaderT, lift)++#if !MIN_VERSION_base(4,18,0)+import Data.Semigroup (Semigroup)+#endif++import Reflex.Class (Event)+++-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'+-- and combines them via 'Semigroup' to provide an 'Event' result.+class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where+  tellEvent :: Event t w -> m ()+++instance EventWriter t w m => EventWriter t w (ReaderT r m) where+  tellEvent = lift . tellEvent
+ src/Reflex/FastWeak.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if GHCJS_FAST_WEAK+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+#endif++-- |+-- Module:+--   Reflex.FastWeak+-- Description:+--   'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value+--   referred to by a 'FastWeak' stays live while the ticket is held (live).+--+--   On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper+--   around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same.+--+--   On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly+--   in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS.+module Reflex.FastWeak+  ( FastWeakTicket+  , FastWeak+  , mkFastWeakTicket+  , getFastWeakTicketValue+  , getFastWeakTicketWeak+  , getFastWeakValue+  , getFastWeakTicket+  , emptyFastWeak+#ifdef GHCJS_FAST_WEAK+  --TODO: Move these elsewhere+  , unsafeFromRawJSVal+  , unsafeToRawJSVal+  , js_isNull+#endif+  ) where++import GHC.Exts (Any)+import Unsafe.Coerce++#ifdef GHCJS_FAST_WEAK+import GHCJS.Types+#else+import Control.Exception (evaluate)+import System.IO.Unsafe+import System.Mem.Weak+#endif+++#ifdef GHCJS_FAST_WEAK+-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'+-- can be used to get the referred to value without fear of @Nothing,+-- and 'getFastWeakTicketWeak' can be used to get the weak version.+--+-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@.+newtype FastWeakTicket a = FastWeakTicket JSVal++-- | A reference to some value which can be garbage collected if there are only+-- weak references to the value left.+--+-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.+--+-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using+-- 'getFastWeakTicket' if the value hasn't been collected yet.+--+-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@.+newtype FastWeak a = FastWeak JSVal++-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two+data Val a = Val { unVal :: a }++-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@+unsafeFromRawJSVal :: JSVal -> a+unsafeFromRawJSVal v = unVal (unsafeCoerce v)++-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object.+unsafeToRawJSVal :: a -> JSVal+unsafeToRawJSVal v = unsafeCoerce (Val v)+#else+-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'+-- can be used to get the referred to value without fear of @Nothing@,+-- and 'getFastWeakTicketWeak' can be used to get the weak version.+data FastWeakTicket a = FastWeakTicket+  { _fastWeakTicket_val :: !a+  , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)+  }++-- | A reference to some value which can be garbage collected if there are only weak references to the value left.+--+-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.+--+-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket'+-- if the value hasn't been collected yet.+--+-- Synonymous with 'Weak'.+type FastWeak a = Weak a+#endif++-- | Return the @a@ kept alive by the given 'FastWeakTicket'.+--+-- This needs to be in IO so we know that we've relinquished the ticket.+getFastWeakTicketValue :: FastWeakTicket a -> IO a+#ifdef GHCJS_FAST_WEAK+getFastWeakTicketValue t = do+  v <- js_ticketVal t+  return $ unsafeFromRawJSVal v++foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal+#else+getFastWeakTicketValue = return . _fastWeakTicket_val+#endif++-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected,+-- or @Nothing@ if it has been collected.+getFastWeakValue :: FastWeak a -> IO (Maybe a)+#ifdef GHCJS_FAST_WEAK+getFastWeakValue w = do+  r <- js_weakVal w+  case js_isNull r of+    True -> return Nothing+    False -> return $ Just $ unsafeFromRawJSVal r++foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool++foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal+#else+getFastWeakValue = deRefWeak+#endif++-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred+-- remains alive. Returns @Just@ if the value hasn't been collected+-- and a ticket can therefore be obtained, @Nothing@ if it's been collected.+getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))+#ifdef GHCJS_FAST_WEAK+getFastWeakTicket w = do+  r <- js_weakTicket w+  case js_isNull r of+    True -> return Nothing+    False -> return $ Just $ FastWeakTicket r++foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal+#else+getFastWeakTicket w = do+  deRefWeak w >>= \case+    Nothing -> return Nothing+    Just v -> return $ Just $ FastWeakTicket+      { _fastWeakTicket_val = v+      , _fastWeakTicket_weak = w+      }+#endif++-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process+-- which can be obtained with 'getFastWeakTicketValue'.+--+-- This function is marked NOINLINE so it is opaque to GHC.+-- If we do not do this, then GHC will sometimes fuse the constructor away+-- so any weak references that are attached to the ticket will have their+-- finalizer run. Using the opaque constructor, GHC does not see the+-- constructor application, so it behaves like an IORef and cannot be fused away.+--+-- The result is also evaluated to WHNF, since forcing a thunk invalidates+-- the weak pointer to it in some cases.+{-# NOINLINE mkFastWeakTicket #-}+mkFastWeakTicket :: a -> IO (FastWeakTicket a)+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the+-- associated FastWeak to actually be weak+#ifdef GHCJS_FAST_WEAK+mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)++foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a)+#else+mkFastWeakTicket v = do+  v' <- evaluate v+  w <- mkWeakPtr v' Nothing+  return $ FastWeakTicket+    { _fastWeakTicket_val = v'+    , _fastWeakTicket_weak = w+    }+#endif++-- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't.+-- Note that unless the ticket for the same 'FastWeak' is held in some other way+-- the value might be collected immediately.+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)+-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value+#ifdef GHCJS_FAST_WEAK+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a)+{-# INLINE getFastWeakTicketWeak #-}+getFastWeakTicketWeak = getFastWeakTicketWeak'+#else+getFastWeakTicketWeak = return . _fastWeakTicket_weak+#endif++-- | A weak reference that is always empty+emptyFastWeak :: FastWeak a+emptyFastWeak = unsafeCoerce w+  where w :: FastWeak Any+#ifdef GHCJS_FAST_WEAK+        w = js_emptyWeak+#else+        w = unsafePerformIO $ do+          w' <- mkWeakPtr undefined Nothing+          finalize w'+          return w'+#endif+{-# NOINLINE emptyFastWeak #-}++#ifdef GHCJS_FAST_WEAK+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any+#endif
+ src/Reflex/FunctorMaybe.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++-- |+-- Module:+--   Reflex.FunctorMaybe+-- Description:+--   This module defines the FunctorMaybe class, which extends Functors with the+--   ability to delete values.+module Reflex.FunctorMaybe+  ( FunctorMaybe (..)+  ) where++import Data.IntMap (IntMap)+import Data.Map (Map)+#if !MIN_VERSION_base(4,16,0)+import Data.Semigroup (Option(..))+#endif+import Witherable++--TODO: See if there's a better class in the standard libraries already++-- | A class for values that combines filtering and mapping using 'Maybe'.+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@.+{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-}+class FunctorMaybe f where+  -- | Combined mapping and filtering function.+  fmapMaybe :: (a -> Maybe b) -> f a -> f b++instance FunctorMaybe Maybe where+  fmapMaybe = mapMaybe++#if !MIN_VERSION_base(4,16,0)+deriving instance FunctorMaybe Option+#endif++instance FunctorMaybe [] where+  fmapMaybe = mapMaybe++instance FunctorMaybe (Map k) where+  fmapMaybe = mapMaybe++instance FunctorMaybe IntMap where+  fmapMaybe = mapMaybe
src/Reflex/Host/Class.hs view
@@ -1,54 +1,89 @@-{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies, FlexibleContexts #-}-module Reflex.Host.Class where+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} +-- | This module provides the interface for hosting 'Reflex' engines.  This+-- should only be necessary if you're writing a binding or some other library+-- that provides a core event loop.+module Reflex.Host.Class+  ( ReflexHost (..)+  , MonadSubscribeEvent (..)+  , MonadReadEvent (..)+  , MonadReflexCreateTrigger (..)+  , MonadReflexHost (..)+  , fireEvents+  , newEventWithTriggerRef+  , fireEventRef+  , fireEventRefAndRead+  ) where+ import Reflex.Class -import Control.Applicative-import Control.Monad import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Ref import Control.Monad.Trans-import Control.Monad.Trans.Reader (ReaderT())-import Control.Monad.Trans.Writer (WriterT())-import Control.Monad.Trans.Cont   (ContT())-import Control.Monad.Trans.Except (ExceptT())-import Control.Monad.Trans.RWS    (RWST())-import Control.Monad.Trans.State  (StateT())+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.RWS (RWST)+import Control.Monad.Trans.State (StateT) import qualified Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer (WriterT) import Data.Dependent.Sum (DSum (..))-import Data.Monoid import Data.GADT.Compare-import Control.Monad.Ref---- Note: this import must come last to silence warnings from AMP-import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)+import Data.Kind (Type) --- | Framework implementation support class for the reflex implementation represented by @t@.-class (Reflex t, MonadReflexCreateTrigger t (HostFrame t), MonadSample t (HostFrame t), MonadHold t (HostFrame t), MonadFix (HostFrame t), MonadSubscribeEvent t (HostFrame t)) => ReflexHost t where-  type EventTrigger t :: * -> *-  type EventHandle t :: * -> *-  type HostFrame t :: * -> *+-- | Framework implementation support class for the reflex implementation+-- represented by @t@.+class ( Reflex t+      , MonadReflexCreateTrigger t (HostFrame t)+      , MonadSample t (HostFrame t)+      , MonadHold t (HostFrame t)+      , MonadFix (HostFrame t)+      , MonadSubscribeEvent t (HostFrame t)+      ) => ReflexHost t where+  type EventTrigger t :: Type -> Type+  type EventHandle t :: Type -> Type+  type HostFrame t :: Type -> Type --- | Monad in which Events can be 'subscribed'.  This forces all underlying event sources to be initialized, so that the event will fire whenever it ought to.  Events must be subscribed before they are read using readEvent+-- | Monad in which Events can be 'subscribed'.  This forces all underlying+-- event sources to be initialized, so that the event will fire whenever it+-- ought to.  Events must be subscribed before they are read using readEvent class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where   -- | Subscribe to an event and set it up if needed.   ---  -- This function will create a new 'EventHandle' from an 'Event'. This handle may then be used via-  -- 'readEvent' in the read callback of 'fireEventsAndRead'.+  -- This function will create a new 'EventHandle' from an 'Event'. This handle+  -- may then be used via 'readEvent' in the read callback of+  -- 'fireEventsAndRead'.   ---  -- If the event wasn't subscribed to before (either manually or through a dependent event or behavior)-  -- then this function will cause the event and all dependencies of this event to be set up.-  -- For example, if the event was created by 'newEventWithTrigger', then it's callback will be executed.+  -- If the event wasn't subscribed to before (either manually or through a+  -- dependent event or behavior) then this function will cause the event and+  -- all dependencies of this event to be set up.  For example, if the event was+  -- created by 'newEventWithTrigger', then it's callback will be executed.   --   -- It's safe to call this function multiple times.   subscribeEvent :: Event t a -> m (EventHandle t a)  -- | Monad that allows to read events' values. class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where-  -- | Read the value of an 'Event' from an 'EventHandle' (created by calling 'subscribeEvent').+  -- | Read the value of an 'Event' from an 'EventHandle' (created by calling+  -- 'subscribeEvent').   ---  -- After event propagation is done, all events can be in two states: either they are firing with some value or they are not firing.-  -- In the former case, this function returns @Just act@, where @act@ in an action to read the current value of-  -- the event. In the latter case, the function returns @Nothing@.+  -- After event propagation is done, all events can be in two states: either+  -- they are firing with some value or they are not firing.  In the former+  -- case, this function returns @Just act@, where @act@ in an action to read+  -- the current value of the event. In the latter case, the function returns+  -- @Nothing@.   --   -- This function is normally used in the calllback for 'fireEventsAndRead'.   readEvent :: EventHandle t a -> m (Maybe (m a))@@ -57,55 +92,70 @@ class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where   -- | Creates a root 'Event' (one that is not based on any other event).   ---  -- When a subscriber first subscribes to an event (building another event-  -- that depends on the subscription) the given callback function is run and-  -- passed a trigger. The callback function can then set up the event source in IO.-  -- After this is done, the callback function must return an accompanying teardown action.+  -- When a subscriber first subscribes to an event (building another event that+  -- depends on the subscription) the given callback function is run and passed+  -- a trigger. The callback function can then set up the event source in IO.+  -- After this is done, the callback function must return an accompanying+  -- teardown action.   ---  -- Any time between setup and teardown the trigger can be used to fire-  -- the event, by passing it to 'fireEventsAndRead'.+  -- Any time between setup and teardown the trigger can be used to fire the+  -- event, by passing it to 'fireEventsAndRead'.   ---  -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future.+  -- Note: An event may be set up multiple times. So after the teardown action+  -- is executed, the event may still be set up again in the future.   newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)   newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k) -class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, MonadReadEvent t (ReadPhase m), MonadSample t (ReadPhase m), MonadHold t (ReadPhase m)) => MonadReflexHost t m | m -> t where-  type ReadPhase m :: * -> *+-- | 'MonadReflexHost' designates monads that can run reflex frames.+class ( ReflexHost t+      , MonadReflexCreateTrigger t m+      , MonadSubscribeEvent t m+      , MonadReadEvent t (ReadPhase m)+      , MonadSample t (ReadPhase m)+      , MonadHold t (ReadPhase m)+      ) => MonadReflexHost t m | m -> t where+  type ReadPhase m :: Type -> Type   -- | Propagate some events firings and read the values of events afterwards.   ---  -- This function will create a new frame to fire the given events. It will then update all-  -- dependent events and behaviors. After that is done, the given callback is executed which-  -- allows to read the final values of events and check whether they have fired in this frame or-  -- not.+  -- This function will create a new frame to fire the given events. It will+  -- then update all dependent events and behaviors. After that is done, the+  -- given callback is executed which allows to read the final values of events+  -- and check whether they have fired in this frame or not.   --   -- All events that are given are fired at the same time.   ---  -- This function is typically used in the main loop of a reflex framework implementation.-  -- The main loop waits for external events to happen (such as keyboard input or a mouse click)-  -- and then fires the corresponding events using this function. The read callback can be used-  -- to read output events and perform a corresponding response action to the external event.-  fireEventsAndRead :: [DSum (EventTrigger t)] -> (ReadPhase m a) -> m a+  -- This function is typically used in the main loop of a reflex framework+  -- implementation.  The main loop waits for external events to happen (such as+  -- keyboard input or a mouse click) and then fires the corresponding events+  -- using this function. The read callback can be used to read output events+  -- and perform a corresponding response action to the external event.+  fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a    -- | Run a frame without any events firing.   ---  -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing.-  -- Using this function in that case can improve performance, since the implementation can assume that no events-  -- are firing when 'sample' or 'hold' are called.+  -- This function should be used when you want to use 'sample' and 'hold' when+  -- no events are currently firing.  Using this function in that case can+  -- improve performance, since the implementation can assume that no events are+  -- firing when 'sample' or 'hold' are called.   ---  -- This function is commonly used to set up the basic event network when the application starts up.+  -- This function is commonly used to set up the basic event network when the+  -- application starts up.   runHostFrame :: HostFrame t a -> m a  -- | Like 'fireEventsAndRead', but without reading any events.-fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m () fireEvents dm = fireEventsAndRead dm $ return () {-# INLINE fireEvents #-}  -- | Create a new event and store its trigger in an 'IORef' while it's active. ----- An event is only active between the set up (when it's first subscribed to) and the teardown phases (when noboby is subscribing the event anymore).--- This function returns an Event and an 'IORef'. As long as the event is active, the 'IORef' will contain 'Just' the event trigger to--- trigger this event. When the event is not active, the 'IORef' will contain 'Nothing'. This allows event sources to be more efficient,--- since they don't need to produce events when nobody is listening.+-- An event is only active between the set up (when it's first subscribed to)+-- and the teardown phases (when noboby is subscribing the event anymore).  This+-- function returns an Event and an 'IORef'. As long as the event is active, the+-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the+-- event is not active, the 'IORef' will contain 'Nothing'. This allows event+-- sources to be more efficient, since they don't need to produce events when+-- nobody is listening. newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a))) newEventWithTriggerRef = do   rt <- newRef Nothing@@ -115,23 +165,26 @@   return (e, rt) {-# INLINE newEventWithTriggerRef #-} +-- | Fire the given trigger if it is not 'Nothing'. fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m () fireEventRef mtRef input = do   mt <- readRef mtRef   case mt of     Nothing -> return ()-    Just trigger -> fireEvents [trigger :=> input]+    Just trigger -> fireEvents [trigger :=> Identity input] +-- | Fire the given trigger if it is not 'Nothing', and read from the given+-- 'EventHandle'. fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b) fireEventRefAndRead mtRef input e = do   mt <- readRef mtRef   case mt of     Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire-    Just trigger -> fireEventsAndRead [trigger :=> input] $ do+    Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do       mGetValue <- readEvent e       case mGetValue of         Nothing -> return Nothing-        Just getValue -> liftM Just getValue+        Just getValue -> fmap Just getValue   --------------------------------------------------------------------------------@@ -173,8 +226,8 @@   type ReadPhase (StateT s m) = ReadPhase m   fireEventsAndRead dm a = lift $ fireEventsAndRead dm a   runHostFrame = lift . runHostFrame-  -  ++ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where   newEventWithTrigger = lift . newEventWithTrigger   newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer@@ -185,9 +238,9 @@ instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where   type ReadPhase (Strict.StateT s m) = ReadPhase m   fireEventsAndRead dm a = lift $ fireEventsAndRead dm a-  runHostFrame = lift . runHostFrame  -  -  +  runHostFrame = lift . runHostFrame++  instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where   newEventWithTrigger = lift . newEventWithTrigger
+ src/Reflex/Host/Headless.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Reflex.Host.Headless where++import Control.Concurrent.Chan (newChan, readChan)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Fix (MonadFix, fix)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.Ref (MonadRef, Ref, readRef)+import Data.Dependent.Sum (DSum (..), (==>))+import Data.Foldable (for_, asum)+import Data.Functor.Identity (Identity(..))+import Data.IORef (IORef, readIORef)+import Data.Maybe (catMaybes)+import Data.Traversable (for)++import Reflex+import Reflex.Host.Class++type MonadHeadlessApp t m =+  ( Reflex t+  , Adjustable t m+  , MonadCatch m+  , MonadFix (Performable m)+  , MonadFix m+  , MonadHold t (Performable m)+  , MonadHold t m+  , MonadIO (HostFrame t)+  , MonadIO (Performable m)+  , MonadIO m+  , MonadMask m+  , MonadRef (HostFrame t)+  , MonadSample t (Performable m)+  , MonadSample t m+  , MonadThrow m+  , MonadThrow (Performable m)+  , NotReady t m+  , PerformEvent t m+  , PostBuild t m+  , PrimMonad (HostFrame t)+  , Ref (HostFrame t) ~ IORef+  , Ref m ~ IORef+  , ReflexHost t+  , TriggerEvent t m+  )++-- | Run a headless FRP network. Inside the action, you will most probably use+-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type+-- classes to interface the FRP network with the outside world. Useful for+-- testing. Each headless network runs on its own spider timeline.+runHeadlessApp+  :: forall a+  .  (forall t m. MonadHeadlessApp t m => m (Event t a))+  -- ^ The action to be run in the headless FRP network. The FRP network is+  -- closed at the first occurrence of the resulting 'Event'.+  -> IO a+runHeadlessApp guest =+  -- We are using the 'Spider' implementation of reflex. Running the host+  -- allows us to take actions on the FRP timeline.+  withSpiderTimeline $ runSpiderHostForTimeline $ do+    -- Create the "post-build" event and associated trigger. This event fires+    -- once, when the application starts.+    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef+    -- Create a queue to which we will write 'Event's that need to be+    -- processed.+    events <- liftIO newChan+    -- Run the "guest" application, providing the appropriate context. We'll+    -- pure the result of the action, and a 'FireCommand' that will be used to+    -- trigger events.+    (result, fc@(FireCommand fire)) <- do+      hostPerformEventT $                 -- Allows the guest app to run+                                          -- 'performEvent', so that actions+                                          -- (e.g., IO actions) can be run when+                                          -- 'Event's fire.++        flip runPostBuildT postBuild $    -- Allows the guest app to access to+                                          -- a "post-build" 'Event'++          flip runTriggerEventT events $  -- Allows the guest app to create new+                                          -- events and triggers and write+                                          -- those triggers to a channel from+                                          -- which they will be read and+                                          -- processed.+            guest++    -- Read the trigger reference for the post-build event. This will be+    -- 'Nothing' if the guest application hasn't subscribed to this event.+    mPostBuildTrigger <- readRef postBuildTriggerRef++    -- Subscribe to an 'Event' of that the guest application can use to+    -- request application shutdown. We'll check whether this 'Event' is firing+    -- to determine whether to terminate.+    shutdown <- subscribeEvent result++    -- When there is a subscriber to the post-build event, fire the event.+    initialShutdownEventFirings :: Maybe [Maybe a] <- for mPostBuildTrigger $ \postBuildTrigger ->+      fire [postBuildTrigger :=> Identity ()] $ sequence =<< readEvent shutdown+    let shutdownImmediately = case initialShutdownEventFirings of+          -- We didn't even fire postBuild because it wasn't subscribed+          Nothing -> Nothing+          -- Take the first Just, if there is one. Ideally, we should cut off+          -- the event loop as soon as the firing happens, but Performable+          -- doesn't currently give us an easy way to do that+          Just firings -> asum firings++    case shutdownImmediately of+      Just exitResult -> pure exitResult+      -- The main application loop. We wait for new events and fire those that+      -- have subscribers. If we detect a shutdown request, the application+      -- terminates.+      Nothing -> fix $ \loop -> do+        -- Read the next event (blocking).+        ers <- liftIO $ readChan events+        shutdownEventFirings :: [Maybe a] <- do+          -- Fire events that have subscribers.+          fireEventTriggerRefs fc ers $+            -- Check if the shutdown 'Event' is firing.+            sequence =<< readEvent shutdown+        let -- If the shutdown event fires multiple times, take the first one.+            -- Ideally, we should cut off the event loop as soon as this fires,+            -- but Performable doesn't currently give us an easy way to do that.+            shutdownNow = asum shutdownEventFirings+        case shutdownNow of+          Just exitResult -> pure exitResult+          Nothing -> loop+  where+    -- Use the given 'FireCommand' to fire events that have subscribers+    -- and call the callback for the 'TriggerInvocation' of each.+    fireEventTriggerRefs+      :: forall b m t+      .  MonadIO m+      => FireCommand t m+      -> [DSum (EventTriggerRef t) TriggerInvocation]+      -> ReadPhase m b+      -> m [b]+    fireEventTriggerRefs (FireCommand fire) ers rcb = do+      mes <- liftIO $+        for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do+          me <- readIORef er+          pure $ fmap (==> a) me+      a <- fire (catMaybes mes) rcb+      liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb+      pure a
+ src/Reflex/Network.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module:+--   Reflex.Network+-- Description:+--   This module provides combinators for building FRP graphs/networks and modifying them dynamically.+module Reflex.Network+  ( networkView+  , networkHold+  , untilReady+  ) where++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.NotReady.Class+import Reflex.PostBuild.Class++-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates.+-- The returned Event of network results fires at post-build time and when the 'Dynamic' updates.+-- Note:  Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires+-- when switching networks. Such an 'Event' would typically be flattened (via 'switchHoldPromptly').+networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)+networkView child = do+  postBuild <- getPostBuild+  let newChild = leftmost [updated child, tagCheap (current child) postBuild]+  snd <$> runWithReplace notReady newChild++-- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires.+-- The returned Dynamic of network results occurs when the Event does.+-- Note:  Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened (via 'switchPromptlyDyn').+networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)+networkHold child0 newChild = do+  (result0, newResult) <- runWithReplace child0 newChild+  holdDyn result0 newResult++-- | Render a placeholder network to be shown while another network is not yet+-- done building+untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)+untilReady a b = do+  postBuild <- getPostBuild+  runWithReplace a $ b <$ postBuild
+ src/Reflex/NotReady/Class.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.NotReady.Class+  ( NotReady(..)+  ) where++import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans+import Control.Monad.Trans.Writer (WriterT)++import Reflex.BehaviorWriter.Base (BehaviorWriterT)+import Reflex.Class+import Reflex.DynamicWriter.Base (DynamicWriterT)+import Reflex.EventWriter.Base (EventWriterT)+import Reflex.Host.Class+import Reflex.PerformEvent.Base (PerformEventT (..))+import Reflex.PostBuild.Base (PostBuildT)+import Reflex.Query.Base (QueryT)+import Reflex.Requester.Base (RequesterT)+import Reflex.TriggerEvent.Base (TriggerEventT)++class Monad m => NotReady t m | m -> t where+  notReadyUntil :: Event t a -> m ()+  default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m ()+  notReadyUntil = lift . notReadyUntil++  notReady :: m ()+  default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()+  notReady = lift notReady++instance NotReady t m => NotReady t (ReaderT r m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (PostBuildT t m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (EventWriterT t w m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (DynamicWriterT t w m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (BehaviorWriterT t w m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (QueryT t q m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where+  notReadyUntil = PerformEventT . notReadyUntil+  notReady = PerformEventT notReady++instance NotReady t m => NotReady t (RequesterT t request response m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady++instance NotReady t m => NotReady t (TriggerEventT t m) where+  notReadyUntil = lift . notReadyUntil+  notReady = lift notReady
+ src/Reflex/PerformEvent/Base.hs view
@@ -0,0 +1,185 @@+-- | This module provides 'PerformEventT', the standard implementation of+-- 'PerformEvent'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.PerformEvent.Base+  ( PerformEventT (..)+  , FireCommand (..)+  , hostPerformEventT+  ) where++import Reflex.Adjustable.Class+import Reflex.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.Requester.Base+import Reflex.Requester.Class++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Data.Coerce+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum+import Data.Functor.Identity+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Semigroup as S++#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif++-- | A function that fires events for the given 'EventTrigger's and then runs+-- any followup actions provided via 'PerformEvent'.  The given 'ReadPhase'+-- action will be run once for the initial trigger execution as well as once for+-- each followup.+newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?++-- | Provides a basic implementation of 'PerformEvent'.  Note that, despite the+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }++deriving instance ReflexHost t => Functor (PerformEventT t m)+deriving instance ReflexHost t => Applicative (PerformEventT t m)+deriving instance ReflexHost t => Monad (PerformEventT t m)+deriving instance ReflexHost t => MonadFix (PerformEventT t m)+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)+deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)+deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)+deriving instance (ReflexHost t, MonadCatch (HostFrame t)) => MonadCatch (PerformEventT t m)+deriving instance (ReflexHost t, MonadThrow (HostFrame t)) => MonadThrow (PerformEventT t m)+deriving instance (ReflexHost t, MonadMask (HostFrame t)) => MonadMask (PerformEventT t m)++instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where+  type PrimState (PerformEventT t m) = PrimState (HostFrame t)+  primitive = PerformEventT . lift . primitive++instance (Monad (HostFrame t), ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where+  type Performable (PerformEventT t m) = HostFrame t+  {-# INLINABLE performEvent_ #-}+  performEvent_ = PerformEventT . requesting_+  {-# INLINABLE performEvent #-}+  performEvent = PerformEventT . requestingIdentity++instance ReflexHost t => Adjustable t (PerformEventT t m) where+  runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')+    where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)+          f a0 a' = do+            result0 <- lift a0+            result' <- requestingIdentity a'+            return (result0, result')+  traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')+  traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')+  traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')++defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), Reflex t)+  => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))+  -> (forall a. k' a -> v a -> HostFrame t (v2 a))+  -> DMap k' v+  -> Event t (p k' v)+  -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))+defaultAdjustBase traversePatchWithKey f' dm0 dm' = do+  result0 <- lift $ DMap.traverseWithKey f' dm0+  result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'+  return (result0, result')++defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), Reflex t)+  => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))+  -> (IntMap.Key -> v -> HostFrame t v2)+  -> IntMap v+  -> Event t (p v)+  -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do+  result0 <- lift $ IntMap.traverseWithKey f' dm0+  result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'+  return (result0, result')++instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where+  {-# INLINABLE newEventWithTrigger #-}+  newEventWithTrigger = PerformEventT . lift . newEventWithTrigger+  {-# INLINABLE newFanEventWithTrigger #-}+  newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f++-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run+-- at the appropriate time.+{-# INLINABLE hostPerformEventT #-}+hostPerformEventT :: forall t m a.+                     ( MonadReflexHost t m+                     , MonadRef m+                     , Ref m ~ Ref IO+                     )+                  => PerformEventT t m a+                  -> m (a, FireCommand t m)+hostPerformEventT a = do+  (response, responseTrigger) <- newEventWithTriggerRef+  (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response+  eventToPerformHandle <- subscribeEvent eventToPerform+  return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do+    let go :: [DSum (EventTrigger t) Identity] -> m [a']+        go ts = do+          (result', mToPerform) <- fireEventsAndRead ts $ do+            mToPerform <- sequence =<< readEvent eventToPerformHandle+            result' <- readPhase+            return (result', mToPerform)+          case mToPerform of+            Nothing -> return [result']+            Just toPerform -> do+              responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform+              mrt <- readRef responseTrigger+              let followupEventTriggers = case mrt of+                    Just rt -> [rt :=> Identity responses]+                    Nothing -> []+              (result':) <$> go followupEventTriggers+    go triggers++instance ReflexHost t => MonadSample t (PerformEventT t m) where+  {-# INLINABLE sample #-}+  sample = PerformEventT . lift . sample++instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where+  {-# INLINABLE hold #-}+  hold v0 v' = PerformEventT $ lift $ hold v0 v'+  {-# INLINABLE holdDyn #-}+  holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'+  {-# INLINABLE buildDynamic #-}+  buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'+  {-# INLINABLE headE #-}+  headE = PerformEventT . lift . headE+  {-# INLINABLE now #-}+  now = PerformEventT . lift $ now++instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where+  type Ref (PerformEventT t m) = Ref (HostFrame t)+  {-# INLINABLE newRef #-}+  newRef = PerformEventT . lift . newRef+  {-# INLINABLE readRef #-}+  readRef = PerformEventT . lift . readRef+  {-# INLINABLE writeRef #-}+  writeRef r = PerformEventT . lift . writeRef r++instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where+  {-# INLINABLE atomicModifyRef #-}+  atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
+ src/Reflex/PerformEvent/Class.hs view
@@ -0,0 +1,72 @@+-- | This module defines 'PerformEvent', which mediates the+-- interaction between a "Reflex"-based program and the external side-effecting+-- actions such as 'IO'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.PerformEvent.Class+  ( PerformEvent (..)+  , performEventAsync+  ) where++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.Kind (Type)++#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Fix+#endif++import Reflex.Class+import Reflex.TriggerEvent.Class++-- | 'PerformEvent' represents actions that can trigger other actions based on+-- 'Event's.+class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where+  -- | The type of action to be triggered; this is often not the same type as+  -- the triggering action.+  type Performable m :: Type -> Type+  -- | Perform the action contained in the given 'Event' whenever the 'Event'+  -- fires.  Return the result in another 'Event'.  Note that the output 'Event'+  -- will generally occur later than the input 'Event', since most 'Performable'+  -- actions cannot be performed during 'Event' propagation.+  performEvent :: Event t (Performable m a) -> m (Event t a)+  -- | Like 'performEvent', but do not return the result.  May have slightly+  -- better performance.+  performEvent_ :: Event t (Performable m ()) -> m ()++-- | Like 'performEvent', but the resulting 'Event' occurs only when the+-- callback (@a -> IO ()@) is called, not when the included action finishes.+--+-- NOTE: Despite the name, 'performEventAsync' does not run its action in a+-- separate thread - although the action is free to invoke forkIO and then call+-- the callback whenever it is ready.  This will work properly, even in GHCJS+-- (which fully implements concurrency even though JavaScript does not have+-- built in concurrency).+{-# INLINABLE performEventAsync #-}+performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)+performEventAsync e = do+  (eOut, triggerEOut) <- newTriggerEvent+  performEvent_ $ fmap ($ triggerEOut) e+  return eOut++instance PerformEvent t m => PerformEvent t (ReaderT r m) where+  type Performable (ReaderT r m) = ReaderT r (Performable m)+  performEvent_ e = do+    r <- ask+    lift $ performEvent_ $ flip runReaderT r <$> e+  performEvent e = do+    r <- ask+    lift $ performEvent $ flip runReaderT r <$> e++instance PerformEvent t m => PerformEvent t (MaybeT m) where+  type Performable (MaybeT m) = MaybeT (Performable m)+  performEvent_ = lift . performEvent_ . fmapCheap (void . runMaybeT)+  performEvent = lift . fmap (fmapMaybe id) . performEvent . fmapCheap runMaybeT
+ src/Reflex/PostBuild/Base.hs view
@@ -0,0 +1,213 @@+-- | This module defines 'PostBuildT', the standard implementation of+-- 'PostBuild'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.PostBuild.Base+  ( PostBuildT (..)+  , runPostBuildT+  -- * Internal+  , mapIntMapWithAdjustImpl+  , mapDMapWithAdjustImpl+  ) where++import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import qualified Control.Monad.Trans.Control as TransControl+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Functor.Compose+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Semigroup as S++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Control.Monad.Identity+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.TriggerEvent.Class++-- | Provides a basic implementation of 'PostBuild'.+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadFix+    , MonadIO+    , MonadTrans+    , MonadException+    , MonadAsyncException+    , MonadMask+    , MonadThrow+    , MonadCatch+    )++-- | Run a 'PostBuildT' action.  An 'Event' should be provided that fires+-- immediately after the action is finished running; no other 'Event's should+-- fire first.+{-# INLINABLE runPostBuildT #-}+runPostBuildT :: PostBuildT t m a -> Event t () -> m a+runPostBuildT (PostBuildT a) = runReaderT a++-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.+instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where+  mempty = pure mempty++instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where+  (<>) = liftA2 (S.<>)++instance PrimMonad m => PrimMonad (PostBuildT x m) where+  type PrimState (PostBuildT x m) = PrimState m+  primitive = lift . primitive++instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where+  {-# INLINABLE getPostBuild #-}+  getPostBuild = PostBuildT ask++instance MonadSample t m => MonadSample t (PostBuildT t m) where+  {-# INLINABLE sample #-}+  sample = lift . sample++instance MonadHold t m => MonadHold t (PostBuildT t m) where+  {-# INLINABLE hold #-}+  hold v0 = lift . hold v0+  {-# INLINABLE holdDyn #-}+  holdDyn v0 = lift . holdDyn v0+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 = lift . holdIncremental v0+  {-# INLINABLE buildDynamic #-}+  buildDynamic a0 = lift . buildDynamic a0+  {-# INLINABLE headE #-}+  headE = lift . headE+  {-# INLINABLE now #-}+  now = lift now++instance PerformEvent t m => PerformEvent t (PostBuildT t m) where+  type Performable (PostBuildT t m) = Performable m+  {-# INLINABLE performEvent_ #-}+  performEvent_ = lift . performEvent_+  {-# INLINABLE performEvent #-}+  performEvent = lift . performEvent++instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where+  {-# INLINABLE newEventWithTrigger #-}+  newEventWithTrigger = PostBuildT . lift . newEventWithTrigger+  {-# INLINABLE newFanEventWithTrigger #-}+  newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f++instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where+  {-# INLINABLE newTriggerEvent #-}+  newTriggerEvent = lift newTriggerEvent+  {-# INLINABLE newTriggerEventWithOnComplete #-}+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance MonadRef m => MonadRef (PostBuildT t m) where+  type Ref (PostBuildT t m) = Ref m+  {-# INLINABLE newRef #-}+  newRef = lift . newRef+  {-# INLINABLE readRef #-}+  readRef = lift . readRef+  {-# INLINABLE writeRef #-}+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where+  {-# INLINABLE atomicModifyRef #-}+  atomicModifyRef r = lift . atomicModifyRef r++instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where+  runWithReplace a0 a' = do+    postBuild <- getPostBuild+    lift $ do+      rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'+          let voidResult' = fmapCheap (\_ -> ()) result'+      return result+  {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}+  traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap+  traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove++{-# INLINABLE mapIntMapWithAdjustImpl #-}+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)+  => (   (IntMap.Key -> (Event t (), v) -> m v')+      -> IntMap (Event t (), v)+      -> Event t (p (Event t (), v))+      -> m (IntMap v', Event t (p v'))+     )+  -> (IntMap.Key -> v -> PostBuildT t m v')+  -> IntMap v+  -> Event t (p v)+  -> PostBuildT t m (IntMap v', Event t (p v'))+mapIntMapWithAdjustImpl base f dm0 dm' = do+  postBuild <- getPostBuild+  let loweredDm0 = fmap ((,) postBuild) dm0+      f' :: IntMap.Key -> (Event t (), v) -> m v'+      f' k (e, v) = do+        runPostBuildT (f k v) e+  lift $ do+    rec (result0, result') <- base f' loweredDm0 loweredDm'+        cohortDone <- numberOccurrencesFrom_ 1 result'+        numberedDm' <- numberOccurrencesFrom 1 dm'+        let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone+            loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do+              return $ fmap ((,) (selectInt postBuild' n)) p+    return (result0, result')++{-# INLINABLE mapDMapWithAdjustImpl #-}+mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)+  => (   (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))+      -> DMap k (Compose ((,) (Bool, Event t ())) v)+      -> Event t (p k (Compose ((,) (Bool, Event t ())) v))+      -> m (DMap k v', Event t (p k v'))+     )+  -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))+  -> (forall a. k a -> v a -> PostBuildT t m (v' a))+  -> DMap k v+  -> Event t (p k v)+  -> PostBuildT t m (DMap k v', Event t (p k v'))+mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do+  postBuild <- getPostBuild+  let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0+      f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)+      f' k (Compose ((shouldHeadE, e), v)) = do+        eOnce <- if shouldHeadE+          then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence+          else return e+        runPostBuildT (f k v) eOnce+  lift $ do+    rec (result0, result') <- base f' loweredDm0 loweredDm'+        let voidResult' = fmapCheap (\_ -> ()) result'+        let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))+    return (result0, result')++--------------------------------------------------------------------------------+-- Deprecated functionality+--------------------------------------------------------------------------------++-- | Deprecated+instance TransControl.MonadTransControl (PostBuildT t) where+  type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a+  {-# INLINABLE liftWith #-}+  liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT+  {-# INLINABLE restoreT #-}+  restoreT = TransControl.defaultRestoreT PostBuildT
+ src/Reflex/PostBuild/Class.hs view
@@ -0,0 +1,38 @@+-- | This module defines 'PostBuild', which indicates that an action will be+-- notified when it, and any action it's a part of, has finished executing.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.PostBuild.Class+  ( PostBuild (..)+  ) where++import Reflex.Class++import Control.Monad.Reader+import Control.Monad.State+import qualified Control.Monad.State.Strict as Strict++-- | 'PostBuild' represents an action that is notified via an 'Event' when it+-- has finished executing.  Note that the specific definition of "finished" is+-- determined by the instance of 'PostBuild', but the intent is to allow+-- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they+-- were created, when the post-build 'Event' fires.  The post-build 'Event' will+-- fire exactly once for an given action.+class (Reflex t, Monad m) => PostBuild t m | m -> t where+  -- | Retrieve the post-build 'Event' for this action.+  getPostBuild :: m (Event t ())++instance PostBuild t m => PostBuild t (ReaderT r m) where+  getPostBuild = lift getPostBuild++instance PostBuild t m => PostBuild t (StateT s m) where+  getPostBuild = lift getPostBuild++instance PostBuild t m => PostBuild t (Strict.StateT s m) where+  getPostBuild = lift getPostBuild
+ src/Reflex/Profiled.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module:+--   Reflex.Profiled+-- Description:+--   This module contains an instance of the 'Reflex' class that provides+--   profiling/cost-center information.+module Reflex.Profiled where++import Control.Monad+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict (StateT, execStateT, modify)+import Data.Bifunctor+import Data.Coerce+import Data.Dependent.Map (DMap)+import Data.GADT.Compare (GCompare)+import Data.FastMutableIntMap+import Data.IORef+import Data.List+import Data.Kind (Type)+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Ord+import Data.Profunctor.Unsafe ((#.))+import qualified Data.Semigroup as S+import Data.Type.Coercion+import Foreign.Ptr+import GHC.Foreign+import GHC.IO.Encoding+import GHC.Stack+import System.IO.Unsafe++#if !MIN_VERSION_base(4,18,0)+import Data.Monoid ((<>))+#endif++import Reflex.Adjustable.Class+import Reflex.BehaviorWriter.Class+import Reflex.Class+import Reflex.DynamicWriter.Class+import Reflex.EventWriter.Class+import Reflex.Host.Class+import Reflex.NotReady.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Query.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++data ProfiledTimeline t++{-# NOINLINE profilingData #-}+profilingData :: IORef (Map (Ptr CostCentreStack) Int)+profilingData = unsafePerformIO $ newIORef Map.empty++data CostCentreTree = CostCentreTree+  { _costCentreTree_ownEntries :: !Int+  , _costCentreTree_cumulativeEntries :: !Int+  , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)+  }+  deriving (Show, Eq, Ord)++instance S.Semigroup CostCentreTree where+  (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =+      CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb++instance Monoid CostCentreTree where+  mempty = CostCentreTree 0 0 mempty+  mappend = (S.<>)++getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]+getCostCentreStack = go []+  where go l ccs = if ccs == nullPtr+          then return l+          else do+          cc <- ccsCC ccs+          parent <- ccsParent ccs+          go (cc : l) parent++toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree+toCostCentreTree ccs n =+  foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)+    <$> getCostCentreStack ccs++getCostCentreTree :: IO CostCentreTree+getCostCentreTree = do+  vals <- readIORef profilingData+  mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)++formatCostCentreTree :: CostCentreTree -> IO String+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []+  where go :: Int -> CostCentreTree -> StateT [String] IO ()+        go depth cct = do+          let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct+              indent = mconcat $ replicate depth "  "+          forM_ children $ \(cc, childCct) -> do+            lbl <- liftIO $ peekCString utf8 =<< ccLabel cc+            mdl <- liftIO $ peekCString utf8 =<< ccModule cc+            loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc+            let description = mdl <> "." <> lbl <> " (" <> loc <> ")"+            modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)+            go (succ depth) childCct++showProfilingData :: IO ()+showProfilingData = do+  putStr =<< formatCostCentreTree =<< getCostCentreTree++writeProfilingData :: FilePath -> IO ()+writeProfilingData p = do+  writeFile p =<< formatCostCentreTree =<< getCostCentreTree++newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)++profileEvent :: Reflex t => Event t a -> Event t a+profileEvent e = unsafePerformIO $ do+  stack <- getCurrentCCS e+  let f x = unsafePerformIO $ do+        modifyIORef' profilingData $ Map.insertWith (+) stack 1+        return $ return $ Just x+  return $ pushCheap f e++--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs++instance Reflex t => Reflex (ProfiledTimeline t) where+  newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }+  newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }+  newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }+  newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }+  type PushM (ProfiledTimeline t) = ProfiledM (PushM t)+  type PullM (ProfiledTimeline t) = ProfiledM (PullM t)+  never = Event_Profiled never+  constant = Behavior_Profiled . constant+  push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us+  pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e+  pull = Behavior_Profiled . pull . coerce+  fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)+  mergeG :: forall z (k :: z -> Type) q v. GCompare k+    => (forall a. q a -> Event (ProfiledTimeline t) (v a))+    -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)+  mergeG nt = Event_Profiled #. mergeG (coerce nt)+  switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)+  coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)+  current (Dynamic_Profiled d) = coerce $ current d+  updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d+  unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'+  unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'+  mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)+  mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)+  currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i+  updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i+  incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i+  behaviorCoercion c =+    Coercion `trans` behaviorCoercion @t c `trans` Coercion+  eventCoercion c =+    Coercion `trans` eventCoercion @t c `trans` Coercion+  dynamicCoercion c =+    Coercion `trans` dynamicCoercion @t c `trans` Coercion+  incrementalCoercion c d =+    Coercion `trans` incrementalCoercion @t c d `trans` Coercion+  mergeIntIncremental = Event_Profiled . mergeIntIncremental .+    coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)+  fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e++deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))++instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where+  hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'+  holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'+  holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'+  buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'+  headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e+  now = ProfiledM $ Event_Profiled <$> now++instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where+  sample (Behavior_Profiled b) = ProfiledM $ sample b++instance Adjustable t m => Adjustable (ProfiledTimeline t) (ProfiledM m) where+  runWithReplace a0 a' = (fmap . fmap) coerce . lift $+    runWithReplace (coerce a0) (coerce $ coerce <$> a')+  traverseIntMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $+    traverseIntMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')+  traverseDMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $+    traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = (fmap . fmap) coerce . lift $+    traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) dm0 (coerce dm')++instance MonadTrans ProfiledM where+  lift = ProfiledM++instance MonadIO m => MonadIO (ProfiledM m) where+  liftIO = lift . liftIO++instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where+  type Performable (ProfiledM m) = Performable m+  performEvent_ = lift . performEvent_ . coerce+  performEvent = lift . fmap coerce . performEvent . coerce++instance TriggerEvent t m => TriggerEvent (ProfiledTimeline t) (ProfiledM m) where+  newTriggerEvent = first coerce <$> lift newTriggerEvent+  newTriggerEventWithOnComplete = first coerce <$> lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete f = coerce <$> lift (newEventWithLazyTriggerWithOnComplete f)++instance PostBuild t m => PostBuild (ProfiledTimeline t) (ProfiledM m) where+  getPostBuild = coerce <$> lift getPostBuild++instance NotReady t m => NotReady (ProfiledTimeline t) (ProfiledM m) where+  notReady = lift notReady+  notReadyUntil = lift . notReadyUntil . coerce++instance BehaviorWriter t w m => BehaviorWriter (ProfiledTimeline t) w (ProfiledM m) where+  tellBehavior = lift . tellBehavior . coerce++instance DynamicWriter t w m => DynamicWriter (ProfiledTimeline t) w (ProfiledM m) where+  tellDyn = lift . tellDyn . coerce++instance EventWriter t w m => EventWriter (ProfiledTimeline t) w (ProfiledM m) where+  tellEvent = lift . tellEvent . coerce++instance MonadQuery t q m => MonadQuery (ProfiledTimeline t) q (ProfiledM m) where+  tellQueryIncremental = lift . tellQueryIncremental . coerce+  askQueryResult = coerce <$> lift askQueryResult+  queryIncremental = fmap coerce . lift . queryIncremental . coerce++instance Requester t m => Requester (ProfiledTimeline t) (ProfiledM m) where+  type Request (ProfiledM m) = Request m+  type Response (ProfiledM m) = Response m++  requesting = fmap coerce . lift . requesting . coerce+  requesting_ = lift . requesting_ . coerce++instance MonadRef m => MonadRef (ProfiledM m) where+  type Ref (ProfiledM m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where+  newEventWithTrigger = lift . fmap coerce . newEventWithTrigger+  newFanEventWithTrigger f = do+    es <- lift $ newFanEventWithTrigger f+    return $ EventSelector $ \k -> coerce $ select es k++instance MonadReader r m => MonadReader r (ProfiledM m) where+  ask = lift ask+  local f (ProfiledM a) = ProfiledM $ local f a+  reader = lift . reader++instance ReflexHost t => ReflexHost (ProfiledTimeline t) where+  type EventTrigger (ProfiledTimeline t) = EventTrigger t+  type EventHandle (ProfiledTimeline t) = EventHandle t+  type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)++instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where+  subscribeEvent = lift . subscribeEvent . coerce++instance PrimMonad m => PrimMonad (ProfiledM m) where+  type PrimState (ProfiledM m) = PrimState m+  primitive = lift . primitive++instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where+  type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)+  fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r+  runHostFrame = lift . runHostFrame . coerce++instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where+  readEvent = lift . fmap coerce . readEvent
+ src/Reflex/Pure.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+-- There are two expected orphan instances in this module:+--   * MonadSample (Pure t) ((->) t)+--   * MonadHold (Pure t) ((->) t)+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Reflex.Pure+-- Description:+--   This module provides a pure implementation of Reflex, which is intended to+--   serve as a reference for the semantics of the Reflex class.  All+--   implementations of Reflex should produce the same results as this+--   implementation, although performance and laziness/strictness may differ.+module Reflex.Pure+  ( Pure+  , Behavior (..)+  , Event (..)+  , Dynamic (..)+  , Incremental (..)+  ) where++import Control.Monad+import Data.Dependent.Map (DMap)+import Data.GADT.Compare (GCompare)+import qualified Data.Dependent.Map as DMap+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Maybe+import Data.MemoTrie+import Data.Monoid+import Data.Type.Coercion+import Reflex.Class+import Data.Kind (Type)++-- | A completely pure-functional 'Reflex' timeline, identifying moments in time+-- with the type @/t/@.+data Pure (t :: Type)++-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist+-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used+-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where++  newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }+  newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }+  newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }+  newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }++  type PushM (Pure t) = (->) t+  type PullM (Pure t) = (->) t++  never :: Event (Pure t) a+  never = Event $ \_ -> Nothing++  constant :: a -> Behavior (Pure t) a+  constant x = Behavior $ \_ -> x++  push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b+  push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t++  pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b+  pushCheap = push++  pull :: PullM (Pure t) a -> Behavior (Pure t) a+  pull = Behavior . memo++  -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a+  -- warning because the GCompare instance is not used; however, removing the+  -- GCompare instance produces a different warning, due to that constraint+  -- being present in the original class definition.++  --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))+  --   -> DMap k q -> Event (Pure t) (DMap k v)+  mergeG nt events = Event $ memo $ \t ->+    let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events+    in if DMap.null currentOccurrences+       then Nothing+       else Just currentOccurrences++--  The instance signature doeesn't compile, leave commented for documentation+--  fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v+  fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k++  switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a+  switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t++  coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a+  coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t++  current :: Dynamic (Pure t) a -> Behavior (Pure t) a+  current d = Behavior $ \t -> fst $ unDynamic d t++  updated :: Dynamic (Pure t) a -> Event (Pure t) a+  updated d = Event $ \t -> snd $ unDynamic d t++  unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a+  unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)++  -- See UNUSED_CONSTRAINT, above.++  --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p+  --a) -> Incremental (Pure t) p a+  unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)++  mergeIncrementalG = mergeIncrementalImpl+  mergeIncrementalWithMoveG = mergeIncrementalImpl++  currentIncremental i = Behavior $ \t -> fst $ unIncremental i t++  updatedIncremental i = Event $ \t -> snd $ unIncremental i t++  incrementalToDynamic i = Dynamic $ \t ->+    let (old, mPatch) = unIncremental i t+        e = case mPatch of+          Nothing -> Nothing+          Just patch -> apply patch old+    in (old, e)+  behaviorCoercion Coercion = Coercion+  eventCoercion Coercion = Coercion+  dynamicCoercion Coercion = Coercion+  incrementalCoercion Coercion Coercion = Coercion++  fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k++  mergeIntIncremental = mergeIntIncrementalImpl++mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)+  => (forall a. q a -> Event (Pure t) (v a))+  -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)+mergeIncrementalImpl nt i = Event $ \t ->+  let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t+  in if DMap.null results+     then Nothing+     else Just results++mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)+mergeIntIncrementalImpl i = Event $ \t ->+  let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t+  in if IntMap.null results+     then Nothing+     else Just results++instance Functor (Dynamic (Pure t)) where+  fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t+                             in (f cur, fmap f upd)++instance Applicative (Dynamic (Pure t)) where+  pure a = Dynamic $ \_ -> (a, Nothing)+  (<*>) = ap++instance Monad (Dynamic (Pure t)) where+  return = pure+  (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->+    let (curX :: a, updX :: Maybe a) = unDynamic x t+        (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t+        (updInner :: Maybe b, updBoth :: Maybe b) = case updX of+          Nothing -> (Nothing, Nothing)+          Just nextX -> let (c, u) = unDynamic (f nextX) t+                        in (Just c, u)+    in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])++instance MonadSample (Pure t) ((->) t) where++  sample :: Behavior (Pure t) a -> (t -> a)+  sample = unBehavior++instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where++  hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a+  hold initialValue e initialTime = Behavior f+    where f = memo $ \sampleTime ->+            -- Really, the sampleTime should never be prior to the initialTime,+            -- because that would mean the Behavior is being sampled before+            -- being created.+            if sampleTime <= initialTime+            then initialValue+            else let lastTime = pred sampleTime+                 in fromMaybe (f lastTime) $ unEvent e lastTime++  holdDyn v0 = buildDynamic (return v0)++  buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a+  buildDynamic initialValue e initialTime =+    let Behavior f = hold (initialValue initialTime) e initialTime+    in Dynamic $ \t -> (f t, unEvent e t)++  holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p+  holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)+    where f = memo $ \sampleTime ->+            -- Really, the sampleTime should never be prior to the initialTime,+            -- because that would mean the Behavior is being sampled before+            -- being created.+            if sampleTime <= initialTime+            then initialValue+            else let lastTime = pred sampleTime+                     lastValue = f lastTime+                 in case unEvent e lastTime of+                   Nothing -> lastValue+                   Just x -> fromMaybe lastValue $ apply x lastValue++  headE = slowHeadE+  now t = Event $ guard . (t ==)
+ src/Reflex/Query/Base.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Reflex.Query.Base+  ( QueryT (..)+  , runQueryT+  , mapQuery+  , mapQueryResult+  , dynWithQueryT+  , withQueryT+  , mapQueryT+  ) where++import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Morph+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Align+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum(..))+import Data.Foldable+import Data.Functor.Compose+import Data.Functor.Misc+import Data.GADT.Compare (GCompare)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Kind (Type)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Semigroup as S+import Data.Semigroup.Commutative+import Data.Some (Some(Some))+import Data.These++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.DynamicWriter.Class+import Reflex.EventWriter.Base+import Reflex.EventWriter.Class+import Reflex.Host.Class+import qualified Data.Patch.MapWithMove as MapWithMove+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Query.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }+  deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef, MonadCatch, MonadThrow, MonadMask)++deriving instance MonadHold t m => MonadHold t (QueryT t q m)+deriving instance MonadSample t m => MonadSample t (QueryT t q m)++runQueryT :: (MonadFix m, Commutative q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))+runQueryT (QueryT a) qr = do+  ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr+  return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))++newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])++getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v++getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w++maskMempty :: (Eq a, Monoid a) => a -> Maybe a+maskMempty x = if x == mempty then Nothing else Just x++instance (Reflex t, MonadFix m, Group q, Commutative q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where+  runWithReplace (QueryT a0) a' = do+    ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'+    let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q+        sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty+        bs' = fmapCheap snd $ r'+    bbs <- hold bs0 bs'+    let patches = flip pushCheap bs' $ \newBs -> do+          oldBs <- sample bbs+          maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)+    QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs+    QueryT $ lift $ tellEvent patches+    return (r0, fmapCheap fst r')++  traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v'))+  traverseIntMapWithKeyWithAdjust f im0 im' = do+    let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')+        f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v+    (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'+    let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0+        liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $+          IntMap.map (fmap getQueryTLoweredResultValue) p+        liftedBs0 :: IntMap [Behavior t q]+        liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0+        liftedBs' :: Event t (PatchIntMap [Behavior t q])+        liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $+          IntMap.map (fmap getQueryTLoweredResultWritten) p+        sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q+        sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty+        accumBehaviors :: forall m'. MonadHold t m'+                       => IntMap [Behavior t q]+                       -> PatchIntMap [Behavior t q]+                       -> m' ( Maybe (IntMap [Behavior t q])+                             , Maybe (AdditivePatch q))+        -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.+        -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.+        -- bs0 is a Map denoting the behaviors of the current children.+        -- pbs is a PatchMap denoting an update to the behaviors of the current children+        accumBehaviors bs0 pbs@(PatchIntMap bs') = do+          let p k bs = case IntMap.lookup k bs0 of+                Nothing -> case bs of+                  -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.+                  Nothing -> return mempty+                  -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.+                  Just newBs -> sampleBs newBs+                Just oldBs -> case bs of+                  -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state+                  Nothing -> negateG <$> sampleBs oldBs+                  -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state+                  -- composed with the sampling the child's new state.+                  Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs+          -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the+          -- child patches and wrap them in AdditivePatch.+          patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'+          return (apply pbs bs0, Just patch)+    (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'+    tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch+    return (liftedResult0, liftedResult')++  traverseDMapWithKeyWithAdjust :: forall (k :: Type -> Type) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))+  traverseDMapWithKeyWithAdjust f dm0 dm' = do+    let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)+        f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v+    (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'+    let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0+        liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $+          mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p+        liftedBs0 :: Map (Some k) [Behavior t q]+        liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0+        liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])+        liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $+          Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p+        sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q+        sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty+        accumBehaviors :: forall m'. MonadHold t m'+                       => Map (Some k) [Behavior t q]+                       -> PatchMap (Some k) [Behavior t q]+                       -> m' ( Maybe (Map (Some k) [Behavior t q])+                             , Maybe (AdditivePatch q))+        -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.+        -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.+        -- bs0 is a Map denoting the behaviors of the current children.+        -- pbs is a PatchMap denoting an update to the behaviors of the current children+        accumBehaviors bs0 pbs@(PatchMap bs') = do+          let p k bs = case Map.lookup k bs0 of+                Nothing -> case bs of+                  -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.+                  Nothing -> return Nothing+                  -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.+                  Just newBs -> maskMempty <$> sampleBs newBs+                Just oldBs -> case bs of+                  -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state+                  Nothing -> maskMempty . negateG <$> sampleBs oldBs+                  -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state+                  -- composed with the sampling the child's new state.+                  Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)+          -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the+          -- child patches and wrap them in AdditivePatch.+          patch <- fold <$> Map.traverseWithKey p bs'+          return (apply pbs bs0, AdditivePatch <$> patch)+    (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'+    tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch+    return (liftedResult0, liftedResult')++  traverseDMapWithKeyWithAdjustWithMove :: forall (k :: Type -> Type) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do+    let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)+        f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v+    (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'+    let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0+        liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)+        liftedBs0 :: Map (Some k) [Behavior t q]+        liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0+        liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])+        liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $+          Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}+        sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q+        sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty+        accumBehaviors' :: forall m'. MonadHold t m'+                        => Map (Some k) [Behavior t q]+                        -> PatchMapWithMove (Some k) [Behavior t q]+                        -> m' ( Maybe (Map (Some k) [Behavior t q])+                              , Maybe (AdditivePatch q))+        -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.+        -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.+        -- bs0 is a Map denoting the behaviors of the current children.+        -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children+        accumBehaviors' bs0 pbs = do+          let bs' = unPatchMapWithMove pbs+              p k bs = case Map.lookup k bs0 of+                Nothing -> case MapWithMove._nodeInfo_from bs of+                  -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.+                  MapWithMove.From_Delete -> return Nothing+                  -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.+                  MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs+                  MapWithMove.From_Move k' -> case Map.lookup k' bs0 of+                    Nothing -> return Nothing+                    Just newBs -> maskMempty <$> sampleBs newBs+                Just oldBs -> case MapWithMove._nodeInfo_from bs of+                  -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state+                  MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs+                  -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state+                  -- composed with the sampling the child's new state.+                  MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)+                  MapWithMove.From_Move k'+                    | k' == k -> return Nothing+                    | otherwise -> case Map.lookup k' bs0 of+                  -- If we are moving from a non-existent key, that is a delete+                        Nothing -> maskMempty . negateG <$> sampleBs oldBs+                        Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)+          -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the+          -- child patches and wrap them in AdditivePatch.+          patch <- fold <$> Map.traverseWithKey p bs'+          return (apply pbs bs0, AdditivePatch <$> patch)+    (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'+    tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch+    return (liftedResult0, liftedResult')++instance MonadTrans (QueryT t q) where+  lift = QueryT . lift . lift . lift++instance MFunctor (QueryT t q) where+  hoist = mapQueryT++instance PrimMonad m => PrimMonad (QueryT t q m) where+  type PrimState (QueryT t q m) = PrimState m+  primitive = lift . primitive++instance PostBuild t m => PostBuild t (QueryT t q m) where+  getPostBuild = lift getPostBuild++instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where+  mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT++instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance PerformEvent t m => PerformEvent t (QueryT t q m) where+  type Performable (QueryT t q m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance MonadRef m => MonadRef (QueryT t q m) where+  type Ref (QueryT t q m) = Ref m+  newRef = QueryT . newRef+  readRef = QueryT . readRef+  writeRef r = QueryT . writeRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where+  newEventWithTrigger = QueryT . newEventWithTrigger+  newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a++-- TODO: Monoid and Semigroup can likely be derived once StateT has them.+instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where+  mempty = pure mempty+  mappend = (<>)++instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where+  (<>) = liftA2 (S.<>)++-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly+withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Commutative q, Commutative q', Query q')+           => QueryMorphism q q'+           -> QueryT t q m a+           -> QueryT t q' m a+withQueryT f a = do+  r' <- askQueryResult+  (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'+  tellQueryIncremental $ unsafeBuildIncremental+    (fmap (mapQuery f) (sample (currentIncremental q)))+    (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)+  return result++-- | Maps a function over a 'QueryT' that can change the underlying monad+mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a+mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a++-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly+dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Commutative q, Group q', Commutative q', Query q')+           => Dynamic t (QueryMorphism q q')+           -> QueryT t q m a+           -> QueryT t q' m a+dynWithQueryT f q = do+  r' <- askQueryResult+  (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'+  tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'+  return result+ where zipDynIncrementalWith g da ib =+         let eab = align (updated da) (updatedIncremental ib)+             ec = flip push eab $ \case+                 This a -> do+                   aOld <- sample $ current da+                   b <- sample $ currentIncremental ib+                   return $ Just $ AdditivePatch (g a b ~~ g aOld b)+                 That (AdditivePatch b) -> do+                   a <- sample $ current da+                   return $ Just $ AdditivePatch $ g a b+                 These a (AdditivePatch b) -> do+                   aOld <- sample $ current da+                   bOld <- sample $ currentIncremental ib+                   return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]+         in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec++instance (Monad m, Group q, Commutative q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where+  tellQueryIncremental q = do+    QueryT (modify (currentIncremental q:))+    QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))+  askQueryResult = QueryT ask+  queryIncremental q = do+    tellQueryIncremental q+    zipDynWith crop (incrementalToDynamic q) <$> askQueryResult++instance Requester t m => Requester t (QueryT t q m) where+  type Request (QueryT t q m) = Request m+  type Response (QueryT t q m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++instance EventWriter t w m => EventWriter t w (QueryT t q m) where+  tellEvent = lift . tellEvent++instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where+  tellDyn = lift . tellDyn
+ src/Reflex/Query/Class.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module:+--   Reflex.Query.Class+-- Description:+--   A class that ties together queries to some data source and their results,+--   providing methods for requesting data from the source and accumulating+--   streamed results.+module Reflex.Query.Class+  ( Query (..)+  , QueryMorphism (..)+  , SelectedCount (..)+  , combineSelectedCounts++  , MonadQuery (..)+  , tellQueryDyn+  , queryDyn+  , subQuery+  , mapQuery+  , mapQueryResult+  ) where++import Control.Category (Category)+import qualified Control.Category as Cat+import Control.Monad.Reader+import Data.Bits+import Data.Data+import Data.Ix+import Data.Kind (Type)+import Data.Map.Monoidal (MonoidalMap)+import qualified Data.Map.Monoidal as MonoidalMap+import Data.Semigroup.Commutative+import Data.Void+import Data.Monoid hiding ((<>))+import Foreign.Storable++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+import Data.Semigroup (Semigroup(..))+#endif++import Reflex.Class++-- | A 'Query' can be thought of as a declaration of interest in some set of data.+-- A 'QueryResult' is the set of data associated with that interest set.+-- The @crop@ function provides a way to determine what part of a given 'QueryResult'+-- is relevant to a given 'Query'.+class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where+  type QueryResult a :: Type+  crop :: a -> QueryResult a -> QueryResult a++instance (Ord k, Query v) => Query (MonoidalMap k v) where+  type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)+  crop q r = MonoidalMap.intersectionWith (flip crop) r q++-- | the result of two queries is both results.+instance (Query a, Query b) => Query (a, b) where+  type QueryResult (a, b) = (QueryResult a, QueryResult b)+  crop (x, x') (y, y') = (crop x y, crop x' y')++-- | Trivial queries have trivial results.+instance Query () where+  type QueryResult () = ()+  crop _ _ = ()++-- | The result of an absurd query is trivial; If you can ask the question, the+-- answer cannot tell you anything you didn't already know.+--+-- 'QueryResult Void = @Void@' seems like it would also work, but that has+-- problems of robustness. In some applications, an unasked question can still+-- be answered, so it is important that the result is inhabited even when the+-- question isn't. Applications that wish to prevent this can mandate that the+-- query result be paired with the query: then the whole response will be+-- uninhabited as desired.+instance Query Void where+  type QueryResult Void = ()+  crop = absurd++#if MIN_VERSION_base(4,12,0)+-- | We can lift queries into monoidal containers.+-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)+instance (Query q, Applicative f) => Query (Ap f q) where+  type QueryResult (Ap f q) = Ap f (QueryResult q)+  crop = liftA2 crop+#endif++-- | QueryMorphism's must be group homomorphisms when acting on the query type+-- and compatible with the query relationship when acting on the query result.+data QueryMorphism q q' = QueryMorphism+  { _queryMorphism_mapQuery :: q -> q'+  , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q+  }++instance Category QueryMorphism where+  id = QueryMorphism id id+  qm . qm' = QueryMorphism+    { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'+    , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm+    }++-- | Apply a 'QueryMorphism' to a 'Query'+mapQuery :: QueryMorphism q q' -> q -> q'+mapQuery = _queryMorphism_mapQuery++-- | Map a 'QueryMorphism' to a 'QueryResult'+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q+mapQueryResult = _queryMorphism_mapQueryResult++-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on+-- 'combineSelectedCounts'+newtype SelectedCount = SelectedCount { unSelectedCount :: Int }+  deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)++instance Semigroup SelectedCount where+  SelectedCount a <> SelectedCount b = SelectedCount (a + b)++instance Monoid SelectedCount where+  mempty = SelectedCount 0+  mappend = (<>)++instance Group SelectedCount where+  negateG (SelectedCount a) = SelectedCount (negate a)++instance Commutative SelectedCount++-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use+-- this function which returns Nothing if the result is 0. This allows the pruning of leaves+-- of the 'Query' that are no longer wanted.+combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount+combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)++-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly+-- used interface.+class (Group q, Commutative q, Query q, Monad m) => MonadQuery t q m | m -> q t where+  tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()+  askQueryResult :: m (Dynamic t (QueryResult q))+  queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))++instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where+  tellQueryIncremental = lift . tellQueryIncremental+  askQueryResult = lift askQueryResult+  queryIncremental = lift . queryIncremental++-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.+tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()+tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)++-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.+queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))+queryDyn q = do+  tellQueryDyn q+  zipDynWith crop q <$> askQueryResult++-- | Use a query morphism to operate on a smaller version of a query.+subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)
+ src/Reflex/Requester/Base.hs view
@@ -0,0 +1,21 @@+module Reflex.Requester.Base+  ( RequesterT (..)+  , runRequesterT+  , withRequesterT+  , runWithReplaceRequesterTWith+  , traverseIntMapWithKeyWithAdjustRequesterTWith+  , traverseDMapWithKeyWithAdjustRequesterTWith+  , RequesterData+  , RequesterDataKey+  , traverseRequesterData+  , forRequesterData+  , requesterDataToList+  , singletonRequesterData+  , matchResponsesWithRequests+  , matchResponseMapWithRequests+  , multiEntry+  , unMultiEntry+  , requesting'+  ) where++import Reflex.Requester.Base.Internal
+ src/Reflex/Requester/Base/Internal.hs view
@@ -0,0 +1,596 @@+-- | This module provides 'RequesterT', the standard implementation of+-- 'Requester'.+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Requester.Base.Internal where++import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Morph+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Bits+import Data.Coerce+import Data.Constraint+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum (..))+import Data.Functor.Compose+import Data.Functor.Misc+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy+import Data.Some (Some(Some))+import Data.Type.Equality+import Data.Unique.Tag++import GHC.Exts (Any)+import Unsafe.Coerce++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Dynamic+import Reflex.EventWriter.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++--TODO: Make this module type-safe++newtype TagMap (f :: Type -> Type) = TagMap (IntMap Any)++newtype RequesterData f = RequesterData (TagMap (Entry f))++emptyRequesterData :: RequesterData f+emptyRequesterData = RequesterData $ TagMap IntMap.empty++data RequesterDataKey a where+  RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a+  RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead+  RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a+  RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a++singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f+singletonRequesterData rdk v = case rdk of+  RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v+  RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v+  RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents+    { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v+    , _multi2Contents_dict = Dict+    }+  RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v++mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b++mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)+mergeTagMap (TagMap m) (TagMap n) =+  TagMap $ IntMap.unionWithKey (g' combiner) m n+  where+    combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a+    combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of+      MyTagType_Single -> a+      MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b+      MyTagType_Multi2 -> case _multi2Contents_dict a of+        Dict -> Multi2Contents+          { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)+          , _multi2Contents_dict = Dict+          }+      MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b+    g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any+    g' f rawKey a b =+      let k = MyTag rawKey :: MyTag a+          fromAny :: Any -> Entry f a+          fromAny = unsafeCoerce+          toAny :: Entry f a -> Any+          toAny = unsafeCoerce+      in toAny $ f k (fromAny a) (fromAny b)++requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]+requesterDataToList (RequesterData m) = do+  k :=> Entry e <- tagMapToList m+  case myKeyType k of+    MyTagType_Single -> return $ RequesterDataKey_Single k :=> e+    MyTagType_Multi -> do+      (k', e') <- IntMap.toList e+      k'' :=> e'' <- requesterDataToList e'+      return $ RequesterDataKey_Multi k k' k'' :=> e''+    MyTagType_Multi2 -> case _multi2Contents_dict e of+      Dict -> do+        (k', e') <- Map.toList $ _multi2Contents_values e+        (k'', e'') <- IntMap.toList e'+        k''' :=> e''' <- requesterDataToList e''+        return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''+    MyTagType_Multi3 -> do+      (k', e') <- IntMap.toList e+      (k'', e'') <- IntMap.toList e'+      k''' :=> e''' <- requesterDataToList e''+      return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''++singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v++tagMapToList :: forall f. TagMap f -> [DSum MyTag f]+tagMapToList (TagMap m) = f <$> IntMap.toList m+  where f :: (Int, Any) -> DSum MyTag f+        f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v++traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m+  where+    g :: Int -> Any -> t Any+    g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)++-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order+  where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)+        go k (Entry request) = Entry <$> case myKeyType k of+          MyTagType_Single -> f request+          MyTagType_Multi -> traverse (traverseRequesterData f) request+          MyTagType_Multi2 -> case request of+            Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do+              v <- traverse (traverse (traverseRequesterData f)) request'+              pure $ Multi2Contents+                { _multi2Contents_values = v+                , _multi2Contents_dict = Dict+                }+          MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request++-- | 'traverseRequesterData' with its arguments flipped+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)+forRequesterData r f = traverseRequesterData f r++data MyTagType :: Type -> Type where+  MyTagType_Single :: MyTagType (Single a)+  MyTagType_Multi :: MyTagType Multi+  MyTagType_Multi2 :: MyTagType (Multi2 k)+  MyTagType_Multi3 :: MyTagType Multi3++myKeyType :: MyTag x -> MyTagType x+myKeyType (MyTag k) = case k .&. 0x3 of+  0x0 -> unsafeCoerce MyTagType_Single+  0x1 -> unsafeCoerce MyTagType_Multi+  0x2 -> unsafeCoerce MyTagType_Multi2+  0x3 -> unsafeCoerce MyTagType_Multi3+  t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t++data Single a+data Multi+data Multi2 (k :: Type -> Type)+data Multi3++class MyTagTypeOffset x where+  myTagTypeOffset :: proxy x -> Int++instance MyTagTypeOffset (Single a) where+  myTagTypeOffset _ = 0x0++instance MyTagTypeOffset Multi where+  myTagTypeOffset _ = 0x1++instance MyTagTypeOffset (Multi2 k) where+  myTagTypeOffset _ = 0x2++instance MyTagTypeOffset Multi3 where+  myTagTypeOffset _ = 0x3++type family EntryContents request a where+  EntryContents request (Single a) = request a+  EntryContents request Multi = IntMap (RequesterData request)+  EntryContents request (Multi2 k) = Multi2Contents k request+  EntryContents request Multi3 = IntMap (IntMap (RequesterData request))++data Multi2Contents k request = Multi2Contents+  { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances+  , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))+  }++newtype Entry request x = Entry { unEntry :: EntryContents request x }++{-# INLINE singleEntry #-}+singleEntry :: f a -> Entry f (Single a)+singleEntry = Entry++{-# INLINE multiEntry #-}+multiEntry :: IntMap (RequesterData f) -> Entry f Multi+multiEntry = Entry++{-# INLINE unMultiEntry #-}+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)+unMultiEntry = unEntry++-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes+-- WARNING: This type should never be exposed.  In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)++newtype MyTagWrap (f :: Type -> Type) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)++{-# INLINE castMyTagWrap #-}+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)+castMyTagWrap = coerce++instance GEq MyTag where+  (MyTag a) `geq` (MyTag b) =+    if a == b+    then Just $ unsafeCoerce Refl+    else Nothing++instance GCompare MyTag where+  (MyTag a) `gcompare` (MyTag b) =+    case a `compare` b of+      LT -> GLT+      EQ -> unsafeCoerce GEQ+      GT -> GGT++instance GEq (MyTagWrap f) where+  (MyTagWrap a) `geq` (MyTagWrap b) =+    if a == b+    then Just $ unsafeCoerce Refl+    else Nothing++instance GCompare (MyTagWrap f) where+  (MyTagWrap a) `gcompare` (MyTagWrap b) =+    case a `compare` b of+      LT -> GLT+      EQ -> unsafeCoerce GEQ+      GT -> GGT++data RequesterState t (request :: Type -> Type) = RequesterState+  { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom+  , _requesterState_requests :: ![(Int, Event t Any)]+  }++-- | A basic implementation of 'Requester'.+newtype RequesterT t request (response :: Type -> Type) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException+           , MonadAsyncException+           , MonadCatch+           , MonadThrow+           , MonadMask+           )++deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)++instance EventWriter t w m => EventWriter t w (RequesterT t request response m) where+  tellEvent = lift . tellEvent++instance PrimMonad m => PrimMonad (RequesterT t request response m) where+  type PrimState (RequesterT t request response m) = PrimState m+  primitive = lift . primitive++-- TODO: Monoid and Semigroup can likely be derived once StateT has them.+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where+  mempty = pure mempty++instance (Semigroup a, Monad m) => Semigroup (RequesterT t request response m a) where+  (<>) = liftA2 (<>)+++-- | Run a 'RequesterT' action.  The resulting 'Event' will fire whenever+-- requests are made, and responses should be provided in the input 'Event'.+-- The 'Tag' keys will be used to return the responses to the same place the+-- requests were issued.+runRequesterT :: (Reflex t, Monad m)+              => RequesterT t request response m a+              -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse+              -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild+runRequesterT (RequesterT a) responses = do+  (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $+    coerceEvent responses+  return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)++-- | Map a function over the request and response of a 'RequesterT'+withRequesterT+  :: (Reflex t, MonadFix m)+  => (forall x. req x -> req' x) -- ^ The function to map over the request+  -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response+  -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed+  -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'+withRequesterT freq frsp child = do+  rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'+      (a, req) <- lift $ runRequesterT child rsp+      rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $+        fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req+  return a++instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where+  type Request (RequesterT t request response m) = request+  type Response (RequesterT t request response m) = response+  requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))+  requesting_ = void . tagRequest . fmapCheap singleEntry++{-# INLINE tagRequest #-}+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))+tagRequest req = do+  old <- RequesterT get+  let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)+      t = MyTagWrap n+  RequesterT $ put $ RequesterState+    { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4+    , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old+    }+  return t++{-# INLINE responseFromTag #-}+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))+responseFromTag (MyTagWrap t) = do+  responses :: EventSelectorInt t Any <- RequesterT ask+  return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t++instance MonadTrans (RequesterT t request response) where+  lift = RequesterT . lift . lift++instance MFunctor (RequesterT t request response) where+  hoist f = RequesterT . hoist (hoist f) . unRequesterT++instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where+  type Performable (RequesterT t request response m) = Performable m+  performEvent_ = lift . performEvent_+  performEvent = lift . performEvent++instance MonadRef m => MonadRef (RequesterT t request response m) where+  type Ref (RequesterT t request response m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where+  newEventWithTrigger = lift . newEventWithTrigger+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance MonadReader r m => MonadReader r (RequesterT t request response m) where+  ask = lift ask+  local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a+  reader = lift . reader++instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where+  runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'+  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental+  traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove++requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))+requesting' = responseFromTag . castMyTagWrap <=< tagRequest++{-# INLINABLE runWithReplaceRequesterTWith #-}+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m+                                                                 , MonadFix m+                                                                 )+                             => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))+                             -> RequesterT t request response m a+                             -> Event t (RequesterT t request response m b)+                             -> RequesterT t request response m (a, Event t b)+runWithReplaceRequesterTWith f a0 a' = do+  rec na' <- numberOccurrencesFrom 1 a'+      responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here+      let responses' = fanInt responses+      ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'+      requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'+  return (result0, fmapCheap (fst . snd) v')++{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.+                                        ( Reflex t+                                        , MonadHold t m+                                        , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))+                                        , Patch (p (Event t (IntMap (RequesterData request))))+                                        , Functor p+                                        , MonadFix m+                                        )+                                     => (   (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))+                                         -> IntMap (IntMap.Key, v)+                                         -> Event t (p (IntMap.Key, v))+                                         -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))+                                        )+                                     -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))+                                     -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))+                                     -> (IntMap.Key -> v -> RequesterT t request response m v')+                                     -> IntMap v+                                     -> Event t (p v)+                                     -> RequesterT t request response m (IntMap v', Event t (p v'))+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do+  rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here+      let responses :: EventSelectorInt t (IntMap (RequesterData response))+          responses = fanInt $ fmapCheap unpack response+          unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))+          unpack = unEntry+          pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3+          pack = Entry+          f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')+          f' k (n, v) = do+            (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?+            return (fmapCheap (IntMap.singleton n) myRequests, result)+      ndm' <- numberOccurrencesFrom 1 dm'+      (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable+      let result0 = fmap snd children0+          result' = fforCheap children' $ fmap snd+          requests0 :: IntMap (Event t (IntMap (RequesterData request)))+          requests0 = fmap fst children0+          requests' :: Event t (p (Event t (IntMap (RequesterData request))))+          requests' = fforCheap children' $ fmap fst+          promptRequests :: Event t (IntMap (IntMap (RequesterData request)))+          promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'+      requests <- holdIncremental requests0 requests'+  return (result0, result')++{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.+                                        ( GCompare k+                                        , Reflex t+                                        , MonadHold t m+                                        , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))+                                        , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))+                                        , MonadFix m+                                        )+                                     => (forall k' v1 v2. GCompare k'+                                         => (forall a. k' a -> v1 a -> m (v2 a))+                                         -> DMap k' v1+                                         -> Event t (p k' v1)+                                         -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))+                                        )+                                     -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)+                                     -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)+                                     -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)+                                     -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))+                                     -> (forall a. k a -> v a -> RequesterT t request response m (v' a))+                                     -> DMap k v+                                     -> Event t (p k v)+                                     -> RequesterT t request response m (DMap k v', Event t (p k v'))+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do+  rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here+      let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))+          responses = fanMap $ fmapCheap unpack response+          unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))+          unpack = _multi2Contents_values . unEntry+          pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)+          pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }+          f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)+          f' k (Compose (n, v)) = do+            (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))+            return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)+      ndm' <- numberOccurrencesFrom 1 dm'+      (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'+      let result0 = DMap.map (snd . getCompose) children0+          result' = fforCheap children' $ mapPatch $ snd . getCompose+          requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))+          requests0 = weakenDMapWith (fst . getCompose) children0+          requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))+          requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose+          promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))+          promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'+      requests <- holdIncremental requests0 requests'+  return (result0, result')++data Decoder rawResponse response =+  forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)++matchResponsesWithRequests+  :: forall t rawRequest rawResponse request response m.+     ( MonadFix m+     , MonadHold t m+     , Reflex t+     )+  => (forall a. request a -> (rawRequest, rawResponse -> response a))+  -- ^ Given a request (from 'Requester'), produces the wire format of the+  -- request and a function used to process the associated response+  -> Event t (RequesterData request)+  -- ^ The outgoing requests+  -> Event t (Int, rawResponse)+  -- ^ The incoming responses, tagged by an identifying key+  -> m ( Event t (Map Int rawRequest)+       , Event t (RequesterData response)+       )+  -- ^ A map of outgoing wire-format requests and an event of responses keyed+  -- by the 'RequesterData' key of the associated outgoing request+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv++-- | Matches incoming responses with previously-sent requests+-- and uses the provided request "decoder" function to process+-- incoming responses.+matchResponseMapWithRequests+  :: forall t rawRequest rawResponse request response m.+     ( MonadFix m+     , MonadHold t m+     , Reflex t+     )+  => (forall a. request a -> (rawRequest, rawResponse -> response a))+  -- ^ Given a request (from 'Requester'), produces the wire format of the+  -- request and a function used to process the associated response+  -> Event t (RequesterData request)+  -- ^ The outgoing requests+  -> Event t (Map Int rawResponse)+  -- ^ A map of incoming responses, tagged by an identifying key+  -> m ( Event t (Map Int rawRequest)+       , Event t (RequesterData response)+       )+  -- ^ A map of outgoing wire-format requests and an event of responses keyed+  -- by the 'RequesterData' key of the associated outgoing request+matchResponseMapWithRequests f send recv = do+  rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing+      waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-+        holdIncremental mempty $ leftmost+          [ fmap (\(_, outstanding, _) -> outstanding) outgoing+          , snd <$> incoming+          ]+      let outgoing = processOutgoing nextId send+          incoming = processIncoming waitingFor recv+  return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)+  where+    -- Tags each outgoing request with an identifying integer key+    -- and returns the next available key, a map of response decoders+    -- for requests for which there are outstanding responses, and the+    -- raw requests to be sent out.+    processOutgoing+      :: Behavior t Int+      -- The next available key+      -> Event t (RequesterData request)+      -- The outgoing request+      -> Event t ( Int+                 , PatchMap Int (Decoder rawResponse response)+                 , Map Int rawRequest )+      -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests+    processOutgoing nextId out = flip pushAlways out $ \dm -> do+      oldNextId <- sample nextId+      let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do+            n <- get+            put $ succ n+            let (rawReq, rspF) = f v+            return (n, rawReq, Decoder k rspF)+          patchWaitingFor = PatchMap $ Map.fromList $+            (\(n, _, dec) -> (n, Just dec)) <$> result+          toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result+      return (newNextId, patchWaitingFor, toSend)+    -- Looks up the each incoming raw response in a map of response+    -- decoders and returns the decoded response and a patch that can+    -- be used to clear the ID of the consumed response out of the queue+    -- of expected responses.+    processIncoming+      :: Incremental t (PatchMap Int (Decoder rawResponse response))+      -- A map of outstanding expected responses+      -> Event t (Map Int rawResponse)+      -- A incoming response paired with its identifying key+      -> Event t (RequesterData response, PatchMap Int v)+      -- The decoded response and a patch that clears the outstanding responses queue+    processIncoming waitingFor inc = flip push inc $ \rspMap -> do+      wf <- sample $ currentIncremental waitingFor+      let match rawRsp (Decoder k rspF) =+            let rsp = rspF rawRsp+            in singletonRequesterData k rsp+          matches = Map.intersectionWith match rspMap wf+      pure $ if Map.null matches then Nothing else Just+        (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
+ src/Reflex/Requester/Class.hs view
@@ -0,0 +1,75 @@+-- | This module defines 'Requester', which indicates that an action can make+-- requests and receive responses to them.  Typically, this is used for things+-- like a WebSocket, where it's desirable to collect many potential sources of+-- events and send them over a single channel, then distribute the results back+-- out efficiently to their original request sites.+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Requester.Class+ ( Requester (..)+ , withRequesting+ , requestingIdentity+ ) where++import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Reader+import qualified Control.Monad.State.Lazy as Lazy+import Control.Monad.State.Strict+import Data.Kind (Type)+import Reflex.Class++-- | A 'Requester' action can trigger requests of type @Request m a@ based on+-- 'Event's, and receive responses of type @Response m a@ in return.  Note that+-- the @a@ type can vary within the 'Requester' action, but will be linked for a+-- given request.  For example, if @Request m@ is 'IO' and @Response m@ is+-- 'Identity', then 'requestingIdentity' has the same type as+-- 'Reflex.PerformEvent.Class.performEvent'.+class (Reflex t, Monad m) => Requester t m | m -> t where+  -- | The type of requests that this 'Requester' can emit+  type Request m :: Type -> Type+  -- | The type of responses that this 'Requester' can receive+  type Response m :: Type -> Type+  -- | Emit a request whenever the given 'Event' fires, and return responses in+  -- the resulting 'Event'.+  --+  -- Semantically, the response event occurs at a later time than the request event.+  requesting :: Event t (Request m a) -> m (Event t (Response m a))+  -- | Emit a request whenever the given 'Event' fires, and ignore all responses.+  requesting_ :: Event t (Request m a) -> m ()+++instance Requester t m => Requester t (ReaderT r m) where+  type Request (ReaderT r m) = Request m+  type Response (ReaderT r m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++instance Requester t m => Requester t (StateT s m) where+  type Request (StateT s m) = Request m+  type Response (StateT s m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++instance Requester t m => Requester t (Lazy.StateT s m) where+  type Request (Lazy.StateT s m) = Request m+  type Response (Lazy.StateT s m) = Response m+  requesting = lift . requesting+  requesting_ = lift . requesting_++-- | Emit a request whenever the given 'Event' fires, and unwrap the responses+-- before returning them.  @Response m@ must be 'Identity'.+requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)+requestingIdentity = fmap coerceEvent . requesting++withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r+withRequesting f = do+  rec response <- requesting request+      (request, result) <- f response+  return result
src/Reflex/Spider.hs view
@@ -1,5 +1,21 @@-module Reflex.Spider ( Spider-                     , SpiderHost (..) --Temporary, until Widget no longer uses unsafePerformIO-                     ) where+{-# LANGUAGE CPP #-}++-- |+-- Module:+--   Reflex.Spider+-- Description:+--   This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine+module Reflex.Spider+  ( Spider+  , SpiderTimeline+  , Global+  , SpiderHost+  , runSpiderHost+  , runSpiderHostForTimeline+  , newSpiderTimeline+  , withSpiderTimeline+    -- * Deprecated+  , SpiderEnv+  ) where  import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hs view
@@ -1,1440 +1,2962 @@-{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}-module Reflex.Spider.Internal where--import qualified Reflex.Class as R-import qualified Reflex.Host.Class as R--import Data.IORef-import System.Mem.Weak-import Data.Foldable-import Data.Traversable-import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)-import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)-import GHC.Exts-import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2-import Data.Dependent.Map (DMap, DSum (..))-import qualified Data.Dependent.Map as DMap-import Data.GADT.Compare-import Data.Functor.Misc-import Data.Maybe-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Control.Monad.Ref-import Control.Monad.Exception-import Data.Monoid ((<>))--import System.IO.Unsafe-import Unsafe.Coerce-import Control.Monad.Primitive---- Note: must come last to silence warnings due to AMP on GHC < 7.10-import Prelude hiding (mapM, mapM_, any, sequence, concat)--debugPropagate :: Bool--debugInvalidateHeight :: Bool--#ifdef DEBUG--#define DEBUG_NODEIDS--debugPropagate = True--debugInvalidateHeight = True--class HasNodeId a where-  getNodeId :: a -> Int--instance HasNodeId (Hold a) where-  getNodeId = holdNodeId--instance HasNodeId (PushSubscribed a b) where-  getNodeId = pushSubscribedNodeId--instance HasNodeId (SwitchSubscribed a) where-  getNodeId = switchSubscribedNodeId--instance HasNodeId (MergeSubscribed a) where-  getNodeId = mergeSubscribedNodeId--instance HasNodeId (FanSubscribed a) where-  getNodeId = fanSubscribedNodeId--instance HasNodeId (CoincidenceSubscribed a) where-  getNodeId = coincidenceSubscribedNodeId--instance HasNodeId (RootSubscribed a) where-  getNodeId = rootSubscribedNodeId--showNodeId :: HasNodeId a => a -> String-showNodeId = ("#"<>) . show . getNodeId--#else--debugPropagate = False--debugInvalidateHeight = False--showNodeId :: a -> String-showNodeId = const ""--#endif--#ifdef DEBUG_NODEIDS-{-# NOINLINE nextNodeIdRef #-}-nextNodeIdRef :: IORef Int-nextNodeIdRef = unsafePerformIO $ newIORef 1--{-# NOINLINE unsafeNodeId #-}-unsafeNodeId :: a -> Int-unsafeNodeId a = unsafePerformIO $ do-  touch a-  atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)-#endif----TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce---type role Hold representational-data Hold a-   = Hold { holdValue :: !(IORef a)-          , holdInvalidators :: !(IORef [Weak Invalidator])-            -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'-          , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef-          , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef-#ifdef DEBUG_NODEIDS-          , holdNodeId :: Int-#endif-          }--data EventEnv-   = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])-              , eventEnvHoldInits :: !(IORef [SomeHoldInit])-              , eventEnvClears :: !(IORef [SomeMaybeIORef])-              , eventEnvRootClears :: !(IORef [SomeDMapIORef])-              , eventEnvCurrentHeight :: !(IORef Int)-              , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])-              , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))-              }--runEventM :: EventM a -> EventEnv -> IO a-runEventM = runReaderT . unEventM--askToAssignRef :: EventM (IORef [SomeAssignment])-askToAssignRef = EventM $ asks eventEnvAssignments--askHoldInitRef :: EventM (IORef [SomeHoldInit])-askHoldInitRef = EventM $ asks eventEnvHoldInits--getCurrentHeight :: EventM Int-getCurrentHeight = EventM $ do-  heightRef <- asks eventEnvCurrentHeight-  liftIO $ readIORef heightRef--putCurrentHeight :: Int -> EventM ()-putCurrentHeight h = EventM $ do-  heightRef <- asks eventEnvCurrentHeight-  liftIO $ writeIORef heightRef h--scheduleClear :: IORef (Maybe a) -> EventM ()-scheduleClear r = EventM $ do-  clears <- asks eventEnvClears-  liftIO $ modifyIORef' clears (SomeMaybeIORef r :)--scheduleRootClear :: IORef (DMap k) -> EventM ()-scheduleRootClear r = EventM $ do-  clears <- asks eventEnvRootClears-  liftIO $ modifyIORef' clears (SomeDMapIORef r :)--scheduleMerge :: Int -> MergeSubscribed a -> EventM ()-scheduleMerge height subscribed = EventM $ do-  delayedRef <- asks eventEnvDelayedMerges-  liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]--emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()-emitCoincidenceInfo sci = EventM $ do-  ciRef <- asks eventEnvCoincidenceInfos-  liftIO $ modifyIORef' ciRef (sci:)---- Note: hold cannot examine its event until after the phase is over-hold :: a -> Event a -> EventM (Behavior a)-hold v0 e = do-  holdInitRef <- askHoldInitRef-  liftIO $ do-    valRef <- newIORef v0-    invsRef <- newIORef []-    parentRef <- newIORef $ error "hold not yet initialized (parent)"-    subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"-    let h = Hold-          { holdValue = valRef-          , holdInvalidators = invsRef-          , holdSubscriber = subscriberRef-          , holdParent = parentRef-#ifdef DEBUG_NODEIDS-          , holdNodeId = unsafeNodeId (v0, e)-#endif-          }-    s <- newSubscriberHold h-    writeIORef subscriberRef $ unsafeCoerce s-    modifyIORef' holdInitRef (SomeHoldInit e h :)-    return $ BehaviorHold h--subscribeHold :: Event a -> Hold a -> EventM ()-subscribeHold e h = do-  toAssignRef <- askToAssignRef-  !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item-  ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"-  subd <- subscribe e $ WeakSubscriberSimple ws-  liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd-  occ <- liftIO $ getEventSubscribedOcc subd-  case occ of-    Nothing -> return ()-    Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)----type role BehaviorM representational--- BehaviorM can sample behaviors-newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)--data BehaviorSubscribed a-   = BehaviorSubscribedHold (Hold a)-   | BehaviorSubscribedPull (PullSubscribed a)--data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)----type role PullSubscribed representational-data PullSubscribed a-   = PullSubscribed { pullSubscribedValue :: !a-                    , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])-                    , pullSubscribedOwnInvalidator :: !Invalidator-                    , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated-                    }----type role Pull representational-data Pull a-   = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))-          , pullCompute :: !(BehaviorM a)-          }--data Invalidator-   = forall a. InvalidatorPull (Pull a)-   | forall a. InvalidatorSwitch (SwitchSubscribed a)--data RootSubscribed a-   = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])-                    , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence-                    }--data Root (k :: * -> *)-   = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event-          , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))-          , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))-          }--data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)---- EventM can do everything BehaviorM can, plus create holds-newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over--data PushSubscribed a b-   = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)-                    , pushSubscribedHeight :: !(IORef Int)-                    , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])-                    , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die-                    , pushSubscribedParent :: !(EventSubscribed a)-#ifdef DEBUG_NODEIDS-                    , pushSubscribedNodeId :: Int-#endif-                    }--data Push a b-   = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed-          , pushParent :: !(Event a)-          , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?-          }--data MergeSubscribed k-   = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))-                     , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence-                     , mergeSubscribedHeight :: !(IORef Int)-                     , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])-                     , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory-                     , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))-#ifdef DEBUG_NODEIDS-                     , mergeSubscribedNodeId :: Int-#endif-                     }----TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)-data Merge k-   = Merge { mergeParents :: !(DMap (WrapArg Event k))-           , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?-           }--data FanSubscriberKey k a where-  FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]--instance GEq k => GEq (FanSubscriberKey k) where-  geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of-    Nothing -> Nothing-    Just Refl -> Just Refl--instance GCompare k => GCompare (FanSubscriberKey k) where-  gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of-    GLT -> GLT-    GEQ -> GEQ-    GGT -> GGT--data FanSubscribed k-   = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))-                   , fanSubscribedParent :: !(EventSubscribed (DMap k))-                   , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))-#ifdef DEBUG_NODEIDS-                   , fanSubscribedNodeId :: Int-#endif-                   }--data Fan k-   = Fan { fanParent :: !(Event (DMap k))-         , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))-         }--data SwitchSubscribed a-   = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))-                      , switchSubscribedHeight :: !(IORef Int)-                      , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])-                      , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)-                      , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))-                      , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator-                      , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))-                      , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])-                      , switchSubscribedParent :: !(Behavior (Event a))-                      , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))-#ifdef DEBUG_NODEIDS-                      , switchSubscribedNodeId :: Int-#endif-                      }--data Switch a-   = Switch { switchParent :: !(Behavior (Event a))-            , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))-            }--data CoincidenceSubscribed a-   = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))-                           , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])-                           , coincidenceSubscribedHeight :: !(IORef Int)-                           , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))-                           , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))-                           , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))-#ifdef DEBUG_NODEIDS-                           , coincidenceSubscribedNodeId :: Int-#endif-                           }--data Coincidence a-   = Coincidence { coincidenceParent :: !(Event (Event a))-                 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))-                 }--data Box a = Box { unBox :: a }----type WeakSubscriber a = Weak (Subscriber a)-data WeakSubscriber a-   = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?-   | WeakSubscriberSimple !(Weak (Subscriber a))--showWeakSubscriberType :: WeakSubscriber a -> String-showWeakSubscriberType = \case-  WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"-  WeakSubscriberSimple _ -> "WeakSubscriberSimple"--deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))-deRefWeakSubscriber ws = case ws of-  WeakSubscriberSimple w -> deRefWeak w-  WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w--data Subscriber a-   = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)-   | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?-   | forall k. (GCompare k, a ~ DMap k) => SubscriberFan (FanSubscribed k)-   | SubscriberHold !(Hold a)-   | SubscriberSwitch (SwitchSubscribed a)-   | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)-   | SubscriberCoincidenceInner (CoincidenceSubscribed a)--showSubscriberType :: Subscriber a -> String-showSubscriberType = \case-  SubscriberPush _ _ -> "SubscriberPush"-  SubscriberMerge _ _ -> "SubscriberMerge"-  SubscriberFan _ -> "SubscriberFan"-  SubscriberHold _ -> "SubscriberHold"-  SubscriberSwitch _ -> "SubscriberSwitch"-  SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"-  SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"--data Event a-   = forall k. GCompare k => EventRoot !(k a) !(Root k)-   | EventNever-   | forall b. EventPush !(Push b a)-   | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)-   | forall k. GCompare k => EventFan !(k a) !(Fan k)-   | EventSwitch !(Switch a)-   | EventCoincidence !(Coincidence a)--showEventType :: Event a -> String-showEventType = \case-  EventRoot _ _ -> "EventRoot"-  EventNever -> "EventNever"-  EventPush _ -> "EventPush"-  EventMerge _ -> "EventMerge"-  EventFan _ _ -> "EventFan"-  EventSwitch _ -> "EventSwitch"-  EventCoincidence _ -> "EventCoincidence"--data EventSubscribed a-   = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)-   | EventSubscribedNever-   | forall b. EventSubscribedPush !(PushSubscribed b a)-   | forall k. (GCompare k, a ~ DMap k) => EventSubscribedMerge !(MergeSubscribed k)-   | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)-   | EventSubscribedSwitch !(SwitchSubscribed a)-   | EventSubscribedCoincidence !(CoincidenceSubscribed a)---- These function are constructor functions that are marked NOINLINE so they are--- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away--- so any weak references that are attached to the constructors will have their--- finalizer run. Using the opaque constructor, does not see the--- constructor application, so it behaves like an IORef and cannot be fused away.------ The result is also evaluated to WHNF, since forcing a thunk invalidates--- the weak pointer to it in some cases.--{-# NOINLINE newRootSubscribed #-}-newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)-newRootSubscribed occ subs =-  return $! RootSubscribed-    { rootSubscribedOccurrence = occ-    , rootSubscribedSubscribers = subs-    }--{-# NOINLINE newSubscriberPush #-}-newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)-newSubscriberPush compute subd = return $! SubscriberPush compute subd--{-# NOINLINE newSubscriberHold #-}-newSubscriberHold :: Hold a -> IO (Subscriber a)-newSubscriberHold h = return $! SubscriberHold h--{-# NOINLINE newSubscriberFan #-}-newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))-newSubscriberFan subd = return $! SubscriberFan subd--{-# NOINLINE newSubscriberSwitch #-}-newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)-newSubscriberSwitch subd = return $! SubscriberSwitch subd--{-# NOINLINE newSubscriberCoincidenceOuter #-}-newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))-newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd--{-# NOINLINE newSubscriberCoincidenceInner #-}-newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)-newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd--{-# NOINLINE newInvalidatorSwitch #-}-newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator-newInvalidatorSwitch subd = return $! InvalidatorSwitch subd--{-# NOINLINE newInvalidatorPull #-}-newInvalidatorPull :: Pull a -> IO Invalidator-newInvalidatorPull p = return $! InvalidatorPull p--{-# NOINLINE newBox #-}-newBox :: a -> IO (Box a)-newBox a = return $! Box a----type role Behavior representational-data Behavior a-   = BehaviorHold !(Hold a)-   | BehaviorConst !a-   | BehaviorPull !(Pull a)---- ResultM can read behaviors and events-type ResultM = EventM--{-# NOINLINE unsafeNewIORef #-}-unsafeNewIORef :: a -> b -> IORef b-unsafeNewIORef _ b = unsafePerformIO $ newIORef b--instance Functor Event where-  fmap f = push $ return . Just . f--instance Functor Behavior where-  fmap f = pull . liftM f . readBehaviorTracked--{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly-push :: (a -> EventM (Maybe b)) -> Event a -> Event b-push f e = EventPush $ Push-  { pushCompute = f-  , pushParent = e-  , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?-  }-{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}--{-# NOINLINE pull #-}-pull :: BehaviorM a -> Behavior a-pull a = BehaviorPull $ Pull-  { pullCompute = a-  , pullValue = unsafeNewIORef a Nothing-  }-{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}--{-# NOINLINE switch #-}-switch :: Behavior (Event a) -> Event a-switch a = EventSwitch $ Switch-  { switchParent = a-  , switchSubscribed = unsafeNewIORef a Nothing-  }-{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}--coincidence :: Event (Event a) -> Event a-coincidence a = EventCoincidence $ Coincidence-  { coincidenceParent = a-  , coincidenceSubscribed = unsafeNewIORef a Nothing-  }--newRoot :: IO (Root k)-newRoot = do-  occRef <- newIORef DMap.empty-  subscribedRef <- newIORef DMap.empty-  return $ Root-    { rootOccurrence = occRef-    , rootSubscribed = subscribedRef-    , rootInit = \_ _ -> return $ return ()-    }--propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()-propagateAndUpdateSubscribersRef subscribersRef a = do-  subscribers <- liftIO $ readIORef subscribersRef-  liftIO $ writeIORef subscribersRef []-  stillAlive <- propagate a subscribers-  liftIO $ modifyIORef' subscribersRef (++stillAlive)---- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors-run :: [DSum RootTrigger] -> ResultM b -> IO b-run roots after = do-  when debugPropagate $ putStrLn "Running an event frame"-  result <- runFrame $ do-    rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do-      occBefore <- liftIO $ do-        occBefore <- readIORef occRef-        writeIORef occRef $ DMap.insert k a occBefore-        return occBefore-      if DMap.null occBefore-        then do scheduleRootClear occRef-                return $ Just r-        else return Nothing-    forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do-      propagateAndUpdateSubscribersRef subscribersRef a-    delayedRef <- EventM $ asks eventEnvDelayedMerges-    let go = do-          delayed <- liftIO $ readIORef delayedRef-          case IntMap.minViewWithKey delayed of-            Nothing -> return ()-            Just ((currentHeight, current), future) -> do-              when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight-              putCurrentHeight currentHeight-              liftIO $ writeIORef delayedRef future-              forM_ current $ \d -> case d of-                DelayedMerge subscribed -> do-                  height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed-                  case height `compare` currentHeight of-                    LT -> error "Somehow a merge's height has been decreased after it was scheduled"-                    GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)-                    EQ -> do-                      m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed-                      liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty-                      --TODO: Assert that m is not empty-                      liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m-                      scheduleClear $ mergeSubscribedOccurrence subscribed-                      propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m-              go-    go-    putCurrentHeight maxBound-    after-  when debugPropagate $ putStrLn "Done running an event frame"-  return result--data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))--data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))--data SomeAssignment = forall a. SomeAssignment (Hold a) a--data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)--debugFinalize :: Bool-debugFinalize = False--mkWeakPtrWithDebug :: a -> String -> IO (Weak a)-mkWeakPtrWithDebug x debugNote = mkWeakPtr x $-  if debugFinalize-  then Just $ putStrLn $ "finalizing: " ++ debugNote-  else Nothing--type WeakList a = [Weak a]----TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?-traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]-traverseAndCleanWeakList_ deRef ws f = go ws-  where go [] = return []-        go (h:t) = do-          ma <- deRef h-          case ma of-            Just a -> do-              f a-              t' <- go t-              return $ h : t'-            Nothing -> go t---- | Propagate everything at the current height-propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]-propagate a subscribers = do-  traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of-    SubscriberPush compute subscribed -> do-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed-      occ <- compute a-      case occ of-        Nothing -> return () -- No need to write a Nothing back into the Ref-        Just o -> do-          liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ-          scheduleClear $ pushSubscribedOccurrence subscribed-          liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))-    SubscriberMerge k subscribed -> do-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed-      oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed-      liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM-      when (DMap.null oldM) $ do -- Only schedule the firing once-        height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed-        --TODO: assertions about height-        currentHeight <- getCurrentHeight-        when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"-        scheduleMerge height subscribed-    SubscriberFan subscribed -> do-      subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"-      --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large-      forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of-        Nothing -> do-          when debugPropagate $ liftIO $ putStrLn "No subscriber for key"-          return ()-        Just subsubs -> do-          _ <- propagate v subsubs --TODO: use the value of this-          return ()-      --TODO: The following is way too slow to do all the time-      subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do-        subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())-        return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))-      liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'-    SubscriberHold h -> do-      invalidators <- liftIO $ readIORef $ holdInvalidators h-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)-      toAssignRef <- askToAssignRef-      liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)-    SubscriberSwitch subscribed -> do-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed-      liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a-      scheduleClear $ switchSubscribedOccurrence subscribed-      subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed-      liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs-    SubscriberCoincidenceOuter subscribed -> do-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed-      outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed-      when debugPropagate $ liftIO $ putStrLn $ "  outerHeight = " <> show outerHeight-      (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed-      when debugPropagate $ liftIO $ putStrLn $ "  isJust occ = " <> show (isJust occ)-      when debugPropagate $ liftIO $ putStrLn $ "  innerHeight = " <> show innerHeight-      liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd-      scheduleClear $ coincidenceSubscribedInnerParent subscribed-      case occ of-        Nothing -> do-          when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height-            writeIORef (coincidenceSubscribedHeight subscribed) innerHeight-            mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)-            mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)-        Just o -> do -- Since it's already firing, no need to adjust height-          liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ-          scheduleClear $ coincidenceSubscribedOccurrence subscribed-          liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))-    SubscriberCoincidenceInner subscribed -> do-      when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed-      liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a-      scheduleClear $ coincidenceSubscribedOccurrence subscribed-      liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))--data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset--subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)-subscribeCoincidenceInner o outerHeight subscribedUnsafe = do-  subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe-  wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"-  innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)-  innerOcc <- liftIO $ getEventSubscribedOcc innerSubd-  innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd-  let height = max innerHeight outerHeight-  emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing-  return (innerOcc, height, innerSubd)--readBehavior :: Behavior a -> IO a-readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases--runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a-runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi--askInvalidator :: BehaviorM (Maybe (Weak Invalidator))-askInvalidator = liftM (fmap fst) $ BehaviorM ask--askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))-askParentsRef = liftM (fmap snd) $ BehaviorM ask--readBehaviorTracked :: Behavior a -> BehaviorM a-readBehaviorTracked b = case b of-  BehaviorHold h -> do-    result <- liftIO $ readIORef $ holdValue h-    askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))-    askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))-    liftIO $ touch $ holdSubscriber h-    return result-  BehaviorConst a -> return a-  BehaviorPull p -> do-    val <- liftIO $ readIORef $ pullValue p-    case val of-      Just subscribed -> do-        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))-        askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))-        liftIO $ touch $ pullSubscribedOwnInvalidator subscribed-        return $ pullSubscribedValue subscribed-      Nothing -> do-        i <- liftIO $ newInvalidatorPull p-        wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"-        parentsRef <- liftIO $ newIORef []-        a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)-        invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator-        parents <- liftIO $ readIORef parentsRef-        let subscribed = PullSubscribed-              { pullSubscribedValue = a-              , pullSubscribedInvalidators = invsRef-              , pullSubscribedOwnInvalidator = i-              , pullSubscribedParents = parents-              }-        liftIO $ writeIORef (pullValue p) $ Just subscribed-        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))-        return a--readEvent :: Event a -> ResultM (Maybe a)-readEvent e = case e of-  EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r-  EventNever -> return Nothing-  EventPush p -> do-    subscribed <- getPushSubscribed p-    liftIO $ do-      result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid-      touch $ pushSubscribedSelf subscribed-      return result-  EventMerge m -> do-    subscribed <- getMergeSubscribed m-    liftIO $ do-      result <- readIORef $ mergeSubscribedOccurrence subscribed-      touch $ mergeSubscribedSelf subscribed-      return result-  EventFan k f -> do-    parentOcc <- readEvent $ fanParent f-    return $ DMap.lookup k =<< parentOcc-  EventSwitch s -> do-    subscribed <- getSwitchSubscribed s-    liftIO $ do-      result <- readIORef $ switchSubscribedOccurrence subscribed-      touch $ switchSubscribedSelf subscribed-      touch $ switchSubscribedOwnInvalidator subscribed-      return result-  EventCoincidence c -> do-    subscribed <- getCoincidenceSubscribed c-    liftIO $ do-      result <- readIORef $ coincidenceSubscribedOccurrence subscribed-      touch $ coincidenceSubscribedOuter subscribed-      --TODO: do we need to touch the inner subscriber?-      return result---- Always refers to 0-{-# NOINLINE zeroRef #-}-zeroRef :: IORef Int-zeroRef = unsafePerformIO $ newIORef 0--getEventSubscribed :: Event a -> EventM (EventSubscribed a)-getEventSubscribed e = case e of-  EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r-  EventNever -> return EventSubscribedNever-  EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p-  EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f-  EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m-  EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s-  EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c--debugSubscribe :: Bool-debugSubscribe = False--subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()-subscribeEventSubscribed es ws = case es of-  EventSubscribedRoot r -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"-    modifyIORef' (rootSubscribedSubscribers r) (ws:)-  EventSubscribedNever -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"-    return ()-  EventSubscribedPush subscribed -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"-    modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)-  EventSubscribedFan k subscribed -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"-    modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]-  EventSubscribedMerge subscribed -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"-    modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)-  EventSubscribedSwitch subscribed -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"-    modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)-  EventSubscribedCoincidence subscribed -> do-    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"-    modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)--getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)-getEventSubscribedOcc es = case es of-  EventSubscribedRoot r -> rootSubscribedOccurrence r-  EventSubscribedNever -> return Nothing-  EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed-  EventSubscribedFan k subscribed -> do-    parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed-    let occ = DMap.lookup k =<< parentOcc-    return occ-  EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed-  EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed-  EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed--eventSubscribedHeightRef :: EventSubscribed a -> IORef Int-eventSubscribedHeightRef es = case es of-  EventSubscribedRoot _ -> zeroRef-  EventSubscribedNever -> zeroRef-  EventSubscribedPush subscribed -> pushSubscribedHeight subscribed-  EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed-  EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed-  EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed-  EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed--subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)-subscribe e ws = do-  subd <- getEventSubscribed e-  liftIO $ subscribeEventSubscribed subd ws-  return subd--noinlineFalse :: Bool-noinlineFalse = False-{-# NOINLINE noinlineFalse #-}--getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)-getRootSubscribed k r = do-  mSubscribed <- liftIO $ readIORef $ rootSubscribed r-  case DMap.lookup (WrapArg k) mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> liftIO $ do-      subscribersRef <- newIORef []-      subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef-      -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory-      uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)-      addFinalizer subscribed $ do-        when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should---        putStrLn "Uninit root"-        uninit-      liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed-      return subscribed---- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in-getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)-getPushSubscribed p = do-  mSubscribed <- liftIO $ readIORef $ pushSubscribed p-  case mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> do -- Not yet subscribed-      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p-      s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe-      ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"-      subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws-      parentOcc <- liftIO $ getEventSubscribedOcc subd-      occ <- liftM join $ mapM (pushCompute p) parentOcc-      occRef <- liftIO $ newIORef occ-      when (isJust occ) $ scheduleClear occRef-      subscribersRef <- liftIO $ newIORef []-      let subscribed = PushSubscribed-            { pushSubscribedOccurrence = occRef-            , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref-            , pushSubscribedSubscribers = subscribersRef-            , pushSubscribedSelf = unsafeCoerce s-            , pushSubscribedParent = subd-#ifdef DEBUG_NODEIDS-            , pushSubscribedNodeId = unsafeNodeId p-#endif-            }-      liftIO $ writeIORef (pushSubscribed p) $ Just subscribed-      return subscribed--getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)-getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do-  mSubscribed <- liftIO $ readIORef $ mergeSubscribed m-  case mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do-      subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"-      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      s <- liftIO $ newBox subscribedUnsafe-      ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"-      subscribers :: [(Any, Maybe (DSum k), Int, DSum (WrapArg EventSubscribed k))] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(WrapArg k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do-        parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws-        parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd-        height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd-        return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)-      let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers-          subscriberHeights = map (\(_, _, x, _) -> x) subscribers-          myHeight =-            if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'-            then invalidHeight-            else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here-      currentHeight <- getCurrentHeight-      let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now-                         then (if DMap.null dm then Nothing else Just dm, DMap.empty)-                         else (Nothing, dm)-      when (not $ DMap.null accum) $ do-        scheduleMerge myHeight subscribedUnsafe-      occRef <- liftIO $ newIORef occ-      when (isJust occ) $ scheduleClear occRef-      accumRef <- liftIO $ newIORef accum-      heightRef <- liftIO $ newIORef myHeight-      subsRef <- liftIO $ newIORef []-      let subscribed = MergeSubscribed-            { mergeSubscribedOccurrence = occRef-            , mergeSubscribedAccum = accumRef-            , mergeSubscribedHeight = heightRef-            , mergeSubscribedSubscribers = subsRef-            , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?-            , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers-#ifdef DEBUG_NODEIDS-            , mergeSubscribedNodeId = unsafeNodeId m-#endif-            }-      liftIO $ writeIORef subscribedRef subscribed-      return subscribed-  where emptyMergeSubscribed = do --TODO: This should never happen-          occRef <- liftIO $ newIORef Nothing-          accumRef <- liftIO $ newIORef DMap.empty-          subsRef <- liftIO $ newIORef []-          return $ MergeSubscribed-            { mergeSubscribedOccurrence = occRef-            , mergeSubscribedAccum = accumRef-            , mergeSubscribedHeight = zeroRef-            , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak-            , mergeSubscribedSelf = unsafeCoerce ()-            , mergeSubscribedParents = DMap.empty-#ifdef DEBUG_NODEIDS-            , mergeSubscribedNodeId = -1-#endif-            }--getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)-getFanSubscribed f = do-  mSubscribed <- liftIO $ readIORef $ fanSubscribed f-  case mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> do-      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f-      sub <- liftIO $ newSubscriberFan subscribedUnsafe-      wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"-      subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub-      subscribersRef <- liftIO $ newIORef DMap.empty-      let subscribed = FanSubscribed-            { fanSubscribedParent = subd-            , fanSubscribedSubscribers = subscribersRef-            , fanSubscribedSelf = sub-#ifdef DEBUG_NODEIDS-            , fanSubscribedNodeId = unsafeNodeId f-#endif-            }-      liftIO $ writeIORef (fanSubscribed f) $ Just subscribed-      return subscribed--getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)-getSwitchSubscribed s = do-  mSubscribed <- liftIO $ readIORef $ switchSubscribed s-  case mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> do-      subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"-      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      i <- liftIO $ newInvalidatorSwitch subscribedUnsafe-      sub <- liftIO $ newSubscriberSwitch subscribedUnsafe-      wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"-      wiRef <- liftIO $ newIORef wi-      wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"-      selfWeakRef <- liftIO $ newIORef wsub-      parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior-      e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)-      subd <- subscribe e $ WeakSubscriberSimple wsub-      subdRef <- liftIO $ newIORef subd-      parentOcc <- liftIO $ getEventSubscribedOcc subd-      occRef <- liftIO $ newIORef parentOcc-      when (isJust parentOcc) $ scheduleClear occRef-      heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)-      subscribersRef <- liftIO $ newIORef []-      let subscribed = SwitchSubscribed-            { switchSubscribedOccurrence = occRef-            , switchSubscribedHeight = heightRef-            , switchSubscribedSubscribers = subscribersRef-            , switchSubscribedSelf = sub-            , switchSubscribedSelfWeak = selfWeakRef-            , switchSubscribedOwnInvalidator = i-            , switchSubscribedOwnWeakInvalidator = wiRef-            , switchSubscribedBehaviorParents = parentsRef-            , switchSubscribedParent = switchParent s-            , switchSubscribedCurrentParent = subdRef-#ifdef DEBUG_NODEIDS-            , switchSubscribedNodeId = unsafeNodeId s-#endif-            }-      liftIO $ writeIORef subscribedRef subscribed-      liftIO $ writeIORef (switchSubscribed s) $ Just subscribed-      return subscribed--getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)-getCoincidenceSubscribed c = do-  mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c-  case mSubscribed of-    Just subscribed -> return subscribed-    Nothing -> do-      subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"-      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe-      wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"-      outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter-      outerOcc <- liftIO $ getEventSubscribedOcc outerSubd-      outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd-      (occ, height, mInnerSubd) <- case outerOcc of-        Nothing -> return (Nothing, outerHeight, Nothing)-        Just o -> do-          (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe-          return (occ, height, Just innerSubd)-      occRef <- liftIO $ newIORef occ-      when (isJust occ) $ scheduleClear occRef-      heightRef <- liftIO $ newIORef height-      innerSubdRef <- liftIO $ newIORef mInnerSubd-      scheduleClear innerSubdRef-      subscribersRef <- liftIO $ newIORef []-      let subscribed = CoincidenceSubscribed-            { coincidenceSubscribedOccurrence = occRef-            , coincidenceSubscribedHeight = heightRef-            , coincidenceSubscribedSubscribers = subscribersRef-            , coincidenceSubscribedOuter = subOuter-            , coincidenceSubscribedOuterParent = outerSubd-            , coincidenceSubscribedInnerParent = innerSubdRef-#ifdef DEBUG_NODEIDS-            , coincidenceSubscribedNodeId = unsafeNodeId c-#endif-            }-      liftIO $ writeIORef subscribedRef subscribed-      liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed-      return subscribed--merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)-merge m = EventMerge $ Merge-  { mergeParents = m-  , mergeSubscribed = unsafeNewIORef m Nothing-  }--newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }--fan :: GCompare k => Event (DMap k) -> EventSelector k-fan e =-  let f = Fan-        { fanParent = e-        , fanSubscribed = unsafeNewIORef e Nothing-        }-  in EventSelector $ \k -> EventFan k f---- | Run an event action outside of a frame-runFrame :: EventM a -> IO a-runFrame a = do-  toAssignRef <- newIORef [] -- This should only actually get used when events are firing-  holdInitRef <- newIORef []-  heightRef <- newIORef 0-  toClearRef <- newIORef []-  toClearRootRef <- newIORef []-  coincidenceInfosRef <- newIORef []-  delayedRef <- liftIO $ newIORef IntMap.empty-  result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do-    result <- a-    let runHoldInits = do-          holdInits <- liftIO $ readIORef holdInitRef-          if null holdInits then return () else do-            liftIO $ writeIORef holdInitRef []-            forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h-            runHoldInits-    runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events-    return result-  toClear <- readIORef toClearRef-  forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing-  toClearRoot <- readIORef toClearRootRef-  forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty-  toAssign <- readIORef toAssignRef-  toReconnectRef <- newIORef []-  forM_ toAssign $ \(SomeAssignment h v) -> do-    writeIORef (holdValue h) v-    writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)-  coincidenceInfos <- readIORef coincidenceInfosRef-  forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do-    touch subInner-    finalize wsubInner-    mapM_ invalidateCoincidenceHeight mcs-  toReconnect <- readIORef toReconnectRef-  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do-    wsub <- readIORef $ switchSubscribedSelfWeak subscribed-    finalize wsub-    wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed-    finalize wi-    let !i = switchSubscribedOwnInvalidator subscribed-    wi' <- mkWeakPtrWithDebug i "wi'"-    writeIORef (switchSubscribedBehaviorParents subscribed) []-    e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))-    --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times-    let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk-    wsub' <- mkWeakPtrWithDebug sub "wsub'"-    writeIORef (switchSubscribedSelfWeak subscribed) wsub'-    subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient-    {--    stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)-    liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of-      EventRoot _ -> "EventRoot"-      EventNever -> "EventNever"-      _ -> "something else"-    -}-    writeIORef (switchSubscribedCurrentParent subscribed) subd'-    parentHeight <- readIORef $ eventSubscribedHeightRef subd'-    myHeight <- readIORef $ switchSubscribedHeight subscribed-    if parentHeight == myHeight then return () else do-      writeIORef (switchSubscribedHeight subscribed) parentHeight-      mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)-  forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs-  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do-    mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)-  return result--invalidHeight :: Int-invalidHeight = -1000--invalidateSubscriberHeight :: WeakSubscriber a -> IO ()-invalidateSubscriberHeight ws = do-  ms <- deRefWeakSubscriber ws-  case ms of-    Nothing -> return () --TODO: cleanup?-    Just s -> case s of-      SubscriberPush _ subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed-        mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"-      SubscriberMerge _ subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed-        oldHeight <- readIORef $ mergeSubscribedHeight subscribed-        when (oldHeight /= invalidHeight) $ do-          writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight-          mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"-      SubscriberFan subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed-        subscribers <- readIORef $ fanSubscribedSubscribers subscribed-        forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"-      SubscriberHold _ -> return ()-      SubscriberSwitch subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed-        oldHeight <- readIORef $ switchSubscribedHeight subscribed-        when (oldHeight /= invalidHeight) $ do-          writeIORef (switchSubscribedHeight subscribed) $ invalidHeight-          mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"-      SubscriberCoincidenceOuter subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed-        invalidateCoincidenceHeight subscribed-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"-      SubscriberCoincidenceInner subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed-        invalidateCoincidenceHeight subscribed-        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"--invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()-invalidateCoincidenceHeight subscribed = do-  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed-  when (oldHeight /= invalidHeight) $ do-    writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight-    mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)----TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy--recalculateSubscriberHeight :: WeakSubscriber a -> IO ()-recalculateSubscriberHeight ws = do-  ms <- deRefWeakSubscriber ws-  case ms of-    Nothing -> return () --TODO: cleanup?-    Just s -> case s of-      SubscriberPush _ subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed-        mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"-      SubscriberMerge _ subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed-        oldHeight <- readIORef $ mergeSubscribedHeight subscribed-        when (oldHeight == invalidHeight) $ do-          height <- calculateMergeHeight subscribed-          when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height-          when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated-            writeIORef (mergeSubscribedHeight subscribed) height-            mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"-      SubscriberFan subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed-        subscribers <- readIORef $ fanSubscribedSubscribers subscribed-        forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"-      SubscriberHold _ -> return ()-      SubscriberSwitch subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed-        oldHeight <- readIORef $ switchSubscribedHeight subscribed-        when (oldHeight == invalidHeight) $ do-          height <- calculateSwitchHeight subscribed-          when (height /= invalidHeight) $ do-            writeIORef (switchSubscribedHeight subscribed) height-            mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"-      SubscriberCoincidenceOuter subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed-        void $ recalculateCoincidenceHeight subscribed-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"-      SubscriberCoincidenceInner subscribed -> do-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed-        void $ recalculateCoincidenceHeight subscribed-        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"--recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()-recalculateCoincidenceHeight subscribed = do-  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed-  when (oldHeight == invalidHeight) $ do-    height <- calculateCoincidenceHeight subscribed-    when (height /= invalidHeight) $ do-      writeIORef (coincidenceSubscribedHeight subscribed) height-      mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones--calculateMergeHeight :: MergeSubscribed k -> IO Int-calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do-  heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do-    readIORef $ eventSubscribedHeightRef es-  return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'--calculateSwitchHeight :: SwitchSubscribed a -> IO Int-calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)--calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int-calculateCoincidenceHeight subscribed = do-  outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed-  innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)-  return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight--{--recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int-recalculateEventSubscribedHeight es = case es of-  EventSubscribedRoot _ -> return 0-  EventSubscribedNever -> return 0-  EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed-  EventSubscribedMerge subscribed -> do-    oldHeight <- readIORef $ mergeSubscribedHeight subscribed-    if oldHeight /= invalidHeight then return oldHeight else do-      height <- calculateMergeHeight subscribed-      writeIORef (mergeSubscribedHeight subscribed) height-      return height-  EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed-  EventSubscribedSwitch subscribed -> do-    oldHeight <- readIORef $ switchSubscribedHeight subscribed-    if oldHeight /= invalidHeight then return oldHeight else do-      height <- calculateSwitchHeight subscribed-      writeIORef (switchSubscribedHeight subscribed) height-      return height-  EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed--}--data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)--debugInvalidate :: Bool-debugInvalidate = False--invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)-invalidate toReconnectRef wis = do-  forM_ wis $ \wi -> do-    mi <- deRefWeak wi-    case mi of-      Nothing -> do-        when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"-        return () --TODO: Should we clean this up here?-      Just i -> do-        finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict-        case i of-          InvalidatorPull p -> do-            when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"-            mVal <- readIORef $ pullValue p-            forM_ mVal $ \val -> do-              writeIORef (pullValue p) Nothing-              writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)-          InvalidatorSwitch subscribed -> do-            when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"-            modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)-  return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them------------------------------------------------------------------------------------- Reflex integration-----------------------------------------------------------------------------------data Spider--instance R.Reflex Spider where-  newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }-  newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }-  type PullM Spider = BehaviorM-  type PushM Spider = EventM-  {-# INLINE never #-}-  {-# INLINE constant #-}-  never = SpiderEvent EventNever-  constant = SpiderBehavior . BehaviorConst-  push f = SpiderEvent. push f . unSpiderEvent-  pull = SpiderBehavior . pull-  merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))-  fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))-  switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior-  coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent--instance R.MonadSample Spider SpiderHost where-  {-# INLINE sample #-}-  sample = SpiderHost . readBehavior . unSpiderBehavior--instance R.MonadHold Spider SpiderHost where-  hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent--instance R.MonadSample Spider BehaviorM where-  {-# INLINE sample #-}-  sample = readBehaviorTracked . unSpiderBehavior--instance R.MonadSample Spider EventM where-  {-# INLINE sample #-}-  sample = liftIO . readBehavior . unSpiderBehavior--instance R.MonadHold Spider EventM where-  {-# INLINE hold #-}-  hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)--data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)-newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }--instance R.MonadSubscribeEvent Spider SpiderHostFrame where-  subscribeEvent e = SpiderHostFrame $ do-    _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used-    return $ SpiderEventHandle (unSpiderEvent e)--instance R.ReflexHost Spider where-  type EventTrigger Spider = RootTrigger-  type EventHandle Spider = SpiderEventHandle-  type HostFrame Spider = SpiderHostFrame--instance R.MonadReadEvent Spider ReadPhase where-  {-# INLINE readEvent #-}-  readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle--instance MonadRef EventM where-  type Ref EventM = Ref IO-  {-# INLINE newRef #-}-  {-# INLINE readRef #-}-  {-# INLINE writeRef #-}-  newRef = liftIO . newRef-  readRef = liftIO . readRef-  writeRef r a = liftIO $ writeRef r a--instance MonadAtomicRef EventM where-  {-# INLINE atomicModifyRef #-}-  atomicModifyRef r f = liftIO $ atomicModifyRef r f--newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)--newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)--instance R.MonadSample Spider SpiderHostFrame where-  sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can-  -instance R.MonadHold Spider SpiderHostFrame where-  {-# INLINE hold #-}-  hold v0 e = SpiderHostFrame $ R.hold v0 e--newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)-newEventWithTriggerIO f = do-  es <- newFanEventWithTriggerIO $ \Refl -> f-  return $ select es Refl--newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)-newFanEventWithTriggerIO f = do-  occRef <- newIORef DMap.empty-  subscribedRef <- newIORef DMap.empty-  let !r = Root-        { rootOccurrence = occRef-        , rootSubscribed = subscribedRef-        , rootInit = f-        }-  return $ EventSelector $ \k -> EventRoot k r--instance R.MonadReflexCreateTrigger Spider SpiderHost where-  newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO-  newFanEventWithTrigger f = SpiderHost $ do-    es <- newFanEventWithTriggerIO f-    return $ R.EventSelector $ SpiderEvent . select es--instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where-  newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO-  newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do-    es <- newFanEventWithTriggerIO f-    return $ R.EventSelector $ SpiderEvent . select es--instance R.MonadSubscribeEvent Spider SpiderHost where-  subscribeEvent e = SpiderHost $ do-    _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used-    return $ SpiderEventHandle (unSpiderEvent e)--newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)--instance R.MonadReflexHost Spider SpiderHost where-  type ReadPhase SpiderHost = ReadPhase-  fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a-  runHostFrame = SpiderHost . runFrame . runSpiderHostFrame--instance MonadRef SpiderHost where-  type Ref SpiderHost = Ref IO-  newRef = SpiderHost . newRef-  readRef = SpiderHost . readRef-  writeRef r = SpiderHost . writeRef r--instance MonadAtomicRef SpiderHost where-  atomicModifyRef r = SpiderHost . atomicModifyRef r--instance MonadRef SpiderHostFrame where-  type Ref SpiderHostFrame = Ref IO-  newRef = SpiderHostFrame . newRef-  readRef = SpiderHostFrame . readRef-  writeRef r = SpiderHostFrame . writeRef r--instance MonadAtomicRef SpiderHostFrame where-  atomicModifyRef r = SpiderHostFrame . atomicModifyRef r+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -Wunused-binds #-}++-- | This module is the implementation of the 'Spider' 'Reflex' engine.  It uses+-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.+module Reflex.Spider.Internal+  ( module Reflex.Spider.Internal+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad hiding (forM, forM_, mapM, mapM_)+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Reader.Class+import Control.Monad.IO.Class+import Control.Monad.ReaderIO+import Control.Monad.Ref+import qualified Control.Monad.Fail as MonadFail+import Data.Align+import Data.Coerce+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum (..))+import Data.FastMutableIntMap (FastMutableIntMap)+import qualified Data.FastMutableIntMap as FastMutableIntMap+import Data.Foldable hiding (concat, elem, sequence_)+import Data.Functor.Constant+import Data.Functor.Misc+import Data.Functor.Product+import Data.GADT.Compare+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IORef+import Data.Kind (Type)+import Data.Maybe hiding (mapMaybe)+import Data.Proxy+import Data.These+import Data.Traversable+import Data.Type.Equality ((:~:)(Refl))+import GHC.Exts hiding (toList)+import GHC.IORef (IORef (..))+import GHC.Stack+import Reflex.FastWeak+import System.IO.Unsafe+import System.Mem.Weak+import Unsafe.Coerce+import Witherable (Filterable, mapMaybe)++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)+import Control.Monad.Fail (MonadFail)+import Data.List (isPrefixOf)+import Data.Monoid (mempty, (<>))+#else+import Control.Monad.Identity+#endif++#ifdef MIN_VERSION_semialign+#if MIN_VERSION_these(0,8,0)+import Data.These.Combinators (justThese)+#endif+#if MIN_VERSION_semialign(1,1,0)+import Data.Zip (Zip (..))+#endif+#endif++#ifdef DEBUG_CYCLES+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)+#endif++import Data.List.NonEmpty (NonEmpty (..), nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Tree (Forest, Tree (..), drawForest)++#ifdef DEBUG_HIDE_INTERNALS+import Data.List (isPrefixOf)+#endif++import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)+import qualified Data.FastWeakBag as FastWeakBag++import Data.Reflection+import Data.Some (Some(Some))+import Data.Type.Coercion+import Data.Profunctor.Unsafe ((#.), (.#))+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)+import qualified Data.WeakBag as WeakBag+import qualified Reflex.Class+import qualified Reflex.Class as R+import qualified Reflex.Host.Class+import Reflex.NotReady.Class+import Data.Patch+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove+import Reflex.PerformEvent.Base (PerformEventT)++#ifdef DEBUG_TRACE_EVENTS+import qualified Data.ByteString.Char8 as BS8+import System.IO (stderr)+import Data.List (isPrefixOf)+#endif++-- TODO stdout might not be the best channel for debug output+debugStrLn :: String -> IO ()+debugStrLn = putStrLn++#ifdef DEBUG_TRACE_EVENTS+withStackOneLine :: (BS8.ByteString -> a) -> a+withStackOneLine expr = unsafePerformIO $ do+  stack <- currentCallStack+  return (expr . BS8.pack  . unwords . dropInternal . reverse $ stack)+    where dropInternal = filterStack "Reflex.Spider.Internal"++#endif++debugPropagate :: Bool++debugInvalidateHeight :: Bool++debugInvalidate :: Bool++#ifdef DEBUG+#define DEBUG_NODEIDS++#ifdef DEBUG_TRACE_PROPAGATION+debugPropagate = True+#else+debugPropagate = False+#endif++#ifdef DEBUG_TRACE_HEIGHT+debugInvalidateHeight = True+#else+debugInvalidateHeight = False+#endif++#ifdef DEBUG_TRACE_INVALIDATION+debugInvalidate = True+#else+debugInvalidate = False+#endif++class HasNodeId a where+  getNodeId :: a -> Int++instance HasNodeId (CacheSubscribed x a) where+  getNodeId = _cacheSubscribed_nodeId++instance HasNodeId (FanInt x a) where+  getNodeId = _fanInt_nodeId++instance HasNodeId (Hold x p) where+  getNodeId = holdNodeId++instance HasNodeId (SwitchSubscribed x a) where+  getNodeId = switchSubscribedNodeId++instance HasNodeId (FanSubscribed x v a) where+  getNodeId = fanSubscribedNodeId++instance HasNodeId (CoincidenceSubscribed x a) where+  getNodeId = coincidenceSubscribedNodeId++instance HasNodeId (RootSubscribed x a) where+  getNodeId = rootSubscribedNodeId++instance HasNodeId (Pull x a) where+  getNodeId = pullNodeId++{-# INLINE showNodeId #-}+showNodeId :: HasNodeId a => a -> String+showNodeId = showNodeId' . getNodeId++showNodeId' :: Int -> String+showNodeId' = ("#"<>) . show+++#else++debugPropagate = False+debugInvalidateHeight = False+debugInvalidate = False++-- This must be inline, or error messages will cause memory leaks due to retaining the node in question+{-# INLINE showNodeId #-}+showNodeId :: a -> String+showNodeId _ = ""++{-# INLINE showNodeId' #-}+showNodeId' :: Int -> String+showNodeId' _ = ""++#endif++#ifdef DEBUG_NODEIDS+{-# NOINLINE nextNodeIdRef #-}+nextNodeIdRef :: IORef Int+nextNodeIdRef = unsafePerformIO $ newIORef 1++newNodeId :: IO Int+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)+#endif++--------------------------------------------------------------------------------+-- EventSubscription+--------------------------------------------------------------------------------++--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.+data EventSubscription x = EventSubscription+  { _eventSubscription_unsubscribe :: !(IO ())+  , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)+  }++unsubscribe :: EventSubscription x -> IO ()+unsubscribe (EventSubscription u _) = u++--------------------------------------------------------------------------------+-- Event+--------------------------------------------------------------------------------++newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }++{-# INLINE subscribeAndRead #-}+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)+subscribeAndRead = unEvent++{-# RULES+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e+  #-}++-- | Construct an 'Event' equivalent to that constructed by 'push', but with no+-- caching; if the computation function is very cheap, this is (much) more+-- efficient than 'push'+{-# INLINE [1] pushCheap #-}+pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b+pushCheap !f e = Event $ \sub -> do+  (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub+    { subscriberPropagate = \a -> do+        mb <- f a+        mapM_ (subscriberPropagate sub) mb+    }+  occ' <- join <$> mapM f occ+  return (subscription, occ')++-- | A subscriber that never triggers other 'Event's+{-# INLINE terminalSubscriber #-}+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a+terminalSubscriber p = Subscriber+  { subscriberPropagate = p+  , subscriberInvalidateHeight = \_ -> return ()+  , subscriberRecalculateHeight = \_ -> return ()+  }++-- | Subscribe to an Event only for the duration of one occurrence+{-# INLINE subscribeAndReadHead #-}+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)+subscribeAndReadHead e sub = do+  subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"+  (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub+    { subscriberPropagate = \a -> do+        liftIO $ unsubscribe =<< readIORef subscriptionRef+        subscriberPropagate sub a+    }+  liftIO $ case occ of+    Nothing -> writeIORef subscriptionRef $! subscription+    Just _ -> unsubscribe subscription+  return (subscription, occ)++--TODO: Make this lazy in its input event+headE :: Defer (SomeMergeInit x) m => Event x a -> m (Event x a)+headE originalE = do+  parent <- liftIO $ newIORef $ Just originalE+  defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately+    let clearParent = liftIO $ writeIORef parent Nothing+    (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent+    when (isJust occ) clearParent+  return $ Event $ \sub ->+    liftIO (readIORef parent) >>= \case+      Nothing -> subscribeAndReadNever+      Just e -> subscribeAndReadHead e sub++data CacheSubscribed x a+   = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))+                     , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)+                     , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))+#ifdef DEBUG_NODEIDS+                     , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int+#endif+                     }++nowSpiderEventM :: HasSpiderTimeline x => EventM x (R.Event (SpiderTimeline x) ())+nowSpiderEventM = SpiderEvent <$> now++now :: Defer (Some Clear) m => m (Event x ())+now = do+  nowOrNot <- liftIO $ newIORef $ Just ()+  scheduleClear nowOrNot+  return . Event $ \_ -> do+    occ <- liftIO . readIORef $ nowOrNot+    return ( EventSubscription (return ()) eventSubscribedNow+           , occ+           )++-- | Construct an 'Event' whose value is guaranteed not to be recomputed+-- repeatedly+--+--TODO: Try a caching strategy where we subscribe directly to the parent when+--there's only one subscriber, and then build our own FastWeakBag only when a second+--subscriber joins+{-# NOINLINE [0] cacheEvent #-}+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a+cacheEvent e =+#ifdef DEBUG_TRACE_EVENTS+  withStackOneLine $ \callSite -> Event $+#else+  Event $+#endif+  unsafePerformIO $ do+    mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))+        <- newIORef emptyFastWeak+    pure $ \sub -> {-# SCC "cacheEvent" #-} do+#ifdef DEBUG_TRACE_EVENTS+          unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite+#endif+          subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case+            Just subscribedTicket -> return subscribedTicket+            Nothing -> do+#ifdef DEBUG_NODEIDS+              nodeId <- liftIO newNodeId+#endif+              subscribers <- liftIO FastWeakBag.empty+              occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below+#ifdef DEBUG_NODEIDS+              (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber+#else+              (parentSub, occ) <- subscribeAndRead e $ Subscriber+#endif+                  { subscriberPropagate = \a -> do+                      liftIO $ writeIORef occRef (Just a)+                      scheduleClear occRef+                      propagateFast a subscribers+                  , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight+                  , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight+                  }+              when (isJust occ) $ do+                liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing+                scheduleClear occRef+              let !subscribed = CacheSubscribed+                    { _cacheSubscribed_subscribers = subscribers+                    , _cacheSubscribed_parent = parentSub+                    , _cacheSubscribed_occurrence = occRef+#ifdef DEBUG_NODEIDS+                    , _cacheSubscribed_nodeId = nodeId+#endif+                    }+              subscribedTicket <- liftIO $ mkFastWeakTicket subscribed+              liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket+              return subscribedTicket+          liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket++cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))+                  -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)+cacheSubscription sub mSubscribedRef subscribedTicket = do+  subscribed <- getFastWeakTicketValue subscribedTicket+  ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed+  occ <- readIORef $ _cacheSubscribed_occurrence subscribed++  let parentSub = _cacheSubscribed_parent subscribed+      es = EventSubscription+        { _eventSubscription_unsubscribe = do+          FastWeakBag.remove ticket++          isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed+          when isEmpty $ do+            writeIORef mSubscribedRef emptyFastWeak+            unsubscribe parentSub+          touch ticket+          touch subscribedTicket+        , _eventSubscription_subscribed = EventSubscribed+          { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub+          , eventSubscribedRetained = toAny subscribedTicket+#ifdef DEBUG_CYCLES+          , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]+          , eventSubscribedHasOwnHeightRef = False+          , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef+#endif+          }+        }+  return (es, occ)+++subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)+subscribe e s = fst <$> subscribeAndRead e s++{-# INLINE wrap #-}+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)+wrap tag getSpecificSubscribed sub = do+  (sln, subd, occ) <- getSpecificSubscribed sub+  let es = tag subd+  return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)++eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r++subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)++eventNever :: Event x a+eventNever = Event $ const subscribeAndReadNever++eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f++eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s++eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c++eventHold :: Hold x p -> Event x p+eventHold !h = Event $ subscribeHoldEvent h++eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub++{-# INLINE subscribeCoincidenceInner #-}+subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do+  subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe+  (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner+  innerHeight <- liftIO $ getEventSubscribedHeight innerSubd+  let height = max innerHeight outerHeight+  defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing+  return (innerOcc, height, innerSubd)++--------------------------------------------------------------------------------+-- Subscriber+--------------------------------------------------------------------------------++data Subscriber x a = Subscriber+  { subscriberPropagate :: !(a -> EventM x ())+  , subscriberInvalidateHeight :: !(Height -> IO ())+  , subscriberRecalculateHeight :: !(Height -> IO ())+  }++newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)+newSubscriberHold h = return $ Subscriber+  { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h+  , subscriberInvalidateHeight = \_ -> return ()+  , subscriberRecalculateHeight = \_ -> return ()+  }++newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed)  $ Subscriber+  { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do+      subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed+      tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"+      liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a+      scheduleClear $ fanSubscribedOccurrence subscribed+      let f _ (Pair v subsubs) = do+            propagate v $ _fanSubscribedChildren_list subsubs+            return $ Constant ()+      _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_+      return ()+  , subscriberInvalidateHeight = \old -> do+      subscribers <- readIORef $ fanSubscribedSubscribers subscribed+      forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old+  , subscriberRecalculateHeight = \new -> do+      subscribers <- readIORef $ fanSubscribedSubscribers subscribed+      forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new+  }++newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber+  { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do+      liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a+      scheduleClear $ switchSubscribedOccurrence subscribed+      propagate a $ switchSubscribedSubscribers subscribed+  , subscriberInvalidateHeight = \_ -> do+      oldHeight <- readIORef $ switchSubscribedHeight subscribed+      when (oldHeight /= invalidHeight) $ do+        writeIORef (switchSubscribedHeight subscribed) $! invalidHeight+        WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight+  , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)+    }++newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber+  { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do+      outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed+      tracePropagate (Proxy :: Proxy x) $ "  outerHeight = " <> show outerHeight+      (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed+      tracePropagate (Proxy :: Proxy x) $ "  isJust occ = " <> show (isJust occ)+      tracePropagate (Proxy :: Proxy x) $ "  innerHeight = " <> show innerHeight++      liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd+      scheduleClear $ coincidenceSubscribedInnerParent subscribed+      case occ of+        Nothing ->+          when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height+            writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight+            WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight+            WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight+        Just o -> do -- Since it's already firing, no need to adjust height+          liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ+          scheduleClear $ coincidenceSubscribedOccurrence subscribed+          propagate o $ coincidenceSubscribedSubscribers subscribed+  , subscriberInvalidateHeight  = \_ -> invalidateCoincidenceHeight subscribed+  , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed+  }++newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber+  { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do+#ifdef DEBUG+      occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed+      case occ of+        Just _ -> error "Coincidence inner is propagating, but coincidence occurrence is already known?"+        Nothing -> do+#endif          +          liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a+          scheduleClear $ coincidenceSubscribedOccurrence subscribed+          propagate a $ coincidenceSubscribedSubscribers subscribed+  , subscriberInvalidateHeight  = \_ -> invalidateCoincidenceHeight subscribed+  , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed+  }++invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()+invalidateSubscriberHeight = flip subscriberInvalidateHeight++recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()+recalculateSubscriberHeight = flip subscriberRecalculateHeight++-- | Propagate everything at the current height+propagate :: forall x a. a -> WeakBag (Subscriber x a) -> EventM x ()+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $+  -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them+  --TODO: Should we check if nodes already have their values before propagating?  Maybe we're re-doing work+  WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a++-- | Propagate everything at the current height+propagateFast :: forall x a. a -> FastWeakBag (Subscriber x a) -> EventM x ()+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $+  -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them+  --TODO: Should we check if nodes already have their values before propagating?  Maybe we're re-doing work+  FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a++--------------------------------------------------------------------------------+-- EventSubscribed+--------------------------------------------------------------------------------++toAny :: a -> Any+toAny = unsafeCoerce++-- Why do we use Any here, instead of just giving eventSubscribedRetained an+-- existential type? Sadly, GHC does not currently know how to unbox types+-- with existentially quantified fields. So instead we just coerce values+-- to type Any on the way in. Since we never coerce them back, this is+-- perfectly safe.+data EventSubscribed x = EventSubscribed+  { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)+  , eventSubscribedRetained :: {-# NOUNPACK #-} !Any+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops+  , eventSubscribedHasOwnHeightRef :: !Bool+  , eventSubscribedWhoCreated :: !(IO [String])+#endif+  }++eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x+eventSubscribedRoot !r = EventSubscribed+  { eventSubscribedHeightRef = zeroRef+  , eventSubscribedRetained = toAny r+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = return []+  , eventSubscribedHasOwnHeightRef = False+  , eventSubscribedWhoCreated = return ["root"]+#endif+  }++eventSubscribedNever :: EventSubscribed x+eventSubscribedNever = EventSubscribed+  { eventSubscribedHeightRef = zeroRef+  , eventSubscribedRetained = toAny ()+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = return []+  , eventSubscribedHasOwnHeightRef = False+  , eventSubscribedWhoCreated = return ["never"]+#endif+  }+eventSubscribedNow :: EventSubscribed x+eventSubscribedNow = EventSubscribed+  { eventSubscribedHeightRef = zeroRef+  , eventSubscribedRetained = toAny ()+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = return []+  , eventSubscribedHasOwnHeightRef = False+  , eventSubscribedWhoCreated = return ["now"]+#endif+  }++eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x+eventSubscribedFan !subscribed = EventSubscribed+  { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed+  , eventSubscribedRetained = toAny subscribed+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]+  , eventSubscribedHasOwnHeightRef = False+  , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed+#endif+  }++eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x+eventSubscribedSwitch !subscribed = EventSubscribed+  { eventSubscribedHeightRef = switchSubscribedHeight subscribed+  , eventSubscribedRetained = toAny subscribed+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = do+      s <- readIORef $ switchSubscribedCurrentParent subscribed+      return [_eventSubscription_subscribed s]+  , eventSubscribedHasOwnHeightRef = True+  , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed+#endif+  }++eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x+eventSubscribedCoincidence !subscribed = EventSubscribed+  { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed+  , eventSubscribedRetained = toAny subscribed+#ifdef DEBUG_CYCLES+  , eventSubscribedGetParents = do+      innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed+      let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed+          innerParents = maybeToList $ innerSubscription+      return $ outerParent : innerParents+  , eventSubscribedHasOwnHeightRef = True+  , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed+#endif+  }++getEventSubscribedHeight :: EventSubscribed x -> IO Height+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es++#ifdef DEBUG_CYCLES+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]+whoCreatedEventSubscribed = eventSubscribedWhoCreated++walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]+walkInvalidHeightParents s0 = do+  subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do+    h <- liftIO $ readIORef $ eventSubscribedHeightRef s+    when (h == invalidHeight) $ do+      when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed+      modify (s :)+      mapM_ loop =<< liftIO (eventSubscribedGetParents s)+  forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight+  return subscribers+#endif++{-# INLINE subscribeHoldEvent #-}+subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)+subscribeHoldEvent = subscribeAndRead . holdEvent++--------------------------------------------------------------------------------+-- Behavior+--------------------------------------------------------------------------------++newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }++behaviorHold :: Hold x p -> Behavior x (PatchTarget p)+behaviorHold !h = Behavior $ readHoldTracked h++behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a+behaviorHoldIdentity = behaviorHold++behaviorConst :: a -> Behavior x a+behaviorConst !a = Behavior $ return a++behaviorPull :: Pull x a -> Behavior x a+behaviorPull !p = Behavior $ do+    val <- liftIO $ readIORef $ pullValue p+    case val of+      Just subscribed -> do+        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))+        askInvalidator >>= mapM_ (liftIO . addInvalidatorAmortized (pullSubscribedInvalidators subscribed))+        liftIO $ touch $ pullSubscribedOwnInvalidator subscribed+        return $ pullSubscribedValue subscribed+      Nothing -> do+        i <- liftIO $ newInvalidatorPull p+        wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"+        parentsRef <- liftIO $ newIORef []+        holdInits <- askBehaviorHoldInits+        a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)+        inv0 <- maybeToList <$> askInvalidator+        invsRef <- liftIO $ newIORef $ InvalidatorList (length inv0) invalidatorPruneThreshold inv0+        parents <- liftIO $ readIORef parentsRef+        let subscribed = PullSubscribed+              { pullSubscribedValue = a+              , pullSubscribedInvalidators = invsRef+              , pullSubscribedOwnInvalidator = i+              , pullSubscribedParents = parents+              }+        liftIO $ writeIORef (pullValue p) $ Just subscribed+        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))+        return a++behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d++{-# INLINE readHoldTracked #-}+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)+readHoldTracked h = do+  result <- liftIO $ readIORef $ holdValue h+  askInvalidator >>= mapM_ (liftIO . addInvalidatorAmortized (holdInvalidators h))+  askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))+  liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected+  return result++data InvalidatorList x = InvalidatorList+  { invalidatorListSize :: !Int+  , invalidatorListPruneAt :: !Int+  , invalidatorListElems :: ![Weak (Invalidator x)]+  }++emptyInvalidatorList :: InvalidatorList x+emptyInvalidatorList = InvalidatorList+  { invalidatorListSize = 0+  , invalidatorListPruneAt = invalidatorPruneThreshold+  , invalidatorListElems = []+  }++-- | Add invalidator weak ref to invalidator list, pruning finalized entries+-- once the list grows to its "prune at" size.+{-# INLINE addInvalidatorAmortized #-}+addInvalidatorAmortized :: IORef (InvalidatorList x) -> Weak (Invalidator x) -> IO ()+addInvalidatorAmortized ref weakInvalidator = do+  InvalidatorList listSize pruneAt weakInvalidators <- readIORef ref+  if listSize < pruneAt+    then writeIORef ref $! InvalidatorList (listSize + 1) pruneAt (weakInvalidator : weakInvalidators)+    else do+      (liveCount, liveInvalidators) <-+        foldrM+        (\weakInvalidator' (!liveCount, liveInvalidators) ->+            (\case Just _ -> (liveCount + 1, weakInvalidator' : liveInvalidators)+                   Nothing -> (liveCount, liveInvalidators))+            <$> deRefWeak weakInvalidator')+        (0, [])+        weakInvalidators+      writeIORef ref $! InvalidatorList+        (liveCount + 1)+        (max invalidatorPruneThreshold (2 * liveCount))+        (weakInvalidator : liveInvalidators)++invalidatorPruneThreshold :: Int+invalidatorPruneThreshold = 100++{-# INLINABLE readBehaviorUntracked #-}+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a+readBehaviorUntracked b = do+  holdInits <- getDeferralQueue+  liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases++--------------------------------------------------------------------------------+-- Dynamic+--------------------------------------------------------------------------------++type DynamicS x p = Dynamic x (PatchTarget p) p++data Dynamic x target p = Dynamic+  { dynamicCurrent :: !(Behavior x target)+  , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?+  }++deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)+++++dynamicHold :: Hold x p -> DynamicS x p+dynamicHold !h = Dynamic+  { dynamicCurrent = behaviorHold h+  , dynamicUpdated = eventHold h+  }++dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)+dynamicHoldIdentity = dynamicHold++dynamicConst :: PatchTarget p -> DynamicS x p+dynamicConst !a = Dynamic+  { dynamicCurrent = behaviorConst a+  , dynamicUpdated = eventNever+  }++dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p+dynamicDyn !d = Dynamic+  { dynamicCurrent = behaviorDyn d+  , dynamicUpdated = eventDyn d+  }++dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)+dynamicDynIdentity = dynamicDyn++--------------------------------------------------------------------------------+-- Combinators+--------------------------------------------------------------------------------++--type role Hold representational+data Hold x p+   = Hold { holdValue :: !(IORef (PatchTarget p))+          , holdInvalidators :: !(IORef (InvalidatorList x))+          , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events+          , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef+#ifdef DEBUG_NODEIDS+          , holdNodeId :: Int+#endif+          }++-- | A statically allocated 'SpiderTimeline'+data Global++{-# NOINLINE globalSpiderTimelineEnv #-}+globalSpiderTimelineEnv :: SpiderTimelineEnv Global+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv++-- | Stores all global data relevant to a particular Spider timeline; only one+-- value should exist for each type @x@+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}+-- We implement SpiderTimelineEnv with a newtype wrapper so+-- we can get the coercions we want safely.+type role SpiderTimelineEnv nominal++data SpiderTimelineEnv' x = SpiderTimelineEnv+  { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())+  , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)+#ifdef DEBUG+  , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)+#endif+  }+type role SpiderTimelineEnv' phantom++instance Eq (SpiderTimelineEnv x) where+  _ == _ = True -- Since only one exists of each type++instance GEq SpiderTimelineEnv where+  a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)+              then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments+              else Nothing++data EventEnv x+   = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe+              , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe+              , eventEnvDynInits :: !(IORef [SomeDynInit x])+              , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])+              , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe+              , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe+              , eventEnvIntClears :: !(IORef [Some IntClear])+              , eventEnvRootClears :: !(IORef [Some RootClear])+              , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe+              , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe+              , eventEnvInvalidatedCoincidences :: !(IORef [SomeCoincidenceSubscribed x]) -- Coincidences whose height was set to 'invalidHeight' this frame and must be recalculated; populated by 'invalidateCoincidenceHeight'+              , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))+              }++{-# INLINE runEventM #-}+runEventM :: EventM x a -> IO a+runEventM = unEventM++asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))++class MonadIO m => Defer a m where+  getDeferralQueue :: m (IORef [a])++{-# INLINE defer #-}+defer :: Defer a m => a -> m ()+defer a = do+  q <- getDeferralQueue+  liftIO $ modifyIORef' q (a:)++instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvAssignments++instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvHoldInits++instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvDynInits++instance Defer (SomeHoldInit x) (BehaviorM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = BehaviorM $ asks snd++instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvMergeUpdates++instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvMergeInits++class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where+  getCurrentHeight :: m Height+  scheduleMerge :: Height -> EventM x () -> m ()++instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where+  {-# INLINE getCurrentHeight #-}+  getCurrentHeight = do+    heightRef <- asksEventEnv eventEnvCurrentHeight+    liftIO $ readIORef heightRef+  {-# INLINE scheduleMerge #-}+  scheduleMerge height subscribed = do+    delayedRef <- asksEventEnv eventEnvDelayedMerges+    liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]++class HasSpiderTimeline x where+  -- | Retrieve the current SpiderTimelineEnv+  spiderTimeline :: SpiderTimelineEnv x++instance HasSpiderTimeline Global where+  spiderTimeline = globalSpiderTimelineEnv++putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()+putCurrentHeight h = do+  heightRef <- asksEventEnv eventEnvCurrentHeight+  liftIO $ writeIORef heightRef $! h++instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvClears++{-# INLINE scheduleClear #-}+scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()+scheduleClear r = defer $ Some $ Clear r++instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvIntClears++{-# INLINE scheduleIntClear #-}+scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()+scheduleIntClear r = defer $ Some $ IntClear r++instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvRootClears++{-# INLINE scheduleRootClear #-}+scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()+scheduleRootClear r = defer $ Some $ RootClear r++instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where+  {-# INLINE getDeferralQueue #-}+  getDeferralQueue = asksEventEnv eventEnvResetCoincidences++-- Note: hold cannot examine its event until after the phase is over+{-# INLINE [1] hold #-}+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)+hold v0 e = do+  valRef <- liftIO $ newIORef v0+  invsRef <- liftIO $ newIORef emptyInvalidatorList+  parentRef <- liftIO $ newIORef Nothing+#ifdef DEBUG_NODEIDS+  nodeId <- liftIO newNodeId+#endif+  let h = Hold+        { holdValue = valRef+        , holdInvalidators = invsRef+        , holdEvent = e+        , holdParent = parentRef+#ifdef DEBUG_NODEIDS+        , holdNodeId = nodeId+#endif+        }+  defer $ SomeHoldInit h+  return h++{-# INLINE getHoldEventSubscription #-}+getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)+getHoldEventSubscription h = do+  ep <- liftIO $ readIORef $ holdParent h+  case ep of+    Just subd -> return subd+    Nothing -> do+      let e = holdEvent h+      subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"+      (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)+      liftIO $ writeIORef subscriptionRef $! subscription+      case occ of+        Nothing -> return ()+        Just o -> do+          old <- liftIO $ readIORef $ holdValue h+          case apply o old of+            Nothing -> return ()+            Just new -> do+              -- Need to evaluate these so that we don't retain the Hold itself+              v <- liftIO $ evaluate $ holdValue h+              i <- liftIO $ evaluate $ holdInvalidators h+              defer $ SomeAssignment v i new+      liftIO $ writeIORef (holdParent h) $ Just subscription+      return subscription++type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])++-- BehaviorM can sample behaviors+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }+  deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))++instance Monad (BehaviorM x) where+  {-# INLINE (>>=) #-}+  BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f+#if !MIN_VERSION_base(4,13,0)+  {-# INLINE fail #-}+  fail s = BehaviorM $ fail s+#endif++data BehaviorSubscribed x a+   = forall p. BehaviorSubscribedHold (Hold x p)+   | BehaviorSubscribedPull (PullSubscribed x a)++newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))++--type role PullSubscribed representational+data PullSubscribed x a+   = PullSubscribed { pullSubscribedValue :: !a+                    , pullSubscribedInvalidators :: !(IORef (InvalidatorList x))+                    , pullSubscribedOwnInvalidator :: !(Invalidator x)+                    , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated+                    }++--type role Pull representational+data Pull x a+   = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))+          , pullCompute :: !(BehaviorM x a)+#ifdef DEBUG_NODEIDS+          , pullNodeId :: Int+#endif+          }++data Invalidator x+   = forall a. InvalidatorPull (Pull x a)+   | forall a. InvalidatorSwitch (SwitchSubscribed x a)++data RootSubscribed x a = forall k. GCompare k => RootSubscribed+  { rootSubscribedKey :: !(k a)+  , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root+  , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))+  , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence+  , rootSubscribedUninit :: IO ()+  , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?+#ifdef DEBUG_NODEIDS+  , rootSubscribedNodeId :: Int+#endif+  }++data Root x k+   = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event+          , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))+          , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))+          }++data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)++data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)++data SomeMergeUpdate x = SomeMergeUpdate+  { _someMergeUpdate_update :: !(EventM x [EventSubscription x])+  , _someMergeUpdate_invalidateHeight :: !(IO ())+  , _someMergeUpdate_recalculateHeight :: !(IO ())+  }++newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }++-- EventM can do everything BehaviorM can, plus create holds+newtype EventM x a = EventM { unEventM :: IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException, MonadCatch, MonadThrow, MonadMask)++newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }++data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove+  { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)+  , _mergeSubscribedParentWithMove_key :: !(IORef (k a))+  }++data HeightBag = HeightBag+  { _heightBag_size :: {-# UNPACK #-} !Int+  , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket+  }+  deriving (Show, Read, Eq, Ord)++heightBagEmpty :: HeightBag+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty++heightBagSize :: HeightBag -> Int+heightBagSize = _heightBag_size++heightBagFromList :: [Height] -> HeightBag+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights++heightBagAdd :: Height -> HeightBag -> HeightBag+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $+  IntMap.insertWithKey (\_ _ old -> succ old) h 0 c++heightBagRemove :: Height -> HeightBag -> HeightBag+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of+  Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b+  Just old -> HeightBag (pred s) $ case old of+    0 -> IntMap.delete h c+    _ -> IntMap.insert h (pred old) c++heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag+heightBagRemoveMaybe (Height h) (HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where+  removed old = HeightBag (pred s) $ case old of+    0 -> IntMap.delete h c+    _ -> IntMap.insert h (pred old) c+++heightBagMax :: HeightBag -> Height+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of+  Just ((h, _), _) -> Height h+  Nothing -> zeroHeight++heightBagVerify :: HeightBag -> HeightBag+#ifdef DEBUG+heightBagVerify b@(HeightBag s c) = if+  | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))+    -> error $ "heightBagVerify: size doesn't match: " <> show b+  | unHeight invalidHeight `IntMap.member` c+    -> error $ "heightBagVerify: contains invalid height: " <> show b+  | otherwise -> b+#else+heightBagVerify = id+#endif++data FanSubscribedChildren x k v a = FanSubscribedChildren+  { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))+  , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)+  , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))+  }++data FanSubscribed x k v+   = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))+                   , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))+                   , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty+                   , fanSubscribedParent :: !(EventSubscription x)+#ifdef DEBUG_NODEIDS+                   , fanSubscribedNodeId :: Int+#endif+                   }++data Fan x k v+   = Fan { fanParent :: !(Event x (DMap k v))+         , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))+         }++data SwitchSubscribed x a+   = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))+                      , switchSubscribedOccurrence :: !(IORef (Maybe a))+                      , switchSubscribedHeight :: !(IORef Height)+                      , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))+                      , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)+                      , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))+                      , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])+                      , switchSubscribedParent :: !(Behavior x (Event x a))+                      , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))+                      , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))+#ifdef DEBUG_NODEIDS+                      , switchSubscribedNodeId :: Int+#endif+                      }++data Switch x a+   = Switch { switchParent :: !(Behavior x (Event x a))+            , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))+            }++{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}+data CoincidenceSubscribed x a+   = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))+                           , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))+                           , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))+                           , coincidenceSubscribedHeight :: !(IORef Height)+                           , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))+                           , coincidenceSubscribedOuterParent :: !(EventSubscription x)+                           , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))+                           , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))+#ifdef DEBUG_NODEIDS+                           , coincidenceSubscribedNodeId :: Int+#endif+                           }++data Coincidence x a+   = Coincidence { coincidenceParent :: !(Event x (Event x a))+                 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))+                 }++{-# NOINLINE newInvalidatorSwitch #-}+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd++{-# NOINLINE newInvalidatorPull #-}+newInvalidatorPull :: Pull x a -> IO (Invalidator x)+newInvalidatorPull p = return $! InvalidatorPull p++instance HasSpiderTimeline x => Filterable (Event x) where+  mapMaybe f = push $ return . f++instance HasSpiderTimeline x => Align (Event x) where+  nil = eventNever+#if MIN_VERSION_these(0, 8, 0)+instance HasSpiderTimeline x => Semialign (Event x) where+#endif+  align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $+     DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]++#ifdef MIN_VERSION_semialign+#if MIN_VERSION_semialign(1,1,0)+instance HasSpiderTimeline x => Zip (Event x) where+#endif+  zip x y = mapMaybe justThese $ align x y+#endif++data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)+                 | BuildDyn  !(EventM x (PatchTarget p), Event x p)+                 | HoldDyn   !(Hold x p)++newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }++newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)++--TODO: Avoid the duplication between this and R.zipDynWith+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)+zipDynWith f da db =+  let eab = align (dynamicUpdated da) (dynamicUpdated db)+      ec = flip push eab $ \o -> do+        (a, b) <- case o of+          This (Identity a) -> do+            b <- readBehaviorUntracked $ dynamicCurrent db+            return (a, b)+          That (Identity b) -> do+            a <- readBehaviorUntracked $ dynamicCurrent da+            return (a, b)+          These (Identity a) (Identity b) -> return (a, b)+        return $ Just $ Identity $ f a b+  in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec++buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)+buildDynamic readV0 v' = do+  result <- liftIO $ newIORef $ BuildDyn (readV0, v')+  let !d = Dyn result+  defer $ SomeDynInit d+  return d++unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p+unsafeBuildDynamic readV0 v' =+  Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')++-- ResultM can read behaviors and events+type ResultM = EventM++instance HasSpiderTimeline x => Functor (Event x) where+  fmap f = push $ return . Just . f++instance Functor (Behavior x) where+  fmap f = pull . fmap f . readBehaviorTracked++{-# INLINE push #-}+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b+push f e = cacheEvent (pushCheap f e)++{-# INLINABLE pull #-}+pull :: BehaviorM x a -> Behavior x a+pull a = unsafePerformIO $ do+  ref <- newIORef Nothing+#ifdef DEBUG_NODEIDS+  nid <- newNodeId+#endif+  pure $ behaviorPull $ Pull+    { pullCompute = a+    , pullValue = ref+#ifdef DEBUG_NODEIDS+    , pullNodeId = nid+#endif+    }++{-# INLINABLE switch #-}+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a+switch a = unsafePerformIO $ do+  ref <- newIORef Nothing+  pure $ eventSwitch $ Switch+    { switchParent = a+    , switchSubscribed = ref+    }++coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a+coincidence a = unsafePerformIO $ do+  ref <- newIORef Nothing+  pure $ eventCoincidence $ Coincidence+    { coincidenceParent = a+    , coincidenceSubscribed = ref+    }++-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b+run roots after = do+  tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"+  let t = spiderTimeline :: SpiderTimelineEnv x+  result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do+    rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do+      occBefore <- liftIO $ do+        occBefore <- readIORef occRef+        writeIORef occRef $! DMap.insert k a occBefore+        return occBefore+      if DMap.null occBefore+        then do scheduleRootClear occRef+                return $ Just r+        else return Nothing+    forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do+      propagate a subscribersRef+    delayedRef <- asksEventEnv eventEnvDelayedMerges+    let go = do+          delayed <- liftIO $ readIORef delayedRef+          case IntMap.minViewWithKey delayed of+            Nothing -> return ()+            Just ((currentHeight, cur), future) -> do+              tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight+              putCurrentHeight $ Height currentHeight+              liftIO $ writeIORef delayedRef $! future+              sequence_ cur+              go+    go+    putCurrentHeight maxBound+    after+  tracePropagate (Proxy :: Proxy x) "Done running an event frame"+  return result++scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do+  height <- liftIO $ readIORef heightRef+  currentHeight <- getCurrentHeight+  case height `compare` currentHeight of+    LT -> error "Somehow a merge's height has been decreased after it was scheduled"+    GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)+    EQ -> a++newtype Clear a = Clear (IORef (Maybe a))++newtype IntClear a = IntClear (IORef (IntMap a))++newtype RootClear k = RootClear (IORef (DMap k Identity))++data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef (InvalidatorList x)) a++debugFinalize :: Bool+debugFinalize = False++mkWeakPtrWithDebug :: a -> String -> IO (Weak a)+mkWeakPtrWithDebug x debugNote = do+  x' <- evaluate x+  mkWeakPtr x' $+    if debugFinalize+    then Just $ debugStrLn $ "finalizing: " ++ debugNote+    else Nothing++type CanTrace x m = (HasSpiderTimeline x, MonadIO m)+++++#ifdef DEBUG++debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)+debugSubscriber description = return . debugSubscriber' description++debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a+debugSubscriber' description subscribed = Subscriber+  {+    subscriberPropagate = \m -> do+      tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)+      subscriberPropagate subscribed m+  , subscriberInvalidateHeight = \old -> do+      traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)+      subscriberInvalidateHeight subscribed old+      traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"+  , subscriberRecalculateHeight = \new -> do+      traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)+      subscriberRecalculateHeight subscribed new+      traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"+  }+++{-# INLINE withIncreasedDepth #-}+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a+withIncreasedDepth _ a = do+  liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ+  result <- a+  liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred+  return result++{-# INLINE tracePropagate #-}+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()+tracePropagate p = when debugPropagate . trace p++{-# INLINE traceInvalidate #-}+traceInvalidate :: String -> IO ()+traceInvalidate = when debugInvalidate . liftIO . debugStrLn++{-# INLINE traceInvalidateHeight #-}+traceInvalidateHeight :: String -> IO ()+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn++{-# INLINE trace #-}+trace :: (CanTrace x m) => proxy x ->  String -> m ()+trace p message = traceM p $ return message++{-# INLINE traceM #-}+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()+traceM _ getMessage = do+  message <- getMessage+  d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)+  liftIO $ debugStrLn $ replicate d ' ' <> message++#else++{-# INLINE withIncreasedDepth #-}+withIncreasedDepth ::  proxy x -> m a -> m a+withIncreasedDepth _ = id++{-# INLINE tracePropagate #-}+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()+tracePropagate _ _ = return ()++{-# INLINE traceInvalidate #-}+traceInvalidate :: String -> IO ()+traceInvalidate _ = return ()++{-# INLINE traceInvalidateHeight #-}+traceInvalidateHeight :: String -> IO ()+traceInvalidateHeight _ = return ()++{-# INLINE debugSubscriber #-}+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)+debugSubscriber _ = return++{-# INLINE debugSubscriber' #-}+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a+debugSubscriber' _ = id++++{-# INLINE trace #-}+trace :: (CanTrace x m) => proxy x ->  String -> m ()+trace _ _ = return ()++{-# INLINE traceM #-}+traceM :: (CanTrace x m) => proxy x -> m String -> m ()+traceM _ _ = return ()++#endif++whoCreatedIORef :: IORef a -> IO [String]+whoCreatedIORef (IORef a) = whoCreated $! a++groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]+groupByHead = \case+  [] -> []+  (x :| xs) : t -> case groupByHead t of+    [] -> [(x, xs :| [])]+    l@((y, yss) : t')+      | x == y -> (x, xs `NonEmpty.cons` yss) : t'+      | otherwise -> (x, xs :| []) : l++listsToForest :: Eq a => [[a]] -> Forest a+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)+    where buildForest (a, lists') = Node a $ listsToForest $ toList lists'++showStacks :: [[String]] -> String+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")++filterStack :: String -> [String] -> [String]+#ifdef DEBUG_HIDE_INTERNALS+filterStack prefix = filter (not . (prefix `isPrefixOf`))+#else+filterStack _prefix = id+#endif++#ifdef DEBUG_CYCLES++data EventLoopException = EventLoopException [[String]]+instance Exception EventLoopException++instance Show EventLoopException where+  show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks+    then "no location information, compile with profiling enabled for stack tree"+    else showStacks stacks++#else++data EventLoopException = EventLoopException+instance Exception EventLoopException++instance Show EventLoopException where+  show EventLoopException = "causality loop detected: \n" <>+    "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"++#endif+++{-# INLINE propagateSubscriberHold #-}+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()+propagateSubscriberHold h a = do+  {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do+    InvalidatorList n _ _ <- liftIO $ readIORef $ holdInvalidators h+    return $ "SubscriberHold" <> showNodeId h <> ": " ++ show n++  v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h+  case {-# SCC "apply" #-} apply a v of+    Nothing -> return ()+    Just v' -> do+      {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $+        tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)+      vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h+      iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h+      defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'++-- | 'CoincidenceSubscribed' is present only when the coincidence raised its height while subscribing to the inner event.+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a))+data SomeCoincidenceSubscribed x = forall a. SomeCoincidenceSubscribed !(CoincidenceSubscribed x a)++runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)++askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))+askInvalidator = do+  (!m, _) <- ask+  case m of+    Nothing -> return Nothing+    Just (!wi, _) -> return $ Just wi++askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))+askParentsRef = do+  (!m, _) <- ask+  case m of+    Nothing -> return Nothing+    Just (_, !p) -> return $ Just p++askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])+askBehaviorHoldInits = do+  (_, !his) <- ask+  return his++{-# INLINE getDynHold #-}+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)+getDynHold d = do+  mh <- liftIO $ readIORef $ unDyn d+  case mh of+    HoldDyn h -> return h+    UnsafeDyn (readV0, v') -> do+      holdInits <- getDeferralQueue+      v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits+      hold' v0 v'+    BuildDyn (readV0, v') -> do+      v0 <- liftIO $ runEventM readV0+      hold' v0 v'+  where+    hold' v0 v' = do+      h <- hold v0 v'+      liftIO $ writeIORef (unDyn d) $ HoldDyn h+      return h+++-- Always refers to 0+{-# NOINLINE zeroRef #-}+zeroRef :: IORef Height+zeroRef = unsafePerformIO $ newIORef zeroHeight++getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)+getRootSubscribed k r sub = do+  mSubscribed <- readIORef $ rootSubscribed r+  let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r+  case DMap.lookup k mSubscribed of+    Just subscribed -> {-# SCC "hitRoot" #-} do+      sln <- subscribeRootSubscribed subscribed sub+      occ <- getOcc+      return (sln, subscribed, occ)+    Nothing -> {-# SCC "missRoot" #-} do+      weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"+      let !cached = rootSubscribed r+      uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"+      (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed++      tracePropagate (Proxy::Proxy x) $  "getRootSubscribed: calling rootInit"++      uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)+      writeIORef uninitRef $! uninit+#ifdef DEBUG_NODEIDS+      nid <- newNodeId+#endif+      let !subscribed = RootSubscribed+            { rootSubscribedKey = k+            , rootSubscribedCachedSubscribed = cached+            , rootSubscribedOccurrence = getOcc+            , rootSubscribedSubscribers = subs+            , rootSubscribedUninit = uninit+            , rootSubscribedWeakSelf = weakSelf+#ifdef DEBUG_NODEIDS+            , rootSubscribedNodeId = nid+#endif+            }+          -- If we die at the same moment that all our children die, they will+          -- try to clean us up but will fail because their Weak reference to us+          -- will also be dead.  So, if we are dying, check if there are any+          -- children; since children don't bother cleaning themselves up if+          -- their parents are already dead, I don't think there's a race+          -- condition here.  However, if there are any children, then we can+          -- infer that we need to clean ourselves up, so we do.+          finalCleanup = do+            cs <- readIORef $ _weakBag_children subs+            when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)+      writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)+      modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it+      occ <- getOcc+      return (sln, subscribed, occ)++{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}+cleanupRootSubscribed :: RootSubscribed x a -> IO ()+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do+  rootSubscribedUninit self+  modifyIORef' cached $ DMap.delete k++{-# INLINE subscribeRootSubscribed #-}+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed++newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }++data FanInt x a = FanInt+  { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty+  , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty+  , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))+#ifdef DEBUG_NODEIDS+  , _fanInt_nodeId :: {-# UNPACK #-} !Int+#endif+  }++newFanInt :: IO (FanInt x a)+newFanInt = do+  subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty+  subscriptionRef <- newIORef $ error "fanInt: no subscription"+  occRef <- newIORef $ error "fanInt: no occurrence"+#ifdef DEBUG_NODEIDS+  nodeId <- newNodeId+#endif+  return $ FanInt+    { _fanInt_subscribers = subscribers+    , _fanInt_subscriptionRef = subscriptionRef+    , _fanInt_occRef = occRef+#ifdef DEBUG_NODEIDS+    , _fanInt_nodeId = nodeId+#endif+    }++fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a+fanInt p = unsafePerformIO $ do+  self <- newFanInt+  pure $ EventSelectorInt $ \k -> Event $ \sub -> do+    isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)+    when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input+      let desc = "fanInt" <> showNodeId self <> ", k = "  <> show k+      (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber+        { subscriberPropagate = \m -> do+            liftIO $ writeIORef (_fanInt_occRef self) m+            scheduleIntClear $ _fanInt_occRef self+            FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v ->  --TODO: Do we need to know that no subscribers are being added as we traverse?+              FastWeakBag.traverse_ b $ \s ->+                subscriberPropagate s v+        , subscriberInvalidateHeight = \old ->+            FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->+              FastWeakBag.traverse_ b $ \s ->+                subscriberInvalidateHeight s old+        , subscriberRecalculateHeight = \new ->+            FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->+              FastWeakBag.traverse_ b $ \s ->+                subscriberRecalculateHeight s new+        }+      liftIO $ do+        writeIORef (_fanInt_subscriptionRef self) subscription+        writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc+      scheduleIntClear $ _fanInt_occRef self+    liftIO $ do+      b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case+        Nothing -> do+          b <- FastWeakBag.empty+          FastMutableIntMap.insert (_fanInt_subscribers self) k b+          return b+        Just b -> return b+      ticket <- liftIO $ FastWeakBag.insert sub b+      currentOcc <- readIORef (_fanInt_occRef self)++      subscribed <- fanIntSubscribed ticket self+      return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)++fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)+fanIntSubscribed ticket self = do+  subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)+  return $ EventSubscribed+    { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent+    , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)+#ifdef DEBUG_CYCLES+    , eventSubscribedGetParents = return [subscribedParent]+    , eventSubscribedHasOwnHeightRef = False+    , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self+#endif+    }+++{-# INLINABLE getFanSubscribed #-}+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))+getFanSubscribed k f sub = do+  mSubscribed <- liftIO $ readIORef $ fanSubscribed f+  case mSubscribed of+    Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do+      sln <- subscribeFanSubscribed k subscribed sub+      occ <- readIORef $ fanSubscribedOccurrence subscribed+      return (sln, subscribed, coerce $ DMap.lookup k =<< occ)+    Nothing -> {-# SCC "missFan" #-} do+      subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      s <- liftIO $ newSubscriberFan subscribedUnsafe+      (subscription, parentOcc) <- subscribeAndRead (fanParent f) s+      weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"+      (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed+      subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"+      occRef <- liftIO $ newIORef parentOcc+      when (isJust parentOcc) $ scheduleClear occRef+#ifdef DEBUG_NODEIDS+      nid <- liftIO newNodeId+#endif+      let subscribed = FanSubscribed+            { fanSubscribedCachedSubscribed = fanSubscribed f+            , fanSubscribedOccurrence = occRef+            , fanSubscribedParent = subscription+            , fanSubscribedSubscribers = subscribersRef+#ifdef DEBUG_NODEIDS+            , fanSubscribedNodeId = nid+#endif+            }+      let !self = (k, subscribed)+      liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf+      liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"+      liftIO $ writeIORef subscribedRef $! subscribed+      liftIO $ writeIORef (fanSubscribed f) $ Just subscribed+      return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)++cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()+cleanupFanSubscribed (k, subscribed) = do+  subscribers <- readIORef $ fanSubscribedSubscribers subscribed+  let reducedSubscribers = DMap.delete k subscribers+  if DMap.null reducedSubscribers+    then do+      unsubscribe $ fanSubscribedParent subscribed+      -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers+      writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing+    else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers++{-# INLINE subscribeFanSubscribed #-}+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket+subscribeFanSubscribed k subscribed sub = do+  subscribers <- readIORef $ fanSubscribedSubscribers subscribed+  case DMap.lookup k subscribers of+    Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do+      let !self = (k, subscribed)+      weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"+      (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed+      writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers+      return sln+    Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed++{-# INLINABLE getSwitchSubscribed #-}+getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)+getSwitchSubscribed s sub = do+  mSubscribed <- liftIO $ readIORef $ switchSubscribed s+  case mSubscribed of+    Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do+      sln <- subscribeSwitchSubscribed subscribed sub+      occ <- readIORef $ switchSubscribedOccurrence subscribed+      return (sln, subscribed, occ)+    Nothing -> {-# SCC "missSwitch" #-} do+      subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      i <- liftIO $ newInvalidatorSwitch subscribedUnsafe+      mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe+      wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"+      wiRef <- liftIO $ newIORef wi+      parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior+      holdInits <- getDeferralQueue+      e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits+      (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub+      heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd+      subscriptionRef <- liftIO $ newIORef subscription+      occRef <- liftIO $ newIORef parentOcc+      when (isJust parentOcc) $ scheduleClear occRef+      weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"+      (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed+#ifdef DEBUG_NODEIDS+      nid <- liftIO newNodeId+#endif+      let !subscribed = SwitchSubscribed+            { switchSubscribedCachedSubscribed = switchSubscribed s+            , switchSubscribedOccurrence = occRef+            , switchSubscribedHeight = heightRef+            , switchSubscribedSubscribers = subs+            , switchSubscribedOwnInvalidator = i+            , switchSubscribedOwnWeakInvalidator = wiRef+            , switchSubscribedBehaviorParents = parentsRef+            , switchSubscribedParent = switchParent s+            , switchSubscribedCurrentParent = subscriptionRef+            , switchSubscribedWeakSelf = weakSelf+#ifdef DEBUG_NODEIDS+            , switchSubscribedNodeId = nid+#endif+            }+      liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"+      liftIO $ writeIORef subscribedRef $! subscribed+      liftIO $ writeIORef (switchSubscribed s) $ Just subscribed+      return (slnForSub, subscribed, parentOcc)++cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()+cleanupSwitchSubscribed subscribed = do+  unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)+  finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead+  writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing++{-# INLINE subscribeSwitchSubscribed #-}+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed++{-# INLINABLE getCoincidenceSubscribed #-}+getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)+getCoincidenceSubscribed c sub = do+  mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c+  case mSubscribed of+    Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do+      sln <- subscribeCoincidenceSubscribed subscribed sub+      occ <- readIORef $ coincidenceSubscribedOccurrence subscribed+      return (sln, subscribed, occ)+    Nothing -> {-# SCC "missCoincidence" #-} do+      subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe+      (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter+      outerHeight <- liftIO $ getEventSubscribedHeight outerSubd+      (occ, height, mInnerSubd) <- case outerOcc of+        Nothing -> return (Nothing, outerHeight, Nothing)+        Just o -> do+          (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe+          return (occ, height, Just innerSubd)+      occRef <- liftIO $ newIORef occ+      when (isJust occ) $ scheduleClear occRef+      heightRef <- liftIO $ newIORef height+      innerSubdRef <- liftIO $ newIORef mInnerSubd+      scheduleClear innerSubdRef+      weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"+      (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed+#ifdef DEBUG_NODEIDS+      nid <- liftIO newNodeId+#endif+      let subscribed = CoincidenceSubscribed+            { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c+            , coincidenceSubscribedOccurrence = occRef+            , coincidenceSubscribedHeight = heightRef+            , coincidenceSubscribedSubscribers = subs+            , coincidenceSubscribedOuter = subOuter+            , coincidenceSubscribedOuterParent = outerSubscription+            , coincidenceSubscribedInnerParent = innerSubdRef+            , coincidenceSubscribedWeakSelf = weakSelf+#ifdef DEBUG_NODEIDS+            , coincidenceSubscribedNodeId = nid+#endif+            }+      liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"+      liftIO $ writeIORef subscribedRef $! subscribed+      liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed+      return (slnForSub, subscribed, occ)++cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()+cleanupCoincidenceSubscribed subscribed = do+  unsubscribe $ coincidenceSubscribedOuterParent subscribed+  writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing++{-# INLINE subscribeCoincidenceSubscribed #-}+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed++{-# INLINE mergeG #-}+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)+  => (forall a. q a -> Event x (v a))+  -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)+mergeG nt d = cacheEvent (mergeCheap nt d)++{-# INLINE mergeWithMove #-}+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)+  => (forall a. q a -> Event x (v a))+  -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)++{-# INLINE [1] mergeCheap #-}+mergeCheap+  :: forall k x q v. (HasSpiderTimeline x, GCompare k)+  => (forall a. q a -> Event x (v a))+  -> DynamicS x (PatchDMap k q)+  -> Event x (DMap k v)+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy+  where+      updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)+      updateMe subscriber heightBagRef oldParents (PatchDMap p) = do+        let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do+              (mOldSubd, newPs) <- case me of+                Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps+                Just e -> do+                  let s = subscriber $ return k+                  subscription@(EventSubscription _ subd) <- subscribe (nt e) s+                  newParentHeight <- liftIO $ getEventSubscribedHeight subd+                  let newParent = MergeSubscribedParent subscription+                  liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight+                  return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps+              forM_ mOldSubd $ \oldSubd -> do+                oldHeight <- liftIO $ getEventSubscribedHeight $+                  _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd++                liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight+              return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)+        foldM f ([], oldParents) $ DMap.toList p++      getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)+      getInitialSubscribers initialParents subscriber = do+        subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do+          let s = subscriber $ return k+          (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s+          height <- liftIO $ getEventSubscribedHeight parentSubd+          return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)+        return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers+               , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here+               , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers+               )++      destroy :: MergeDestroyFunc k (MergeSubscribedParent x)+      destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub++{-# INLINE [1] mergeCheapWithMove #-}+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)+  => (forall a. q a -> Event x (v a))+  -> DynamicS x (PatchDMapWithMove k q)+  -> Event x (DMap k v)+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy+  where+      updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)+      updateMe subscriber heightBagRef oldParents p = do+        -- Prepare new parents for insertion+        let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)+            subscribeParent k e = do+              keyRef <- liftIO $ newIORef k+              let s = subscriber $ liftIO $ readIORef keyRef+              subscription@(EventSubscription _ subd) <- subscribe e s+              liftIO $ do+                newParentHeight <- getEventSubscribedHeight subd+                modifyIORef' heightBagRef $ heightBagAdd newParentHeight+                return $ MergeSubscribedParentWithMove subscription keyRef+        p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p+        -- Collect old parents for deletion and update the keys of moved parents+        let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a+            moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of+              Nothing -> do+                oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $+                  _mergeSubscribedParentWithMove_subscription parent++                liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight+                return $ Just $ _mergeSubscribedParentWithMove_subscription parent+              Just toKey -> do+                liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey+                return Nothing+        toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $+          DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents++        return (toDelete, applyAlways p' oldParents)+      getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)+      getInitialSubscribers initialParents subscriber = do+        subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do+          keyRef <- liftIO $ newIORef k+          let s = subscriber $ liftIO $ readIORef keyRef+          (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s+          height <- liftIO $ getEventSubscribedHeight parentSubd+          return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)+        return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers+               , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here+               , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers+               )++      destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)+      destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub++type MergeUpdateFunc k v x p s+   = (forall a. EventM x (k a) -> Subscriber x (v a))+  -> IORef HeightBag+  -> DMap k s+  -> p+  -> EventM x ([EventSubscription x], DMap k s)++type MergeGetSubscription x s = forall a. s a -> EventSubscription x++type MergeInitFunc k v q x s+   = DMap k q+  -> (forall a. EventM x (k a) -> Subscriber x (v a))+  -> EventM x (DMap k v, [Height], DMap k s)++type MergeDestroyFunc k s+   = DMap k s+  -> IO ()++data Merge x k v s = Merge+  { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))+  , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)+  , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)+  , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))+  , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))+  }++invalidateMergeHeight :: Merge x k v s -> IO ()+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)++invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()+invalidateMergeHeight' heightRef sub = do+  oldHeight <- readIORef heightRef+  -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents+  when (oldHeight /= invalidHeight) $ do+    writeIORef heightRef $! invalidHeight+    subscriberInvalidateHeight sub oldHeight++revalidateMergeHeight :: Merge x k v s -> IO ()+revalidateMergeHeight m = do+  currentHeight <- readIORef $ _merge_heightRef m++  -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check+  when (currentHeight == invalidHeight) $ do+    heights <- readIORef $ _merge_heightBagRef m+    parents <- readIORef $ _merge_parentsRef m+    -- When the number of heights in the bag reaches the number of parents, we should have a valid height+    case heightBagSize heights `compare` DMap.size parents of+      LT -> return ()+      EQ -> do+        let height = succHeight $ heightBagMax heights+        traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height+        writeIORef (_merge_heightRef m) $! height+        subscriberRecalculateHeight (_merge_sub m) height+      GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"++scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do+  vals <- liftIO $ readIORef $ _merge_accumRef m+  -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,+  -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers+  liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty+  --TODO: Assert that m is not empty+  subscriberPropagate (_merge_sub m) vals++checkCycle :: EventSubscribed x -> EventM x ()+checkCycle subscribed = liftIO $ do+    height <- readIORef (eventSubscribedHeightRef subscribed)++    -- currentHeight <- getCurrentHeight+    -- when (height <= currentHeight) $ if height /= invalidHeight+    --     then do+    --       myStack <- liftIO $ whoCreatedIORef undefined --TODO+    --       error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)+    --     else liftIO $+    when (height == invalidHeight) $+#ifdef DEBUG_CYCLES+          do+            nodesInvolvedInCycle <- walkInvalidHeightParents subscribed+            stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed+            throwIO (EventLoopException stacks)+#else+          throwIO EventLoopException+#endif+++mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)+mergeSubscriber subscribed m getKey = Subscriber+  { subscriberPropagate = \a -> do+      oldM <- liftIO $ readIORef $ _merge_accumRef m+      k <- getKey+      let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM+      tracePropagate (Proxy :: Proxy x) $ "  DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)+      liftIO $ writeIORef (_merge_accumRef m) $! newM+      when (DMap.null oldM) $ do -- Only schedule the firing once+        height <- liftIO $ readIORef $ _merge_heightRef m+        checkCycle subscribed++        scheduleMergeSelf m height+  , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating+      modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old+      invalidateMergeHeight m+  , subscriberRecalculateHeight = \new -> do+      modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new+      revalidateMergeHeight m+  }++--TODO: Be able to run as much of this as possible promptly+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)+  where updateMe = do+          oldParents <- liftIO $ readIORef $ _merge_parentsRef m+          (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p+          liftIO $ writeIORef (_merge_parentsRef m) $! newParents+          return subscriptionsToKill++{-# INLINE mergeGCheap' #-}+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)+  => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)+mergeGCheap' _ getInitialSubscribers updateFunc destroy d = Event $ \sub -> do+  initialParents <- readBehaviorUntracked $ dynamicCurrent d+  accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"+  heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"+  heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"+  parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"+  changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"++  let subscribed = EventSubscribed+        { eventSubscribedHeightRef = heightRef+        , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)+#ifdef DEBUG_CYCLES+      , eventSubscribedGetParents = do+          let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)+          fmap getParent' . DMap.toList  <$> readIORef parentsRef+      , eventSubscribedHasOwnHeightRef = False+      , eventSubscribedWhoCreated = whoCreatedIORef heightRef+#endif+      }++      m = Merge+        { _merge_parentsRef = parentsRef+        , _merge_heightBagRef = heightBagRef+        , _merge_heightRef = heightRef+        , _merge_sub = sub+        , _merge_accumRef = accumRef+        }+  (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m+  let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights+      myHeight = if invalidHeight `elem` heights+                 then invalidHeight+                 else succHeight $ heightBagMax myHeightBag+  currentHeight <- getCurrentHeight+  let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now+                     then (if DMap.null dm then Nothing else Just dm, DMap.empty)+                     else (Nothing, dm)+  unless (DMap.null accum) $ scheduleMergeSelf m myHeight+  liftIO $ writeIORef accumRef $! accum+  liftIO $ writeIORef heightRef $! myHeight+  liftIO $ writeIORef heightBagRef $! myHeightBag+  liftIO $ writeIORef parentsRef $! initialParentState+  defer $ SomeMergeInit $ do+    let changeSubscriber = Subscriber+          { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do+              tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"+              defer $ updateMerge subscribed m updateFunc a+          , subscriberInvalidateHeight = \_ -> return ()+          , subscriberRecalculateHeight = \_ -> return ()+          }+    (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber+    forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c+    -- We explicitly hold on to the unsubscribe function from subscribing to the update event.+    -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain+    -- its subscription.+    liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)+  let unsubscribeAll = destroy =<< readIORef parentsRef++  return (EventSubscription unsubscribeAll subscribed, occ)+++mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)+mergeInt = cacheEvent . mergeIntCheap++{-# INLINABLE mergeIntCheap #-}+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)+mergeIntCheap d = Event $ \sub -> do+  initialParents <- readBehaviorUntracked $ dynamicCurrent d+  accum <- liftIO $ FastMutableIntMap.newEmpty+  heightRef <- liftIO $ newIORef zeroHeight+  heightBagRef <- liftIO $ newIORef heightBagEmpty+  parents <- liftIO $ FastMutableIntMap.newEmpty+  changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"+  let subscribed = EventSubscribed+        { eventSubscribedHeightRef = heightRef+        , eventSubscribedRetained = toAny (parents, changeSubdRef)+#ifdef DEBUG_CYCLES+        , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents+        , eventSubscribedHasOwnHeightRef = False+        , eventSubscribedWhoCreated = whoCreatedIORef heightRef+#endif+        }+  let scheduleSelf = do+        height <- liftIO $ readIORef $ heightRef+        scheduleMerge' height heightRef $ do+          vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum+          subscriberPropagate sub vals+      invalidateMyHeight = invalidateMergeHeight' heightRef sub+      recalculateMyHeight = do+        currentHeight <- readIORef heightRef+        when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?+          heights <- readIORef heightBagRef+          numParents <- FastMutableIntMap.size parents+          case heightBagSize heights `compare` numParents of+            LT -> return ()+            EQ -> do+              let height = succHeight $ heightBagMax heights+              traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height+              writeIORef heightRef $! height+              subscriberRecalculateHeight sub height+            GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"+      mySubscriber k = Subscriber+        { subscriberPropagate = \a -> do+            checkCycle subscribed++            wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum+            liftIO $ FastMutableIntMap.insert accum k a+            when wasEmpty scheduleSelf+        , subscriberInvalidateHeight = \old -> do+            modifyIORef' heightBagRef $ heightBagRemove old+            invalidateMyHeight+        , subscriberRecalculateHeight = \new -> do+            modifyIORef' heightBagRef $ heightBagAdd new+            recalculateMyHeight+        }+  forM_ (IntMap.toList initialParents) $ \(k, p) -> do+    (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k+    liftIO $ do+      forM_ parentOcc $ FastMutableIntMap.insert accum k+      FastMutableIntMap.insert parents k subscription+      height <- getEventSubscribedHeight parentSubd+      if height == invalidHeight+        then writeIORef heightRef invalidHeight+        else do+          modifyIORef' heightBagRef $ heightBagAdd height+          modifyIORef' heightRef $ \oldHeight ->+            if oldHeight == invalidHeight+            then invalidHeight+            else max (succHeight height) oldHeight+  myHeight <- liftIO $ readIORef heightRef+  currentHeight <- getCurrentHeight+  isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum+  occ <- if currentHeight >= myHeight -- If we should have fired by now+    then if isEmpty+         then return Nothing+         else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum+    else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet+            return Nothing+  defer $ SomeMergeInit $ do+    let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight+          where+            u = do+              let f k newParent = do+                    subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k+                    newParentHeight <- liftIO $ getEventSubscribedHeight subd+                    liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight+                    return subscription+              newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a+              oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions+              liftIO $ for_ oldParents $ \oldParent -> do+                oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent+                modifyIORef' heightBagRef $ heightBagRemove oldParentHeight+              return $ IntMap.elems oldParents+    let changeSubscriber = Subscriber+          { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do+              tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"+              defer $ updateMe a+          , subscriberInvalidateHeight = \_ -> return ()+          , subscriberRecalculateHeight = \_ -> return ()+          }+    (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber+    forM_ change $ \c -> defer $ updateMe c+    -- We explicitly hold on to the unsubscribe function from subscribing to the update event.+    -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain+    -- its subscription.+    liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)+  let unsubscribeAll = traverse_ (unsubscribe . snd) =<< FastMutableIntMap.toList parents+++  return (EventSubscription unsubscribeAll subscribed, occ)++newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }++fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v+fanG e = unsafePerformIO $ do+  ref <- newIORef Nothing+  let f = Fan+        { fanParent = e+        , fanSubscribed = ref+        }+  pure $ EventSelectorG $ \k -> eventFan k f++runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()+runHoldInits holdInitRef dynInitRef mergeInitRef = do+  holdInits <- liftIO $ readIORef holdInitRef+  dynInits <- liftIO $ readIORef dynInitRef+  mergeInits <- liftIO $ readIORef mergeInitRef+  unless (null holdInits && null dynInits && null mergeInits) $ do+    liftIO $ writeIORef holdInitRef []+    liftIO $ writeIORef dynInitRef []+    liftIO $ writeIORef mergeInitRef []+    mapM_ initHold holdInits+    mapM_ initDyn dynInits+    mapM_ unSomeMergeInit mergeInits+    runHoldInits holdInitRef dynInitRef mergeInitRef++initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h++initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()+initDyn (SomeDynInit d) = void $ getDynHold d++newEventEnv :: IO (EventEnv x)+newEventEnv = do+  toAssignRef <- newIORef [] -- This should only actually get used when events are firing+  holdInitRef <- newIORef []+  dynInitRef <- newIORef []+  mergeUpdateRef <- newIORef []+  mergeInitRef <- newIORef []+  heightRef <- newIORef zeroHeight+  toClearRef <- newIORef []+  toClearIntRef <- newIORef []+  toClearRootRef <- newIORef []+  coincidenceInfosRef <- newIORef []+  invalidatedCoincidencesRef <- newIORef []+  delayedRef <- newIORef IntMap.empty+  return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef invalidatedCoincidencesRef delayedRef++clearEventEnv :: EventEnv x -> IO ()+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef invalidatedCoincidencesRef delayedRef) = do+  writeIORef toAssignRef []+  writeIORef holdInitRef []+  writeIORef dynInitRef []+  writeIORef mergeUpdateRef []+  writeIORef mergeInitRef []+  writeIORef heightRef zeroHeight+  writeIORef toClearRef []+  writeIORef toClearIntRef []+  writeIORef toClearRootRef []+  writeIORef coincidenceInfosRef []+  writeIORef invalidatedCoincidencesRef []+  writeIORef delayedRef IntMap.empty++-- | Run an event action outside of a frame+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex+runFrame a = SpiderHost $ do+  let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)+  let go = do+        result <- a+        runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events+        return result+  result <- runEventM go+  toClear <- readIORef $ eventEnvClears env+  forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing+  toClearInt <- readIORef $ eventEnvIntClears env+  forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty+  toClearRoot <- readIORef $ eventEnvRootClears env+  forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty+  toAssign <- readIORef $ eventEnvAssignments env+  toReconnectRef <- newIORef []+  coincidenceInfos <- readIORef $ eventEnvResetCoincidences env+  forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do+    writeIORef vRef v+    traceInvalidate $ "Invalidating Hold"+    writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef+  mergeUpdates <- readIORef $ eventEnvMergeUpdates env+  writeIORef (eventEnvMergeUpdates env) []+  tracePropagate (Proxy::Proxy x) $ "Updating merges"+  mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates+  tracePropagate (Proxy::Proxy x) $ "Updating merges done"+  toReconnect <- readIORef toReconnectRef+  clearEventEnv env+  switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do+    oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed+    wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed+    traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed+    finalize wi+    i <- evaluate $ switchSubscribedOwnInvalidator subscribed+    wi' <- mkWeakPtrWithDebug i "wi'"+    writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'+    writeIORef (switchSubscribedBehaviorParents subscribed) []+    writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?+    e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env+    runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant+    --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times+    sub <- newSubscriberSwitch subscribed+    subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient+    {-+    stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)+    liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of+      EventRoot _ -> "EventRoot"+      EventNever -> "EventNever"+      _ -> "something else"+    -}+    writeIORef (switchSubscribedCurrentParent subscribed) $! subscription+    return oldSubscription+  liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill+  liftIO $ mapM_ unsubscribe switchSubscriptionsToKill+  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do+    EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed+    parentHeight <- getEventSubscribedHeight subd'+    myHeight <- readIORef $ switchSubscribedHeight subscribed+    when (parentHeight /= myHeight) $ do+      writeIORef (switchSubscribedHeight subscribed) $! invalidHeight+      WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight+  mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different+  forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mInvalidate) -> do+    unsubscribe subscription+    mapM_ invalidateCoincidenceHeight mInvalidate+  invalidatedCoincidences <- readIORef $ eventEnvInvalidatedCoincidences env+  writeIORef (eventEnvInvalidatedCoincidences env) []+  forM_ invalidatedCoincidences $ \(SomeCoincidenceSubscribed subscribed) -> recalculateCoincidenceHeight subscribed+  mapM_ _someMergeUpdate_recalculateHeight mergeUpdates+  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do+    height <- calculateSwitchHeight subscribed+    updateSwitchHeight height subscribed+  return result++newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)++{-# INLINE zeroHeight #-}+zeroHeight :: Height+zeroHeight = Height 0++{-# INLINE invalidHeight #-}+invalidHeight :: Height+invalidHeight = Height (-1000)++#ifdef DEBUG_CYCLES+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents+{-# INLINE invalidHeightBeingTraversed #-}+invalidHeightBeingTraversed :: Height+invalidHeightBeingTraversed = Height (-1001)+#endif++{-# INLINE succHeight #-}+succHeight :: Height -> Height+succHeight h@(Height a) =+  if h == invalidHeight+  then invalidHeight+  else Height $ succ a++invalidateCoincidenceHeight :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO ()+invalidateCoincidenceHeight subscribed = do+  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed+  when (oldHeight /= invalidHeight) $ do+    writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight+    let env = _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))+    modifyIORef' (eventEnvInvalidatedCoincidences env) (SomeCoincidenceSubscribed subscribed :)+    WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight++updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()+updateSwitchHeight new subscribed = do+  oldHeight <- readIORef $ switchSubscribedHeight subscribed+  when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion+    when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion+      writeIORef (switchSubscribedHeight subscribed) $! new+      WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new++recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()+recalculateCoincidenceHeight subscribed = do+  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed+  when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion+    height <- calculateCoincidenceHeight subscribed+    when (height /= invalidHeight) $ do+      writeIORef (coincidenceSubscribedHeight subscribed) $! height+      WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height++calculateSwitchHeight :: SwitchSubscribed x a -> IO Height+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)++calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height+calculateCoincidenceHeight subscribed = do+  outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed+  innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)+  return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight++data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)++invalidate :: IORef [SomeSwitchSubscribed x] -> InvalidatorList x -> IO (InvalidatorList x)+invalidate toReconnectRef (InvalidatorList _ _ wis) = do+  forM_ wis $ \wi -> do+    mi <- deRefWeak wi+    case mi of+      Nothing -> do+        traceInvalidate "invalidate Dead"+        return () --TODO: Should we clean this up here?+      Just i -> do+        finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict+        case i of+          InvalidatorPull p -> do+            traceInvalidate $ "invalidate: Pull" <> showNodeId p+            mVal <- readIORef $ pullValue p+            forM_ mVal $ \val -> do+              writeIORef (pullValue p) Nothing+              writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)+          InvalidatorSwitch subscribed -> do+            traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed+            modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)+  return emptyInvalidatorList -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them++--------------------------------------------------------------------------------+-- Reflex integration+--------------------------------------------------------------------------------++-- | Designates the default, global Spider timeline+data SpiderTimeline x+type role SpiderTimeline nominal++-- | The default, global Spider environment+type Spider = SpiderTimeline Global++instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where+  {-# INLINABLE sample #-}+  sample (SpiderBehavior b) = readBehaviorUntracked b++instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where+  {-# INLINABLE hold #-}+  hold = holdSpiderEventM+  {-# INLINABLE holdDyn #-}+  holdDyn = holdDynSpiderEventM+  {-# INLINABLE holdIncremental #-}+  holdIncremental = holdIncrementalSpiderEventM+  {-# INLINABLE buildDynamic #-}+  buildDynamic = buildDynamicSpiderEventM+  {-# INLINABLE headE #-}+  headE = R.slowHeadE+--  headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e+  {-# INLINABLE now #-}+  now = nowSpiderEventM++instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where+  {-# INLINABLE sample #-}+  sample = coerce . readBehaviorTracked . unSpiderBehavior++instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where+  {-# INLINABLE sample #-}+  sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b++instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where+  {-# INLINABLE hold #-}+  hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e+  {-# INLINABLE holdDyn #-}+  holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e+  {-# INLINABLE buildDynamic #-}+  buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e+  {-# INLINABLE headE #-}+  headE = R.slowHeadE+--  headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e+  {-# INLINABLE now #-}+  now = SpiderPushM nowSpiderEventM+++instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where+  {-# INLINE (>>=) #-}+  x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x+#if !MIN_VERSION_base(4,13,0)+  {-# INLINE fail #-}+  fail _ = error "Dynamic does not support 'fail'"+#endif++{-# INLINABLE newJoinDyn #-}+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)+newJoinDyn d =+  let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)+      eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d+      eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d+      eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d+      v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]+  in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'++instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where+  fmap = mapDynamicSpider+  x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d++mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b+mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic+{-# INLINE [1] mapDynamicSpider #-}++instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where+  pure = SpiderDynamic . dynamicConst+  liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)+  SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b+  a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]+  (<*) = flip (*>) -- There are no effects, so order doesn't matter++holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e++holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e++holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e++buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e++instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where+  {-# INLINABLE hold #-}+  hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e+  {-# INLINABLE holdDyn #-}+  holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e+  {-# INLINABLE buildDynamic #-}+  buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e+  {-# INLINABLE headE #-}+  headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e+  {-# INLINABLE now #-}+  now = runFrame . runSpiderHostFrame $ Reflex.Class.now+++instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where+  sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can++instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where+  {-# INLINABLE hold #-}+  hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e+  {-# INLINABLE holdDyn #-}+  holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e+  {-# INLINABLE buildDynamic #-}+  buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e+  {-# INLINABLE headE #-}+  headE = R.slowHeadE+--  headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e+  {-# INLINABLE now #-}+  now = SpiderHostFrame Reflex.Class.now++instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where+  {-# INLINABLE sample #-}+  sample = runFrame . readBehaviorUntracked . unSpiderBehavior++instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where+  {-# INLINABLE sample #-}+  sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample++instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where+  {-# INLINABLE hold #-}+  hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e+  {-# INLINABLE holdDyn #-}+  holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e+  {-# INLINABLE buildDynamic #-}+  buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e+  {-# INLINABLE headE #-}+  headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e+  {-# INLINABLE now #-}+  now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now++--------------------------------------------------------------------------------+-- Deprecated items+--------------------------------------------------------------------------------++-- | 'SpiderEnv' is the old name for 'SpiderTimeline'+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}+type SpiderEnv = SpiderTimeline+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where+  {-# INLINABLE subscribeEvent #-}+  subscribeEvent e = SpiderHostFrame $ do+    --TODO: Unsubscribe eventually (manually and/or with weak ref)+    val <- liftIO $ newIORef Nothing+    subscription <- subscribe (unSpiderEvent e) $ Subscriber+      { subscriberPropagate = \a -> do+          liftIO $ writeIORef val $ Just a+          scheduleClear val+      , subscriberInvalidateHeight = \_ -> return ()+      , subscriberRecalculateHeight = \_ -> return ()+      }+    return $ SpiderEventHandle+      { spiderEventHandleSubscription = subscription+      , spiderEventHandleValue = val+      }++instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where+  type EventTrigger (SpiderTimeline x) = RootTrigger x+  type EventHandle (SpiderTimeline x) = SpiderEventHandle x+  type HostFrame (SpiderTimeline x) = SpiderHostFrame x++instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where+  {-# NOINLINE readEvent #-}+  readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do+    result <- readIORef $ spiderEventHandleValue h+    touch h+    return result++instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where+  newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO+  newFanEventWithTrigger f = SpiderHost $ do+    es <- newFanEventWithTriggerIO f+    return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es++instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where+  newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO+  newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do+    es <- newFanEventWithTriggerIO f+    return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es++instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where+  {-# INLINABLE subscribeEvent #-}+  subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent++instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where+  type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x+  fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a+  runHostFrame = runFrame . runSpiderHostFrame++unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)+unsafeNewSpiderTimelineEnv = do+  lock <- newMVar ()+  env <- newEventEnv+#ifdef DEBUG+  depthRef <- newIORef 0+#endif+  return $ STE $ SpiderTimelineEnv+    { _spiderTimeline_lock = lock+    , _spiderTimeline_eventEnv = env+#ifdef DEBUG+    , _spiderTimeline_depth = depthRef+#endif+    }++-- | Create a new SpiderTimelineEnv+newSpiderTimeline :: IO (Some SpiderTimelineEnv)+newSpiderTimeline = withSpiderTimeline (pure . Some)++data LocalSpiderTimeline (x :: Type) s++instance Reifies s (SpiderTimelineEnv x) =>+         HasSpiderTimeline (LocalSpiderTimeline x s) where+  spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)++localSpiderTimeline+  :: proxy s+  -> SpiderTimelineEnv x+  -> SpiderTimelineEnv (LocalSpiderTimeline x s)+localSpiderTimeline _ = coerce++-- | Pass a new timeline to the given function.+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r+withSpiderTimeline k = do+  env <- unsafeNewSpiderTimelineEnv+  reify env $ \s -> k $ localSpiderTimeline s env++newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++type ComputeM = EventM++newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where+  {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}+  newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }+  newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }+  newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)+  newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }+  type PullM (SpiderTimeline x) = SpiderPullM x+  type PushM (SpiderTimeline x) = SpiderPushM x+  {-# INLINABLE never #-}+  never = SpiderEvent eventNever+  {-# INLINABLE constant #-}+  constant = SpiderBehavior . behaviorConst+  {-# INLINE push #-}+  push f = SpiderEvent . push (coerce f) . unSpiderEvent+  {-# INLINE pushCheap #-}+  pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent+  {-# INLINABLE pull #-}+  pull = SpiderBehavior . pull . coerce+  {-# INLINABLE fanG #-}+  fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))+  {-# INLINABLE mergeG #-}+  mergeG+    :: forall k2 (k :: k2 -> Type) q (v :: k2 -> Type). GCompare k+    => (forall a. q a -> R.Event (SpiderTimeline x) (v a))+    -> DMap k q+    -> R.Event (SpiderTimeline x) (DMap k v)+  mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst+  {-# INLINABLE switch #-}+  switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior+  {-# INLINABLE coincidence #-}+  coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent+  {-# INLINABLE current #-}+  current = SpiderBehavior . dynamicCurrent . unSpiderDynamic+  {-# INLINABLE updated #-}+  updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic+  {-# INLINABLE unsafeBuildDynamic #-}+  unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'+  {-# INLINABLE unsafeBuildIncremental #-}+  unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv+  {-# INLINABLE mergeIncrementalG #-}+  mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental+  {-# INLINABLE mergeIncrementalWithMoveG #-}+  mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental+  {-# INLINABLE currentIncremental #-}+  currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental+  {-# INLINABLE updatedIncremental #-}+  updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental+  {-# INLINABLE incrementalToDynamic #-}+  incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do+    c <- readBehaviorUntracked $ dynamicCurrent i+    return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'+  eventCoercion Coercion = Coercion+  behaviorCoercion Coercion = Coercion+  dynamicCoercion Coercion = Coercion+  incrementalCoercion Coercion Coercion = Coercion+  {-# INLINABLE mergeIntIncremental #-}+  mergeIntIncremental = SpiderEvent . mergeInt . coerce+  {-# INLINABLE fanInt #-}+  fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))++data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)++data SpiderEventHandle x a = SpiderEventHandle+  { spiderEventHandleSubscription :: EventSubscription x+  , spiderEventHandleValue :: IORef (Maybe a)+  }++instance MonadRef (EventM x) where+  type Ref (EventM x) = Ref IO+  {-# INLINABLE newRef #-}+  {-# INLINABLE readRef #-}+  {-# INLINABLE writeRef #-}+  newRef = liftIO . newRef+  readRef = liftIO . readRef+  writeRef r a = liftIO $ writeRef r a++instance MonadAtomicRef (EventM x) where+  {-# INLINABLE atomicModifyRef #-}+  atomicModifyRef r f = liftIO $ atomicModifyRef r f++-- | The monad for actions that manipulate a Spider timeline identified by @x@+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a }+  deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)++instance Monad (SpiderHost x) where+  {-# INLINABLE (>>=) #-}+  SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f+#if !MIN_VERSION_base(4,13,0)+  {-# INLINABLE fail #-}+  fail = MonadFail.fail+#endif++instance MonadFail (SpiderHost x) where+  {-# INLINABLE fail #-}+  fail s = SpiderHost $ MonadFail.fail s++-- | Run an action affecting the global Spider timeline; this will be guarded by+-- a mutex for that timeline+runSpiderHost :: SpiderHost Global a -> IO a+runSpiderHost (SpiderHost a) = a++-- | Run an action affecting a given Spider timeline; this will be guarded by a+-- mutex for that timeline+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a+runSpiderHostForTimeline (SpiderHost a) _ = a++newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }+  deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadMask, MonadThrow, MonadCatch)++instance Monad (SpiderHostFrame x) where+  {-# INLINABLE (>>=) #-}+  SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f+#if !MIN_VERSION_base(4,13,0)+  {-# INLINABLE fail #-}+  fail s = SpiderHostFrame $ fail s+#endif++instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where+  notReadyUntil _ = pure ()+  notReady = pure ()++newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)+newEventWithTriggerIO f = do+  es <- newFanEventWithTriggerIO $ \Refl -> f+  return $ select es Refl++newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)+newFanEventWithTriggerIO f = do+  occRef <- newIORef DMap.empty+  subscribedRef <- newIORef DMap.empty+  let !r = Root+        { rootOccurrence = occRef+        , rootSubscribed = subscribedRef+        , rootInit = f+        }+  return $ EventSelector $ \k -> eventRoot k r++newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)++instance MonadRef (SpiderHost x) where+  type Ref (SpiderHost x) = Ref IO+  newRef = SpiderHost . newRef+  readRef = SpiderHost . readRef+  writeRef r = SpiderHost . writeRef r++instance MonadAtomicRef (SpiderHost x) where+  atomicModifyRef r = SpiderHost . atomicModifyRef r++instance MonadRef (SpiderHostFrame x) where+  type Ref (SpiderHostFrame x) = Ref IO+  newRef = SpiderHostFrame . newRef+  readRef = SpiderHostFrame . readRef+  writeRef r = SpiderHostFrame . writeRef r++instance MonadAtomicRef (SpiderHostFrame x) where+  atomicModifyRef r = SpiderHostFrame . atomicModifyRef r++instance PrimMonad (SpiderHostFrame x) where+  type PrimState (SpiderHostFrame x) = PrimState IO+  primitive = SpiderHostFrame . EventM . primitive++instance NotReady (SpiderTimeline x) (SpiderHost x) where+  notReadyUntil _ = return ()+  notReady = return ()++instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where+  notReadyUntil _ = return ()+  notReady = return ()
+ src/Reflex/Time.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module:+--   Reflex.Time+-- Description:+--   Clocks, timers, and other time-related functions.+module Reflex.Time where++import Control.Concurrent+import qualified Control.Concurrent.Thread.Delay as Concurrent+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class+import Data.Align+import Data.Data (Data)+import Data.Fixed+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import Data.These+import Data.Time.Clock+import GHC.Generics (Generic)+import System.Random++#if !MIN_VERSION_base(4,18,0)+import Data.Semigroup (Semigroup(..))+#endif++import Reflex.Class+import Reflex.Dynamic+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.TriggerEvent.Class++-- | Metadata associated with a timer "tick"+data TickInfo+  = TickInfo { _tickInfo_lastUTC :: UTCTime+             -- ^ UTC time immediately after the last tick.+             , _tickInfo_n :: Integer+             -- ^ Number of time periods or ticks since the start of the timer+             , _tickInfo_alreadyElapsed :: NominalDiffTime+             -- ^ Amount of time that has elapsed in the current tick period.+             }+  deriving (Eq, Ord, Show)++-- | Fires an 'Event' once every time provided interval elapses, approximately.+-- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick.+-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread.+tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)+tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild++-- | Fires an 'Event' once every time provided interval elapses, approximately.+-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread and the time of the post-build as the tick basis time.+tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)+tickLossyFromPostBuildTime dt = do+  postBuild <- getPostBuild+  postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild+  tickLossyFrom' $ (dt,) <$> postBuildTime++-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered.+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time.+tickLossyFrom+    :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)+    => NominalDiffTime+    -- ^ The length of a tick interval+    -> UTCTime+    -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made.+    -> Event t a+    -- ^ Event that starts a tick generation thread.  Usually you want this to+    -- be something like the result of getPostBuild that only fires once.  But+    -- there could be uses for starting multiple timer threads.+    -> m (Event t TickInfo)+tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e++-- | Generalization of tickLossyFrom that takes the delay and initial time as an 'Event'.+tickLossyFrom'+    :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)+    => Event t (NominalDiffTime, UTCTime)+    -- ^ Event that starts a tick generation thread.  Usually you want this to+    -- be something like the result of 'getPostBuild' that only fires once.  But+    -- there could be uses for starting multiple timer threads.+    -> m (Event t TickInfo)+tickLossyFrom' e = do+  rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]+  return $ fst <$> result+  where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do+          tick <- uncurry getCurrentTick pair+          Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000+          cb (tick, pair)++-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire.+clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)+clockLossy dt t0 = do+  initial <- liftIO $ getCurrentTick dt t0+  e <- tickLossy dt t0+  holdDyn initial e++-- | Generates a 'TickInfo', given the specified interval and timestamp. The 'TickInfo' will include the+-- current time, the number of ticks that have elapsed since the timestamp, and the amount of time that+-- has elapsed since the start time of this tick.+getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo+getCurrentTick dt t0 = do+  t <- getCurrentTime+  let offset = t `diffUTCTime` t0+      (n, alreadyElapsed) = offset `divMod'` dt+  return $ TickInfo t n alreadyElapsed++-- | Delay an Event's occurrences by a given amount in seconds.+delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)+delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do+  Concurrent.delay $ ceiling $ dt * 1000000+  cb a++-- | Send events with Poisson timing with the given basis and rate+--   Each occurrence of the resulting event will contain the index of+--   the current interval, with 0 representing the basis time+poissonLossyFrom+  :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)+  => g+  -> Double+  -- ^ Poisson event rate (Hz)+  -> UTCTime+  -- ^ Baseline time for events+  -> Event t a+  -- ^ Event that starts a tick generation thread. Usually you want this to+  -- be something like the result of getPostBuild that only fires once. But+  -- there could be uses for starting multiple timer threads.+  -- Start sending events in response to the event parameter.+  -> m (Event t TickInfo)+poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate+++-- | Send events with Poisson timing with the given basis and rate+--   Each occurrence of the resulting event will contain the index of+--   the current interval, with 0 representing the basis time.+--   Automatically begin sending events when the DOM is built+poissonLossy+  :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)+  => g+  -> Double+  -- ^ Poisson event rate (Hz)+  -> UTCTime+  -- ^ Baseline time for events+  -> m (Event t TickInfo)+poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild++-- | Send events with inhomogeneous Poisson timing with the given basis+--   and variable rate. Provide a maxRate that you expect to support.+inhomogeneousPoissonFrom+  :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)+  => g+  -> Behavior t Double+  -> Double+  -> UTCTime+  -> Event t a+  -> m (Event t TickInfo)+inhomogeneousPoissonFrom rnd rate maxRate t0 e = do++  -- Create a thread for producing homogeneous poisson events+  -- along with random Doubles (usage of Double's explained below)+  ticksWithRateRand <- performEventAsync $+                       fmap callAtNextInterval e++  -- Filter homogeneous events according to associated+  -- random values and the current rate parameter+  return $ attachWithMaybe filterFun rate ticksWithRateRand++  where++    -- Inhomogeneous poisson processes are built from faster+    -- homogeneous ones by randomly dropping events from the+    -- fast process. For each fast homogeneous event, choose+    -- a uniform random sample from (0, rMax). If the+    -- inhomogeneous rate at this moment is greater than the+    -- random sample, then keep this event, otherwise drop it+    filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo+    filterFun r (tInfo, p)+      | r >= p    = Just tInfo+      | otherwise = Nothing++    callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0++    go tTargetLast lastGen cb lastN = do+      t <- getCurrentTime++      -- Generate random numbers for this poisson interval (u)+      -- and sample-retention likelihood (p)+      let (u, nextGen)            = randomR (0,1) lastGen+          (p :: Double, nextGen') = randomR (0,maxRate) nextGen++      -- Inter-event interval is drawn from exponential+      -- distribution accourding to u+      let dt             = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime+          nEvents        = lastN + 1+          alreadyElapsed = diffUTCTime t tTargetLast+          tTarget        = addUTCTime dt tTargetLast+          thisDelay      = realToFrac $ diffUTCTime tTarget t :: Double+      Concurrent.delay $ ceiling $ thisDelay * 1000000+      _ <- cb (TickInfo t nEvents alreadyElapsed, p)+      go tTarget nextGen' cb nEvents++-- | Send events with inhomogeneous Poisson timing with the given basis+--   and variable rate. Provide a maxRate that you expect to support+inhomogeneousPoisson+  :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)+  => g+  -> Behavior t Double+  -> Double+  -> UTCTime+  -> m (Event t TickInfo)+inhomogeneousPoisson rnd rate maxRate t0 =+  inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild++-- | Block occurrences of an Event until the given number of seconds elapses without+--   the Event firing, at which point the last occurrence of the Event will fire.+debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)+debounce dt e = do+  n :: Dynamic t Integer <- count e+  let tagged = attachPromptlyDynWith (,) n e+  delayed <- delay dt tagged+  return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed++-- | When the given 'Event' occurs, wait the given amount of time and collect+-- all occurrences during that time.  Then, fire the output 'Event' with the+-- collected output.+batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))+batchOccurrences t newValues = do+  let f s x = (Just newState, out)+        where newState = case x of+                This a -> s |> a+                That _ -> mempty+                These a _ -> Seq.singleton a+              out = case x of+                This _ -> if Seq.null s then Just () else Nothing+                That _ -> Nothing+                These _ _ -> Just ()+  rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed+      delayed <- delay t toDelay+  return $ tag buffer delayed++-- | Throttle an input event, ensuring that at least a given amount of time passes between occurrences of the output event. If the input event occurs too+-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.+throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)+throttle t e = do+  let f (immediate, buffer) x = case x of -- (Just newState, out)+        This a -- If only the input event fires+          | immediate -> -- and we're in immediate mode+            -- Immediate mode turns off, and the buffer is empty.+            -- We fire the output event with the input event value immediately.+            (Just (False, Nothing), Just a)+          | otherwise -> -- and we're not in immediate mode+            -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.+            -- We don't fire the output event.+            (Just (False, Just a), Nothing)+        That _ -> -- If only the delayed output event fires,+          case buffer of+            Nothing -> -- and the buffer is empty:+              -- Immediate mode turns back on, and the buffer remains empty.+              -- We don't fire.+              (Just (True, Nothing), Nothing)+            Just b -> -- and the buffer is full:+              -- Immediate mode remains off, and the buffer is cleared.+              -- We fire with the buffered value.+              (Just (False, Nothing), Just b)+        These a _ -> -- If both the input and delayed output event fire simultaneously:+          -- Immediate mode turns off, and the buffer is empty.+          -- We fire with the input event's value, as it is the most recent we have seen at this moment.+          (Just (False, Nothing), Just a)+  rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.+      delayed <- delay t outE+  return outE++data ThrottleState b+  = ThrottleState_Immediate+  | ThrottleState_Buffered (ThrottleBuffer b)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data)++data ThrottleBuffer b+  = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning+                         -- on PatternSynonyms+  | ThrottleBuffer_Full b+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data)++instance Semigroup b => Semigroup (ThrottleBuffer b) where+  x <> y = case x of+    ThrottleBuffer_Empty -> y+    ThrottleBuffer_Full b1 -> case y of+      ThrottleBuffer_Empty -> x+      ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2+  {-# INLINE (<>) #-}++instance Semigroup b => Monoid (ThrottleBuffer b) where+  mempty = ThrottleBuffer_Empty+  {-# INLINE mempty #-}+  mappend = (<>)+  {-# INLINE mappend #-}++-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too+-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.+-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is+-- ready for more input.  For example, using @delay 20@ would give a simple time-based throttle.+--+-- NB: The provided lag function must *actually* delay the event.+throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)+-- Invariants:+-- * Immediate mode must turn off whenever output is produced.+-- * Output must be produced whenever immediate mode turns from on to off.+-- * Immediate mode can only go from off to on when the delayed event fires.+-- * Every input firing must go into either an immediate output firing or the+--   buffer, but not both.+-- * An existing full buffer must either stay in the buffer or go to output,+--   but not both.+throttleBatchWithLag lag e = do+  let f state x = case x of -- (Just $ newState, out)+        This a -> -- If only the input event fires+          case state of+            ThrottleState_Immediate -> -- and we're in immediate mode+              -- Immediate mode turns off, and the buffer is empty.+              -- We fire the output event with the input event value immediately.+              (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a)+            ThrottleState_Buffered b -> -- and we're not in immediate mode+              -- Immediate mode remains off, and we accumulate the input value.+              -- We don't fire the output event.+              (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing)+        That _ -> -- If only the delayed output event fires,+          case state of+            ThrottleState_Immediate -> -- and we're in immediate mode+              -- Nothing happens.+              (Nothing, Nothing)+            ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:+              -- Immediate mode turns back on, and the buffer remains empty.+              -- We don't fire.+              (Just ThrottleState_Immediate, Nothing)+            ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:+              -- Immediate mode remains off, and the buffer is cleared.+              -- We fire with the buffered value.+              (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b)+        These a _ -> -- If both the input and delayed output event fire simultaneously:+          case state of+            ThrottleState_Immediate -> -- and we're in immediate mode+              -- Immediate mode turns off, and the buffer is empty.+              -- We fire with the input event's value, as it is the most recent we have seen at this moment.+              (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)+            ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:+              -- Immediate mode stays off, and the buffer remains empty.+              -- We fire with the input event's value.+              (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)+            ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:+              -- Immediate mode remains off, and the buffer is cleared.+              -- We fire with everything including the buffered value.+              (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a))+  rec (_stateDyn, outE) <- mapAccumMaybeDyn f+        ThrottleState_Immediate -- We start in immediate mode with an empty buffer.+        (align e delayed)+      delayed <- lag (void outE)+  return outE++tickInfo_lastUTC :: Functor f => (UTCTime -> f UTCTime) -> TickInfo -> f TickInfo+tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1+{-# INLINE tickInfo_lastUTC #-}++tickInfo_n :: Functor f => (Integer  -> f Integer ) -> TickInfo -> f TickInfo+tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2+{-# INLINE tickInfo_n #-}++tickInfo_alreadyElapsed :: Functor f => (NominalDiffTime -> f NominalDiffTime) -> TickInfo -> f TickInfo+tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = TickInfo x1 x2 <$> f x3+{-# INLINE tickInfo_alreadyElapsed #-}
+ src/Reflex/TriggerEvent/Base.hs view
@@ -0,0 +1,159 @@+-- | This module defines 'TriggerEventT', the standard implementation of+-- 'TriggerEvent'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Reflex.TriggerEvent.Base+  ( TriggerEventT (..)+  , runTriggerEventT+  , askEvents+  , TriggerInvocation (..)+  , EventTriggerRef (..)+  ) where++import Control.Concurrent+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Data.Coerce+import Data.Dependent.Sum+import Data.IORef+import qualified Data.Semigroup as S++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.TriggerEvent.Class++-- | A value with which to fire an 'Event', as well as a callback to invoke+-- after its propagation has completed.+data TriggerInvocation a = TriggerInvocation a (IO ())++-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }++-- | A basic implementation of 'TriggerEvent'.+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadCatch, MonadThrow, MonadMask)++-- | Run a 'TriggerEventT' action.  The argument should be a 'Chan' into which+-- 'TriggerInvocation's can be passed; it is expected that some other thread+-- will be responsible for popping values out of the 'Chan' and firing their+-- 'EventTrigger's.+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a+runTriggerEventT = runReaderT . unTriggerEventT++instance MonadTrans (TriggerEventT t) where+  {-# INLINABLE lift #-}+  lift = TriggerEventT . lift++instance PrimMonad m => PrimMonad (TriggerEventT t m) where+  type PrimState (TriggerEventT t m) = PrimState m+  {-# INLINABLE primitive #-}+  primitive = lift . primitive++instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where+  type Performable (TriggerEventT t m) = Performable m+  {-# INLINABLE performEvent_ #-}+  performEvent_ e = lift $ performEvent_ e+  {-# INLINABLE performEvent #-}+  performEvent e = lift $ performEvent e++instance PostBuild t m => PostBuild t (TriggerEventT t m) where+  {-# INLINABLE getPostBuild #-}+  getPostBuild = lift getPostBuild++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where+  {-# INLINABLE newEventWithTrigger #-}+  newEventWithTrigger = lift . newEventWithTrigger+  {-# INLINABLE newFanEventWithTrigger #-}+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where+  {-# INLINABLE newTriggerEvent #-}+  newTriggerEvent = do+    (e, t) <- newTriggerEventWithOnComplete+    return (e, \a -> t a $ return ())+  {-# INLINABLE newTriggerEventWithOnComplete #-}+  newTriggerEventWithOnComplete = do+    events <- askEvents+    (eResult, reResultTrigger) <- lift newEventWithTriggerRef+    return . (,) eResult $ \a cb ->+      writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]+  {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}+  newEventWithLazyTriggerWithOnComplete f = do+    events <- askEvents+    lift . newEventWithTrigger $ \t ->+      f $ \a cb -> do+        reResultTrigger <- newRef $ Just t+        writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]++instance MonadRef m => MonadRef (TriggerEventT t m) where+  type Ref (TriggerEventT t m) = Ref m+  {-# INLINABLE newRef #-}+  newRef = lift . newRef+  {-# INLINABLE readRef #-}+  readRef = lift . readRef+  {-# INLINABLE writeRef #-}+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where+  {-# INLINABLE atomicModifyRef #-}+  atomicModifyRef r = lift . atomicModifyRef r++instance MonadSample t m => MonadSample t (TriggerEventT t m) where+  {-# INLINABLE sample #-}+  sample = lift . sample++instance MonadHold t m => MonadHold t (TriggerEventT t m) where+  {-# INLINABLE hold #-}+  hold v0 v' = lift $ hold v0 v'+  {-# INLINABLE holdDyn #-}+  holdDyn v0 v' = lift $ holdDyn v0 v'+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 v' = lift $ holdIncremental v0 v'+  {-# INLINABLE buildDynamic #-}+  buildDynamic a0 = lift . buildDynamic a0+  {-# INLINABLE headE #-}+  headE = lift . headE+  {-# INLINABLE now #-}+  now = lift now++instance Adjustable t m => Adjustable t (TriggerEventT t m) where+  {-# INLINABLE runWithReplace #-}+  runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')+  {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}+  traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'+  {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'++-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.+instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where+  mempty = pure mempty+  mappend = (<>)++instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where+  (<>) = liftA2 (S.<>)+++-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will+-- be fired.+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])+askEvents = TriggerEventT ask
+ src/Reflex/TriggerEvent/Class.hs view
@@ -0,0 +1,56 @@+-- | This module defines 'TriggerEvent', which describes actions that may create+-- new 'Event's that can be triggered from 'IO'.+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.TriggerEvent.Class+  ( TriggerEvent (..)+  ) where++import Reflex.Class++import Control.Monad.Reader+import Control.Monad.State+import qualified Control.Monad.State.Strict as Strict+import Control.Monad.Trans.Maybe (MaybeT)++--TODO: Shouldn't have IO hard-coded+-- | 'TriggerEvent' represents actions that can create 'Event's that can be+-- triggered by 'IO' actions.+class Monad m => TriggerEvent t m | m -> t where+  -- | Create a triggerable 'Event'.  Whenever the resulting function is called,+  -- the resulting 'Event' will fire at some point in the future.  Note that+  -- this may not be synchronous.+  newTriggerEvent :: m (Event t a, a -> IO ())+  -- | Like 'newTriggerEvent', but the callback itself takes another callback,+  -- to be invoked once the requested 'Event' occurrence has finished firing.+  -- This allows synchronous operation.+  newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow+  -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown.  This+  -- relatively complex type signature allows any external listeners to be+  -- subscribed lazily and then removed whenever the returned 'Event' is no+  -- longer being listened to.  Note that the setup/teardown may happen multiple+  -- times, and there is no guarantee that the teardown will be executed+  -- promptly, or even at all, in the case of program termination.+  newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)++instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance TriggerEvent t m => TriggerEvent t (StateT s m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete++instance TriggerEvent t m => TriggerEvent t (MaybeT m) where+  newTriggerEvent = lift newTriggerEvent+  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete+  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
+ src/Reflex/Widget/Basic.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo #-}++module Reflex.Widget.Basic where++import Control.Monad.Fix (MonadFix)+import Data.Map (Map)++import Reflex.Class+import Reflex.Adjustable.Class+import Data.Patch.MapWithMove+++-- | Build sortable content in such a way that re-sorting it can cause minimal+-- disruption to an existing context.+--+-- Naively re-sorting a list of images would destroy every image and add them back+-- in the new order. This framework is able to avoid that by preserving the+-- identity of each image and simply moving it to the new location.+--+-- Example:+--+-- > let sortByFst = buttonA $> comparing fst+-- >     sortBySnd = buttonB $> comparing snd+-- >     sortEvent = leftmost [sortByFst, sortBySnd]+-- > sortableList+-- >   (\k v -> text $ "\n" ++ show k ++ " " ++ v)  -- show each element on a new line+-- >   (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")])+-- >   sortEvent+sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k)+             => (k -> v -> m a) -- ^ Function to render the content for each key/value pair+             -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order+             -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list+             -> m (Map k a)+sortableList f m0 reSortFunc = do+  rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc+      m <- holdIncremental m0 reSortPatch+  (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch+  pure results
+ src/Reflex/Workflow.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module:+--   Reflex.Workflow+-- Description:+--   Provides a convenient way to describe a series of interrelated widgets that+--   can send data to, invoke, and replace one another. Useful for modeling user interface+--   "workflows."+module Reflex.Workflow+  ( Workflow (..)+  , workflow+  , workflowView+  , mapWorkflow+  , mapWorkflowCheap+  ) where++import Control.Arrow ((***))+import Control.Monad.Fix (MonadFix)++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Network+import Reflex.NotReady.Class+import Reflex.PostBuild.Class++-- | A widget in a workflow+--+-- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type.+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }++-- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another).+workflow :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)+workflow w0 = do+  rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult+  return $ fmap fst eResult++-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.+workflowView :: forall t m a. (NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)+workflowView w0 = do+  rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace+      eReplace <- fmap switch $ hold never $ fmap snd eResult+  return $ fmap fst eResult++-- | Map a function over a 'Workflow', possibly changing the return type.+mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)++-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.+mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b+mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
+ test/Adjustable.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}++module Main where++import Control.Monad.Fix+import Data.Maybe+import qualified Data.Map as Map++import Reflex+import Reflex.EventWriter.Base+import Reflex.Network+import Reflex.Patch.MapWithMove+import Test.Run++main :: IO ()+main = do+  let actions =  [ Increment, Update0th, Increment, Swap, Increment, Increment ]+  os <- runAppB testPatchMapWithMove $ map Just actions+  -- If the final counter value in the adjusted widgets corresponds to the number of times it has+  -- been incremented, we know that the networks haven't broken.+  let expectedCount = length $ ffilter (== Increment) actions+  -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved+  return ()++data PatchMapTestAction+  = Increment+  | Swap+  | Update0th+  deriving Eq++-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.+testPatchMapWithMove+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     )+  => Event t PatchMapTestAction+  -> m (Behavior t [Int])+testPatchMapWithMove pulse = do+  let pulseAction = ffor pulse $ \case+        Increment -> Nothing+        Swap -> patchMapWithMove $ Map.fromList+          [ (0, NodeInfo (From_Move 1) (Just 1))+          , (1, NodeInfo (From_Move 0) (Just 0))+          ]+        Update0th -> patchMapWithMove $ Map.fromList+          [ (0, NodeInfo (From_Insert 'z') Nothing) ]+  (_, result) <- runBehaviorWriterT $ mdo+    counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction+    _ <- mapMapWithAdjustWithMove+      (\_ _ -> networkHold+        (tellBehavior $ constant [])+        ((\t -> tellBehavior $ constant [t]) <$> updated counter))+      (Map.fromList $ zip [0..] "ab")+      (fmapMaybe id pulseAction)+    return ()+  return result
+ test/DebugCycles.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import Data.Foldable+import Control.Lens+import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Exception+import System.Timeout+import Data.Maybe (isJust)+import Data.Functor.Misc+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.These+import Data.Align+import Reflex+import Reflex.EventWriter.Base+import Test.Run+import Test.Hspec+import Reflex.Spider.Internal (EventLoopException)+import Witherable (Filterable)++#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))+import Data.These.Lens+#endif++type Widget t m = (MonadHold t m, Reflex t, MonadFix m)++connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)+connectDyn e (d, d') = do+  dd <- holdDyn d (d' <$ e)+  return $ join dd++dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+dynLoop (e1, e2) = do+  -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"+  rec+    d <- count e1+    d' <- connectDyn e2 (d, liftA2 (+) d d')+  return $ updated d'++connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectOnCoincidence click e = do+  d <- holdDyn never (e <$ click)+  return $ coincidence (updated d)++coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+coincidenceLoop (e1, e2) = do+-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"+-- (simpler version of dynLoop)+  rec+    e' <- connectOnCoincidence e2 (updated d)+    d <- count (align e' e1)+  return $ updated d++addHeight :: Reflex t =>  Event t a -> Event t a+addHeight e = leftmost [e4, e4] where+  e1 = leftmost [e, e]+  e2 = leftmost [e1, e1]+  e3 = leftmost [e2, e2]+  e4 = leftmost [e3, e3]++-- Take an existing test and build it inside a+buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)+buildLoop test (e1, e2) = switchHold never buildLoop+  where buildLoop = pushAlways (const $ test (e1, e2)) e2++connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectButtonPromptly click e = do+  d <- holdDyn never (e <$ click)+  return (switchDyn d)++connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectButton click e = do+  d <- hold never (e <$ click)+  return (switch d)++switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop01 (e1, e2) = do+  rec+    e' <- connectButton e2 (updated d)+    d <- count (align e' e1)+  return $ updated d++mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)+mergeLoop (e1, e2) = do+  rec+    (_, e) <- runEventWriterT $+      runWithReplace w (leftmost [w <$ e1])+  return (sum <$> e)+  where+    w = do+      c <- count e1+      tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))++switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop02 (e1, e2) = do+  rec+    e' <- connectButton e2 (updated d)+    d <- count (leftmost [e', e1])+  return $ updated d++switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop03 (e1, e2) = do+  rec+    e' <- connectButton e2 (addHeight $ updated d)+    d <- count (align e' e1)+  return $ updated d++staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+staticLoop01 (e1, e2) = do+  rec+    d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))+  return $ updated d++staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+staticLoop02 (e1, e2) = do+  rec+    d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])+  return $ updated d++buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+buildStaticLoop (e1, e2) = switchHold never buildLoop+  where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2++splitThese :: Filterable f => f (These a b) -> (f a, f b)+splitThese f = (mapMaybe (preview here) f,  mapMaybe (preview there) f)++main :: IO ()+main = hspec $ do+  describe "DebugCycles" $ do+    it "throws EventLoopException on switchLoop01" $ do+      check switchLoop01+    it "throws EventLoopException on switchLoop02" $ do+      check switchLoop02+    it "throws EventLoopException on switchLoop03" $ do+      check switchLoop03+    it "throws EventLoopException on buildSwitchLoop" $ do+      check $ buildLoop switchLoop01+    xit "throws EventLoopException on mergeLoop" $ do+      check mergeLoop+    xit "throws EventLoopException on staticLoop01" $ do+      check staticLoop01+    xit "throws EventLoopException on staticLoop02" $ do+      check staticLoop02+    xit "throws EventLoopException on buildStaticLoop" $ do+      check buildStaticLoop+    xit "throws EventLoopException on coincidenceLoop" $ do+      check coincidenceLoop+    xit "throws EventLoopException on dynLoop" $ do+      check dynLoop+    xit "throws EventLoopException on buildCoincidenceLoop" $ do+      check $ buildLoop coincidenceLoop+ where+   milliseconds = (*1000)+   occs = [  This 1, This 2, That (), This 3, That (), This 1 ]+   check test = do+     let action = timeout (milliseconds 50) $ do+                    runApp' (test . splitThese) (Just <$> occs)+     action `shouldThrow` (const True :: Selector EventLoopException)
+ test/EventWriterT.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Lens+import Control.Monad+import Control.Monad.Fix+import qualified Data.Dependent.Map as DMap+import Data.Functor.Misc+import qualified Data.Map as M+import Data.These++#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))+import Data.These.Lens+#endif++import Reflex+import Reflex.EventWriter.Base+import Test.Run++main :: IO ()+main = do+  os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $+    [ Just ()+    ]+  print os1+  os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]+    <- runApp' (unwrapApp testSimultaneous) $ map Just $+         [ This ()+         , That ()+         , This ()+         , These () ()+         ]+  print os2+  os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]+  print os3+  os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]+  print os4+  os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]+  print os5+  os6 <- runApp' (unwrapApp delayedPulse) [Just ()]+  print os6+  let ![[Nothing, Nothing]] = os6+  return ()++unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])+unwrapApp x appIn = do+  ((), e) <- runEventWriterT $ x appIn+  return e++testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()+testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)++testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()+testSimultaneous pulse = do+  let e0 = fmapMaybe (^? here) pulse+      e1 = fmapMaybe (^? there) pulse+  forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)++-- | Test that a widget telling and event which fires at the same time it has been replaced+-- doesn't count along with the new widget.+testMoribundTellEvent+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     )+  => Event t ()+  -> EventWriterT t [Int] m ()+testMoribundTellEvent pulse = do+  rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()+          tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished+      (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse+  return ()++-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.+testMoribundTellEventDMap+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     )+  => Event t ()+  -> EventWriterT t [Int] m ()+testMoribundTellEventDMap pulse = do+  rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()+          tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished+      (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-+        traverseDMapWithKeyWithAdjust+          (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)+          (mapToDMap $ M.singleton () 1)+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)+  return ()++-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's+-- during the same frame as other elements are updated.+testLiveTellEventDMap+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     )+  => Event t ()+  -> EventWriterT t [Int] m ()+testLiveTellEventDMap pulse = do+  rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()+          tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished+      (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-+        traverseDMapWithKeyWithAdjust+          (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)+          (mapToDMap $ M.singleton 1 ())+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)+  return ()++delayedPulse+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     )+  => Event t ()+  -> EventWriterT t [Int] m ()+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do+    -- This has the effect of delaying pulse' from pulse+    (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse+    tellEvent pulse'
+ test/GC.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Ref+import Data.Align+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum+import Data.Functor.Identity+import Data.GADT.Compare+import Data.IORef+import Data.Semigroup+import Data.These+import Data.Type.Equality ((:~:)(Refl))++import Data.Functor.Misc+import Data.Patch++import qualified Reflex.Host.Class as Host+import qualified Reflex.Spider.Internal as S++import System.Exit+import System.Mem+import Data.Coerce++main :: IO ()+main = do+  ref <- newIORef Nothing+  hostPerf ref+  readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)++hostPerf :: IORef (Maybe Int) -> IO ()+hostPerf ref = S.runSpiderHost $ do+  ---- body+  liftIO $ putStrLn "#creating triggers"+  (response', responseTrigger) <- Host.newEventWithTriggerRef+  (eadd', addTriggerRef) <- Host.newEventWithTriggerRef+  let response = S.unSpiderEvent response'+      eadd = S.unSpiderEvent eadd'+  liftIO $ putStrLn "#creating event graph"+  eventToPerform <- Host.runHostFrame $ do+    (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))+      <- S.SpiderHostFrame+       $ fmap ( S.mergeG coerce+              . S.dynamicHold)+       $ S.hold DMap.empty+       -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained+       $ (\e -> S.Event $ \sub -> do+            (s, o) <- S.subscribeAndRead e $ sub+               { S.subscriberPropagate = S.subscriberPropagate sub+               }+            return (s, o))+       $ runIdentity . runIdentity <$> S.selectG+          (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)+          (WrapArg Request)+    return $ alignWith (mergeThese (<>))+      (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do+        liftIO $ putStrLn "#eadd fired"+        return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just+               $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)+      (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)+  ---- epilogue+  eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)+  liftIO $ putStrLn "#performing GC" >> performMajorGC+  liftIO $ putStrLn "#attempting to fire eadd"+  mAddTrigger <- readRef addTriggerRef+  forM_ mAddTrigger $ \t -> replicateM_ 2 $ do+    liftIO $ putStrLn "#firing eadd"+    mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle+    case mToPerform of+      Nothing -> return ()+      Just toPerform -> do+        responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform+        mrt <- readRef responseTrigger+        let followupEventTriggers = case mrt of+              Just rt -> [rt :=> Identity responses]+              Nothing -> []+        Host.fireEventsAndRead followupEventTriggers $ return ()+        return ()++data Tell a where+  Action :: Tell ()+  Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))++instance GEq Tell where+  geq Action Action = Just Refl+  geq Request Request = Just Refl+  geq _ _ = Nothing++instance GCompare Tell where+  gcompare Action Action = GEQ+  gcompare Request Request = GEQ+  gcompare Action Request = GLT+  gcompare Request Action = GGT
+ test/Headless.hs view
@@ -0,0 +1,10 @@+module Main where++import Reflex+import Reflex.Host.Headless (runHeadlessApp)++main :: IO ()+main = do+  runHeadlessApp $ do+    pb <- getPostBuild+    performEvent (pure <$> pb)
+ test/QueryT.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++import Control.Lens+import Control.Monad.Fix+import Data.Align+import qualified Data.AppendMap as AMap+import Data.Functor.Misc+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Map.Monoidal (MonoidalMap)+import Data.Semigroup+import Data.Semigroup.Commutative+import Data.These++#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))+import Data.These.Lens+#endif++import Reflex+import Data.Patch.MapWithMove+import Test.Run++newtype MyQuery = MyQuery SelectedCount+  deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Commutative, Group)++instance Query MyQuery where+  type QueryResult MyQuery = ()+  crop _ _ = ()++instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where+  type QueryResult (Selector k a) = Selector k (QueryResult a)+  crop q r = undefined++newtype Selector k a = Selector { unSelector :: MonoidalMap k a }+  deriving (Show, Read, Eq, Ord, Functor)++#if !(MIN_VERSION_monoidal_containers(0,4,1))+deriving instance Ord k => Align (MonoidalMap k)+#endif++instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where+  (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b+    where+      f = alignWith $ \case+        This x -> Just x+        That y -> Just y+        These x y ->+          let z = x `mappend` y+          in if z == mempty then Nothing else Just z++instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where+  mempty = Selector AMap.empty+  mappend = (<>)++instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where+  negateG = fmap negateG++instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Commutative (Selector k a)++main :: IO ()+main = do+  [0, 1, 1, 0] <- fmap (map fst . concat) $+    runApp (testQueryT testRunWithReplace) () $ map (Just . That) $+      [ That (), This (), That () ]+  [0, 1, 1, 0] <- fmap (map fst . concat) $+    runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $+      [ That (), This (), That () ]+  [0, 1, 1, 0] <- fmap (map fst . concat) $+    runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $+      [ That (), This (), That () ]+  return ()++testQueryT :: (Reflex t, MonadFix m)+           => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())+           -> AppIn t () (These () ())+           -> m (AppOut t Int Int)+testQueryT w (AppIn _ pulse) = do+  let replace = fmapMaybe (^? here) pulse+      increment = fmapMaybe (^? there) pulse+  (_, q) <- runQueryT (w replace increment) $ pure mempty+  let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q+  return $ AppOut+    { _appOut_behavior = current qDyn+    , _appOut_event = updated qDyn+    }++testRunWithReplace :: ( Reflex t+                      , Adjustable t m+                      , MonadHold t m+                      , MonadFix m+                      , MonadQuery t (Selector Int MyQuery) m)+                   => Event t ()+                   -> Event t ()+                   -> m ()+testRunWithReplace replace increment = do+  let w = do+        n <- count increment+        queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1+  _ <- runWithReplace w $ w <$ replace+  return ()++testSequenceDMapWithAdjust :: ( Reflex t+                              , Adjustable t m+                              , MonadHold t m+                              , MonadFix m+                              , MonadQuery t (Selector Int MyQuery) m)+                           => Event t ()+                           -> Event t ()+                           -> m ()+testSequenceDMapWithAdjust replace increment = do+  _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do+    n <- count increment+    queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1+  return ()++testSequenceDMapWithAdjustWithMove :: ( Reflex t+                                      , Adjustable t m+                                      , MonadHold t m+                                      , MonadFix m+                                      , MonadQuery t (Selector Int MyQuery) m)+                                   => Event t ()+                                   -> Event t ()+                                   -> m ()+testSequenceDMapWithAdjustWithMove replace increment = do+  _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do+    n <- count increment+    queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1+  return ()++-- scam it out to test traverseDMapWithAdjustWithMove+listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, Adjustable t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))+listHoldWithKeyWithMove m0 m' f = do+  (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)+  incrementalToDynamic <$> holdIncremental n0 n'+-- -}
+ test/Reflex/Bench/Focused.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeApplications #-}++module Reflex.Bench.Focused where++import Reflex+import Reflex.TestPlan++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity+import Data.Traversable (for, traverse)++import qualified Data.Dependent.Map as DMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe++import Data.Functor.Misc++import Data.List+import Data.List.Split+import Data.Tuple++import Data.Monoid+import Data.Word++import Control.DeepSeq++import Prelude hiding (concat, sum)+++mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a+mergeTree n es | length es <= n =  sum' es+               | otherwise = mergeTree n subTrees+  where+    merges   = chunksOf n es+    subTrees = map sum' merges+    sum'     = fmap sum . mconcat . fmap (fmap (:[]) )++mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]+mergeListDyn = mconcat . fmap (fmap pure)++mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns+                    | otherwise = mergeTreeDyn n $ fmap sumDyns merges+  where+    merges = chunksOf n dyns+    sumDyns = fmap sum . mergeListDyn++++-- N events all firing for N frames+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]++-- Fire N events once every P frames for total N frames (interspersed evenly)+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]+occasional n period frames = traverse plan $ zipWith occs [1..] phases+  where+    phases       = take (fromIntegral n) $ concat (repeat [1..period])+    occs i phase = (, i) <$> [1, phase+1..frames]++++-- Event which never fires (but isn't 'never')+never' :: TestPlan t m => m (Event t Word)+never' = plan []+++-- Event which fires once on first frame+event :: TestPlan t m => m (Event t Word)+event = plan [(1, 0)]++-- Event which fires constantly over N frames+events :: TestPlan t m => Word -> m (Event t Word)+events n  = plan $ (\i -> (i, i)) <$> [1..n]+++-- N events all originating from one event+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]+++-- Make a fan using the value in the event converting it to a singleton Map+-- use a fan of size n (key is the value mod n)+fanMerge :: Reflex t => Word -> Event t Word -> Event t Word+fanMerge n e =  leftmost $ s <$> [0..n - 1] where+  s k = select f (Const2 k)+  f = fan (toMap <$> e)+  toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)++-- Dumb version of the above using simple fmapMaybe to filter+fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word+fmapFanMerge n e =  leftmost $ s <$> [0..n - 1] where+  s k = flip fmapMaybe e $ \j -> if k == j `mod` n+    then Just k+    else Nothing++++-- Create an Event with a Map which is dense to size N+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))+denseMap n = plan [(1, m)] where+  m = Map.fromList $ zip [1..n] [1..n]++iter :: (a -> a) -> Word -> a -> a+iter _ 0 a = a+iter f n a = iter f (n - 1) (f a)++iterM :: Monad m => (a -> m a) -> Word -> a -> m a+iterM _ 0 a = return a+iterM f n a = iterM f (n - 1) =<< f a++fmapChain :: (Functor f) => Word -> f Word -> f Word+fmapChain = iter (fmap (+1))++mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)+mapDynChain = iterM (return . fmap (+1))++joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)+joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)++holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))++buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)+buildDynChain = iterM (\d -> do+    let b = fmap (+1) (current d)+        e = fmap (*2) (updated d)+    buildDynamic (sample b) e)+++combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)+combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)++pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)+pingPong e1 e2 = do+  rec+    d <- foldDyn (const swap) (e1, e2) e+    let e = switch (fst <$> current d)+  return e++switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)+switchFactors 0 e = return e+switchFactors i e = do+    b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)+    switchFactors (i - 1) (switch b)+++switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)+switchChain  = iterM (\e -> pingPong e ((+1) <$> e))+++switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)+switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))++switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)+switchPromptlyChain = iterM $ \e ->+    switchPromptlyDyn <$> holdDyn e (e <$ e)+++coinChain :: Reflex t => Word -> Event t Word -> Event t Word+coinChain = iter $ \e -> coincidence (e <$ e)++fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word+fanMergeChain width = iter $ fanMerge width++fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word+fmapFanMergeChain width = iter $ fmapFanMerge width++-- | Data type for a collection (a map) which is updated by providing differences+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))++-- This will hopefully become a primitive (faster!)+switchMergeEvents ::  (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Event t a)  -> m (Event t (Map k a))+switchMergeEvents mapChanges = switch . fmap mergeMap  <$> holdMap mapChanges++-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Event t a)  -> m (Event t (Map k a))+-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)++switchMergeBehaviors  :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Behavior t a)  -> m (Behavior t (Map k a))+switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges+  where joinMap m = traverse sample =<< sample m++-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes++  where+    modify k Nothing items = Map.delete k items+    modify k (Just item) items = Map.insert k item items+++-- | Hold an UpdatedMap as a behavior by applying differences to the initial value+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))+holdMap = (current <$>) . holdMapDyn+++increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)+increasingMerge xs = do+  e   <- planList (zipWith Map.singleton  [1..] (Just <$> xs) ++ [reset])+  return (UpdatedMap Map.empty e)+    where+      reset = Map.fromList $ zip [1..] (const Nothing <$> xs)++decreasingMerge ::  (TestPlan t m) => [a] -> m (UpdatedMap t Int a)+decreasingMerge xs = do+  e <- planList (zipWith Map.singleton  [1..] (const Nothing <$> xs) ++ [reset])+  return (UpdatedMap initial e)+    where+      initial = Map.fromList $ zip [1..] xs+      reset = Just <$> initial++modifyMerge :: (TestPlan t m) =>  [a] -> m (UpdatedMap t Int a)+modifyMerge xs = do+  e <- planList $ zipWith Map.singleton  [1..] (Just <$> xs)+  return (UpdatedMap initial e)+    where+      initial = Map.fromList $ zip [1..] xs+++countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]+countMany = traverse (fmap current . count)++countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]+countManyDyn = traverse count+++-- Given a function which creates a sub-network (from a single event)+-- Create a plan which uses a switch to substitute it+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)+switches numFrames f = do+  es <- events numFrames+  switch <$> hold never (makeEvents es)++    where+      makeEvents es =  pushAlways (\n -> f (fmap (+n) es)) es++++-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)+-- the other, which we're only interested in time for running frames+subscribing :: Word -> Word -> [(String, TestCase)]+subscribing n frames =+  [ testSub "fmapFanMerge"        $ return . mergeList . fmapFan n+  , testSub "fanMerge"            $ return . fanMerge n+  , testSub "fmapFan/mergeTree"   $ return . mergeTree 8 . fmapFan n+  , testSub "fmapChain"           $ return . fmapChain n+  , testSub "switchChain"         $ switchChain n+  , testSub "switchPromptlyChain" $ switchPromptlyChain n+  , testSub "switchFactors"       $ switchFactors n+  , testSub "coincidenceChain"    $ return . coinChain n+  ]++  where+    testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)+    testSub name test = testE name (switches frames test)++-- Set of benchmark to test specifically merging dynamic collections+-- a pattern which occurs frequently in reflex-dom collections+merging :: Word -> [(String, TestCase)]+merging n =+  [ testE "static events"        $ mergeList <$> sparse+  , testE "increasing events"    $ switchMergeEvents =<< increasingMerge =<< sparse+  , testE "decreasing events"    $ switchMergeEvents =<< decreasingMerge =<< sparse+  , testE "modify events"        $ switchMergeEvents =<< modifyMerge =<< sparse++  , testB "static behaviors"     $ pull . traverse sample <$> counters+  , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters+  , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters+  , testB "modify behaviors"     $ switchMergeBehaviors =<< modifyMerge =<< counters+++  -- , testE "increasing events/switchMerge"    $ switchMergeMaybe =<< increasingMerge =<< sparse+  -- , testE "decreasing events/switchMerge"    $ switchMergeMaybe =<< decreasingMerge =<< sparse+  -- , testE "modify events/switchMerge"        $ switchMergeMaybe =<< modifyMerge =<< sparse+  ]++  where+    sparse :: TestPlan t m => m [Event t Word]+    sparse = fmap (fmap (+1)) <$> occasional n 8 n++    counters :: TestPlan t m => m [Behavior t Int]+    counters = countMany =<< sparse++++fans :: Word -> [(String, TestCase)]+fans n =+  [  testE "fanMapChain"               $ fanMergeChain n 10 <$> e+  ,  testE "fmapFanMapChain"           $ fmapFanMergeChain n 10 <$> e++  , testE "fanMerge " $ fanMerge n <$> events n++  , testE "fmapFanMerge " $ fmapFanMerge n <$> events n+  , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])++  ]+  where++    e :: TestPlan t m => m (Event t Word)+    e = events 100+++++dynamics :: Word -> [(String, TestCase)]+dynamics n =+  [ testE "mapDynChain"         $ fmap updated $ mapDynChain n =<< d+  , testE "joinDynChain"        $ fmap updated $ joinDynChain n =<< d+  , testE "holdDynChain"        $ fmap updated $ holdDynChain n =<< d+  , testE "buildDynChain"        $ fmap updated $ buildDynChain n =<< d+  , testE "combineDynChain"     $ fmap updated $ combineDynChain n =<< d+  , testE "dense mergeTree"     $ fmap (updated . mergeTreeDyn 8) dense+  , testE "sparse mergeTree"    $ fmap (updated . mergeTreeDyn 8) sparse+  , testE "mergeDyn"            $ fmap (updated . fmap sum . mergeListDyn) sparse+  ] where++    d :: TestPlan t m => m (Dynamic t Word)+    d = count =<< events 10++    sparse, dense :: TestPlan t m => m [Dynamic t Int]+    sparse = countManyDyn =<< occasional n 8 16+    dense  = countManyDyn =<< continuous n 2+++firing :: Word -> [(String, TestCase)]+firing n =+  [ testE "fmapChain"           $ fmapChain n <$> e+  , testE "switchChain2"        $ switchChain2 n =<< e+  , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e+  , testE "switchFactors"       $  switchFactors n =<< e+  , testE "coincidenceChain"    $ coinChain n <$> e++  , testE "dense mergeTree"      $ mergeTree 8 <$> dense+  , testE "sparse mergeTree"  $ mergeTree 8 <$> sparse++  -- Triggers test failure in Spider+  --, testE "runFrame"               $ events n++  , testB "sum counters" $ do+      counts <- counters+      return $ pull $ sum <$> traverse sample counts++  , testB "pullChain"                 $ fmapChain n . current <$> (count =<< events 4)+  , testB "pullChain2"                $ do+    es <- events 4+    e' <- plan [(0, ())]++    b <- hold (constant 0) $+      pushAlways (const $ fmapChain n <$> hold 0 es) e'++    return (join b)+  , testB "counters/pullTree" $ mergeTree 8 <$> counters++  ]+    where+      e :: TestPlan t m => m (Event t Word)+      e = events 10++      dense, sparse :: TestPlan t m => m [Event t Word]+      dense = continuous n 2+      sparse = occasional n 8 16++      counters :: TestPlan t m => m [Behavior t Int]+      counters = countMany =<< sparse+++-- Stress-test sampling a single behavior through a large, shared set of pulls,+-- exercising the invalidator-list pruning path.+sharedInvalidators :: Word -> [(String, TestCase)]+sharedInvalidators width =+  [ testB "sumPulls" $ do+      b <- current <$> (count @_ @_ @Int =<< events 10)+      let ps = [ (+ fromIntegral i) <$> b | i <- [1 .. width] ]+      return $ pull $ sum <$> traverse sample ps+  ]
+ test/Reflex/Plan/Pure.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Plan.Pure where++import Reflex+import Reflex.Pure+import Reflex.TestPlan++import Control.Applicative+import Control.Monad.Fix+import Control.Monad.State+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Data.Bifunctor+import Data.Maybe+import Data.Monoid+import Prelude+++mapToPureEvent :: IntMap a -> Event (Pure Int) a+mapToPureEvent m = Event $ flip IntMap.lookup m++type TimeM = (->) Int+newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)++liftPlan :: TimeM a -> PurePlan a+liftPlan = PurePlan . lift++instance MonadHold (Pure Int) PurePlan where+  hold initial  = liftPlan . hold initial+  holdDyn initial = liftPlan . holdDyn initial+  holdIncremental initial = liftPlan . holdIncremental initial+  buildDynamic getInitial = liftPlan . buildDynamic getInitial+  headE = liftPlan . headE+  now = liftPlan now++instance MonadSample (Pure Int) PurePlan where+  sample = liftPlan . sample+++instance TestPlan (Pure Int) PurePlan where+  plan occs = do+    PurePlan . modify $ IntSet.union (IntMap.keysSet m)+    return $ mapToPureEvent m+      where m = IntMap.fromList (first fromIntegral <$> occs)++runPure :: PurePlan a -> (a, IntSet)+runPure (PurePlan p) = runStateT p mempty $ 0++relevantTimes :: IntSet -> IntSet+relevantTimes occs = IntSet.fromList [0..l + 1]+  where l = fromMaybe 0 (fst <$> IntSet.maxView occs)++testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a+testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)++testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs)++++++
+ test/Reflex/Plan/Reflex.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+module Reflex.Plan.Reflex+  ( TestPlan(..)+  , runPlan+  , Plan (..)+  , Schedule+  , Firing (..)+  , MonadIORef+++  , readSchedule+  , readSchedule_+  , testSchedule+  , readEvent'+  , makeDense++  , runTestE+  , runTestB++  ) where++import Reflex.Class+import Reflex.Host.Class+import Reflex.TestPlan++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.State.Strict++import Control.Monad.Ref+import Data.Dependent.Sum (DSum (..))+import qualified Data.IntMap.Strict as IntMap+import Data.Maybe+import Data.Monoid+import Data.Traversable (sequenceA, traverse)++import Control.DeepSeq+import Control.Exception+import Data.IntMap.Strict (IntMap)+import Data.IORef+import System.Mem++-- Note: this import must come last to silence warnings from AMP+import Prelude++type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)++data Firing t where+  Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t+++type Schedule t = IntMap [Firing t]++-- Implementation of a TestPlan in terms of ReflexHost+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)++deriving instance ReflexHost t => Functor (Plan t)+deriving instance ReflexHost t => Applicative (Plan t)+deriving instance ReflexHost t => Monad (Plan t)++deriving instance ReflexHost t => MonadSample t (Plan t)+deriving instance ReflexHost t => MonadHold t (Plan t)+deriving instance ReflexHost t => MonadFix (Plan t)+++instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where+  plan occurrences = Plan $ do+    (e, ref) <- newEventWithTriggerRef+    modify (IntMap.unionWith mappend (firings ref))+    return e++    where+      firings ref = IntMap.fromList (makeFiring ref <$> occurrences)+      makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])+++firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum  (EventTrigger t) Identity))+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref++runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)+runPlan (Plan p) = runHostFrame $ runStateT p mempty+++makeDense :: Schedule t -> Schedule t+makeDense s = fromMaybe (emptyRange 0) $ do+  (end, _) <- fst <$> IntMap.maxViewWithKey s+  return $ IntMap.union s (emptyRange end)+    where+      emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))+++-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors+-- after the last event)+-- performGC is called at each frame to test for GC issues+testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)++readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule++readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()+readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule++triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a+triggerFrame readResult _ occs =  do+    triggers <- catMaybes <$> traverse firingTrigger occs+    liftIO . evaluate . force =<< fireEventsAndRead triggers readResult++readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)+readEvent' = readEvent >=> sequenceA+++-- Convenience functions for running tests producing Events/Behaviors+runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)+runTestB p = do+  (b, s) <- runPlan p+  testSchedule s $ sample b++runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))+runTestE p = do+  (e, s) <- runPlan p+  h <- subscribeEvent e+  testSchedule s (readEvent' h)++
− test/Reflex/Pure.hs 
@@ -1,76 +0,0 @@-{- | This module provides a pure implementation of Reflex, which is intended-to serve as a reference for the semantics of the Reflex class.  All implementations-of Reflex should produce the same results as this implementation, although performance-and laziness/strictness may differ.--}--{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, InstanceSigs #-}-module Reflex.Pure where--import Reflex.Class-import Data.Functor.Misc--import Control.Monad-import Data.MemoTrie-import Data.Dependent.Map (DMap, GCompare)-import qualified Data.Dependent.Map as DMap--data Pure t---- | The Enum instance of t must be dense: for all x :: t, there must not exist---   any y :: t such that pred x < y < x. The HasTrie instance will be used exclusively---   to memoize functions of t, not for any of its other capabilities.-instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where--  newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }-  newtype Event (Pure t) a    = Event { unEvent :: t -> Maybe a }--  type PushM (Pure t) = (->) t-  type PullM (Pure t) = (->) t--  never :: Event (Pure t) a-  never = Event $ \_ -> Nothing--  constant :: a -> Behavior (Pure t) a-  constant x = Behavior $ \_ -> x--  push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b-  push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t--  pull :: PullM (Pure t) a -> Behavior (Pure t) a-  pull = Behavior . memo--  merge :: GCompare k => DMap (WrapArg (Event (Pure t)) k) -> Event (Pure t) (DMap k)-  merge events = Event $ memo $ \t ->-    let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events-    in if DMap.null currentOccurrences-       then Nothing-       else Just currentOccurrences--  fan :: GCompare k => Event (Pure t) (DMap k) -> EventSelector (Pure t) k-  fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k--  switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a-  switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t--  coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a-  coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t--instance Ord t => MonadSample (Pure t) ((->) t) where--  sample :: Behavior (Pure t) a -> (t -> a)-  sample = unBehavior--instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where--  hold :: a -> Event (Pure t) a -> (t -> (Behavior (Pure t) a))-  hold initialValue e initialTime = Behavior f-    where f = memo $ \sampleTime ->-            -- Really, the sampleTime should never be prior to the initialTime,-            -- because that would mean the Behavior is being sampled before being created.-            if sampleTime <= initialTime-            then initialValue-            else let lastTime = pred sampleTime-                 in case unEvent e lastTime of-                   Nothing -> f lastTime-                   Just x  -> x
+ test/Reflex/Test.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module Reflex.Test+  ( testAgreement+  , compareResult+  , runTests++  , module Reflex.TestPlan++  ) where++import Reflex.Spider++import Reflex.TestPlan++import Reflex.Plan.Pure+import Reflex.Plan.Reflex++import Control.Monad+import Data.Monoid++import Data.IntMap (IntMap)++--import Data.Foldable+import System.Exit++import Prelude+++testAgreement :: TestCase -> IO Bool+testAgreement (TestE p) = do+  spider <- runSpiderHost $ runTestE p+  let results = [("spider", spider)]++  compareResult results (testEvent $ runPure p)++testAgreement (TestB p) = do+  spider <- runSpiderHost $ runTestB p+  let results = [("spider", spider)]++  compareResult results (testBehavior $ runPure p)+++compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool+compareResult results expected = fmap and $ forM results $ \(name, r) -> do++  when (r /= expected) $ do+    putStrLn ("Got: " ++ show (name, r))+    putStrLn ("Expected: " ++ show expected)+  return (r == expected)+++runTests :: [(String, TestCase)] -> IO ()+runTests testCases = do+   results <- forM testCases $ \(name, test) -> do+     putStrLn $ "Test: " <> name+     testAgreement test+   exitWith $ if and results+              then ExitSuccess+              else ExitFailure 1+
test/Reflex/Test/CrossImpl.hs view
@@ -1,29 +1,42 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-}-module Reflex.Test.CrossImpl (test) where+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and)+import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_) +import Control.Monad.Ref import Reflex.Class-import Reflex.Host.Class import Reflex.Dynamic-import qualified Reflex.Spider.Internal as S+import Reflex.Host.Class import qualified Reflex.Pure as P-import Control.Monad.Ref+import qualified Reflex.Spider.Internal as S+import qualified Reflex.Profiled as Prof -import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import qualified Data.Set as Set+import Control.Arrow (second, (&&&))+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)+import Data.Dependent.Sum (DSum (..))+import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Control.Arrow (second, (&&&))+import qualified Data.Set as Set+import Data.Monoid import Data.Traversable-import Data.Foldable-import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Data.Dependent.Map (DSum (..))-import System.Mem import System.Exit--import System.IO.Unsafe+import System.Mem  mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of@@ -61,27 +74,30 @@ instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where   mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b) -testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)-testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do+testTimeline+  :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))+  -> (Map Int a, Map Int b)+  -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))+testTimeline builder (bMap, eMap) = do   (re, reTrigger) <- newEventWithTriggerRef   (rb, rbTrigger) <- newEventWithTriggerRef-  b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb+  b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb   (b', e') <- runHostFrame $ builder (b, re)   e'Handle <- subscribeEvent e' --TODO: This should be unnecessary   let times = relevantTestingTimes (bMap, eMap)   liftIO performGC   outputs <- forM times $ \t -> do-    forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger+    forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger     bOutput <- sample b'-    eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do+    eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do       mret <- readRef reTrigger       let firing = case mret of-            Just ret -> [ret :=> val]+            Just ret -> [ret :=> Identity val]             Nothing -> []       fireEventsAndRead firing $ sequence =<< readEvent e'Handle     liftIO performGC     return (t, (bOutput, eOutput))-  return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs) +  return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)  tracePerf :: Show a => a -> b -> b tracePerf = flip const@@ -90,15 +106,19 @@ testAgreement builder inputs = do   let identityResult = testPure builder inputs   tracePerf "---------" $ return ()-  let spiderResult = testSpider builder inputs+  spiderResult <- S.runSpiderHost $ testTimeline builder inputs   tracePerf "---------" $ return ()-  let resultsAgree = identityResult == spiderResult+  profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs+  tracePerf "---------" $ return ()+  let resultsAgree = identityResult == spiderResult && identityResult == profiledResult   if resultsAgree-    then do putStrLn "Success:"-            print identityResult+    then do --putStrLn "Success:"+            --print identityResult+            return ()     else do putStrLn "Failure:"             putStrLn $ "Pure result: " <> show identityResult             putStrLn $ "Spider result:   " <> show spiderResult+            putStrLn $ "Profiled result:   " <> show profiledResult   return resultsAgree  type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))@@ -111,11 +131,11 @@        b' <- hold "123" e        return (b', e)   , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do-       e' <- liftM updated $ count e+       e' <- updated <$> count e        b' <- hold (0 :: Int) e'        return (b', e')-  , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do-       e' <- onceE $ leftmost [e, e]+  , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+       e' <- headE $ leftmost [e, e]        return (b, e')   , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = fmap (const e) e@@ -124,56 +144,52 @@        return (b, e'')   , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = flip pushAlways e $ const $ do-             let ea = fmap (const "a") e-             let eb = fmap (const "b") e-             let eab = leftmost [ea, eb]-             liftM switch $ hold eab never+             let eab = splitRecombineEvent e+             switch <$> hold eab never            e'' = coincidence e'        return (b, e'')   , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = flip pushAlways e $ const $ do-             let ea = fmap (const "a") e-             let eb = fmap (const "b") e-             let eab = leftmost [ea, eb]-             liftM switch $ hold eab (fmap (const e) e)+             let eab = splitRecombineEvent e+             switch <$> hold eab (fmap (const e) e)            e'' = coincidence e'        return (b, e'')   , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = leftmost [e, e]-       e'' <- liftM switch $ hold e' (fmap (const e) e)+       e'' <- switch <$> hold e' (fmap (const e) e)        return (b, e'')-  , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = fmap (const e) e-       e'' <- switchPromptly never e'+       e'' <- switchHoldPromptly never e'        return (b, e'')-  , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = fmap (const e) e-       e'' <- switchPromptly never $ leftmost [e', e']+       e'' <- switchHoldPromptly never $ leftmost [e', e']        return (b, e'')-  , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = leftmost [e, e]-       e'' <- switchPromptly never (fmap (const e) e')+       e'' <- switchHoldPromptly never (fmap (const e) e')        return (b, e'')-  , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do        let e' = leftmost [e, e]-       e'' <- switchPromptly never (fmap (const e') e)+       e'' <- switchHoldPromptly never (fmap (const e') e)        return (b, e'')   , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = leftmost [e, e]-       e'' <- liftM switch $ hold never (fmap (const e') e)+       e'' <- switch <$> hold never (fmap (const e') e)        return (b, e'')-  , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = flip push e $ \_ -> do-             return . Just =<< onceE e-       e'' <- switchPromptly never e'+             Just <$> headE e+       e'' <- switchHoldPromptly never e'        return (b, e'')-  , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+  , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        let e' = flip pushAlways e $ \_ -> do-             switchPromptly e never-       e'' <- switchPromptly never e'+             switchHoldPromptly e never+       e'' <- switchHoldPromptly never e'        return (b, e'')   , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do-       let e' = flip pushAlways e $ \_ -> return $ fmap id e+       let e' = flip pushAlways e $ \_ -> return e            e'' = coincidence e'        return (b, e'')   , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do@@ -185,7 +201,7 @@            e'' = coincidence e'        return (b, e'')   , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do-       let e' = flip pushAlways e $ \_ -> onceE e+       let e' = flip pushAlways e $ \_ -> headE e            e'' = coincidence e'        return (b, e'')   , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do@@ -205,21 +221,46 @@            eCoincidences = coincidence $ fmap (const e') e        return (b, eCoincidences)   , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do-       eo <- onceE e+       eo <- headE e        bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo        let b' = pull $ sample =<< sample bb        return (b', e)+  , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do+       d <- foldDyn (:) [] $+         pushAlways (\a -> foldDyn (:) [a] e) e+       let b = current (join (fmap distributeListOverDynPure d))+       return (b, e)   , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do        bb <- hold "b" e-       bd <- hold never . fmap (const e) =<< onceE e-       eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e+       bd <- hold never . fmap (const e) =<< headE e+       eOuter <- pushAlways sample . fmap (const bb) <$> headE e        let eInner = switch bd            e' = leftmost [eOuter, eInner]        return (b, e')+  , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do+      rec result <- holdUniqDyn d+          d <- holdDyn (0 :: Int) e+      return (current result, updated result)++++  {-+  , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do+       x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e+       let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)+       return (b, e')+  -}   ] -test :: IO ()-test = do+splitRecombineEvent :: Reflex t => Event t a -> Event t String+splitRecombineEvent e =+  let ea = "a" <$ e+      eb = "b" <$ e+  in leftmost [ea, eb]+++main :: IO ()+main = do   results <- forM testCases $ \(name, TestCase inputs builder) -> do     putStrLn $ "Test: " <> name     testAgreement builder inputs
+ test/Reflex/Test/Micro.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}++module Reflex.Test.Micro (testCases) where++import Reflex+import Reflex.TestPlan++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Char+import Data.Foldable+import Data.Functor.Misc+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import Data.Monoid+import Reflex.Patch.MapWithMove (moveMapKey, insertMapKey, deleteMapKey)++import Prelude++pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)+pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))++foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)+foldedDyn f d = fmap join $ flip buildDynamic never $ do+ a <- sample (current d)+ foldDyn f a (updated d)++scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])+scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure++scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])+scanInnerDyns d = do+  scans <- scannedDyn d+  return (join (fmap distributeListOverDynPure scans))++++{-# ANN testCases "HLint: ignore Functor law" #-}+testCases :: [(String, TestCase)]+testCases =+  [ testB "hold"  $ hold "0" =<< events1++  , testB "count" $ do+      b <- current <$> (count =<< events2)+      return $ (+ (0::Int)) <$> b++  , testB "pull-1"  $ do+      b <- hold "0" =<< events1+      return (pull $ sample $ pull $ sample b)++  , testB "pull-2" $ do+      b1 <- behavior1+      return (pull $ liftA2 (<>) (sample b1) (sample b1))++  , testB "pull-3" $ do+      b1 <- behavior1+      b2 <- behavior2+      return (pull $ liftA2 (<>) (sample b1) (sample b2))++  , testB "pull-4" $ do+      es <- planList ["a", "b", "c"]+      e <- plan [(0, ())]+      b <- hold (constant "") $+        pushAlways (const $ hold "z" es) e+      return (join b)++  , testE "id" $ do+      events2++  , testE "fmap-id" $ do+      e <- events2+      return $ fmap id e++  , testE "tag-1" $ do+      b1 <- behavior1+      e <- events2+      return (tag b1 e)++  , testE "tag-2" $ do+      b1 <- behavior1+      e <- events2+      return (tag (map toUpper <$>  b1) e)++  , testE "attach-1" $ do+      b1 <- behavior1+      e <- events2+      return (attachWith (++) (map toUpper <$> b1) e)++  , testE "leftmost" $ liftA2 leftmost2 events1 events2++  , testE "appendEvents-1" $ liftA2 mappend events1 events2++  , testE "appendEvents-2" $ liftA2 mappend events3 events2++  , testE "merge-1" $ do+      e <- events1+      return $ leftmost ["x" <$ e, "y" <$ e]++  , testE "merge-2" $ do+      e <- events1+      let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]+      let ee = flip pushAlways e $ const $ return m+      return $ coincidence ee++  , testE "headE-1" $ do+      e <- events1+      headE $ leftmost [e, e]++  , testE "headE-2" $ do+      e <- events1+      b <- hold never (e <$ e)+      headE $ switch b++  , testE "switch-1" $ do+      e <- events1+      b <- hold never (e <$ e)+      return $ switch b++  , testE "switch-2" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $ do+            switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)++  , testE "switch-3" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $ do+          switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never++  , testE "switch-4" $ do+      e <- events1+      switch <$> hold (deep e) (e <$ e)++  , testE "switch-5" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $+        return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]++  , testE "switch-6" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $ do+            switch <$> hold ("x" <$ e) (e <$ e)++  , testE "switchHoldPromptly-1" $ do+      e <- events1+      let e' = e <$ e+      switchHoldPromptly never $ e <$ e'++  , testE "switchHoldPromptly-2" $ do+      e <- events1+      switchHoldPromptly never $ deep (e <$ e)++  , testE "switchHoldPromptly-3" $ do+      e <- events1+      switchHoldPromptly never $ (e <$ deep e)++  , testE "switchHoldPromptly-4" $ do+      e <- events1+      switchHoldPromptly never $ (deep e <$ e)++  , testE "switch-5" $ do+      e <- events1+      switch <$> hold never (deep e <$ e)++  , testE "switchHoldPromptly-5" $ do+    e <- events1+    switchHoldPromptly never $ flip push e $+      const (Just <$> headE e)++  , testE "switchHoldPromptly-6" $ do+      e <- events1+      switchHoldPromptly never $ flip pushAlways e $+        const (switchHoldPromptly e never)++  , testE "coincidence-1" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $+        const $ return e++  , testE "coincidence-2" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $+        const $ return (deep e)++  , testE "coincidence-3" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $+        const $ return (coincidence (e <$ e))++  , testE "coincidence-4" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $+        const (headE e)++  , testE "coincidence-5" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $ do+        let e' = deep e+        return (coincidence (e' <$ e'))++  , testE "coincidence-6" $ do+      e <- events1+      return $ coincidence $ flip pushAlways e $ const $ do+        let e' = coincidence (e <$ e)+        return $ deep e'++  , testE "coincidence-7" $ do+      e <- events1+      return $ coincidence (deep e <$ e)++  , testE "coincidence-incremental-height" $ do+      tick <- ticks+      e2 <- mergeMapIncremental+              <$> holdIncremental mempty ((mempty :: PatchMap Int (Event t ())) <$ tick)+      pure (leftmost [ void $ coincidence (e2 <$ leftmost [tick, tick])+                     , tick])++  , testE "coincidence-int-incremental-height" $ do+      tick <- ticks+      h <- mergeIntIncremental+             <$> holdIncremental+                   (IntMap.singleton 1 (void tick))+                   (PatchIntMap (IntMap.singleton 1 (Just (void tick))) <$ tick)+      pure (leftmost [ void $ coincidence (void h <$ leftmost [tick, tick])+                     , tick])++  , testE "coincidence-switch-reconnect-height" $ do+      tick <- ticks+      flag <- foldDyn (\_ b -> not b) False tick+      let hi = leftmost [tick, tick]+      pure (leftmost [void (coincidence (switch (current $ (\b -> if b then hi else tick) <$> flag) <$ hi)), tick])++  , testE "mergeWithMove-height" $ do+      tick <- ticks+      let lo = tick+          hi = leftmost [tick, tick]+      patches <- plan+        [ (1, insertMapKey 1 hi)+        , (2, deleteMapKey 0)+        , (3, insertMapKey 0 lo)+        , (4, moveMapKey 1 2)+        , (5, deleteMapKey 2) ]+      mergeMapIncrementalWithMove+        <$> holdIncremental (Map.singleton (0 :: Int) lo) patches++  , testB "holdWhileFiring" $ do+      e <- events1+      eo <- headE e+      bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo+      return $ pull $ sample =<< sample bb+++  , testB "foldDynWhileFiring"  $ do+    e <- events1+    d <- foldDyn (:) [] $+      pushAlways (\a -> foldDyn (:) [a] e) e++    return $ current (join (fmap distributeListOverDynPure d))++  , testE "joinDyn" $ do+      e <- events1+      bb <- hold "b" e+      bd <- hold never . fmap (const e) =<< headE e++      eOuter <- pushAlways sample . fmap (const bb) <$> headE e+      let eInner = switch bd+      return $ leftmost [eOuter, eInner]++  , testB "foldDyn"  $ do+      d <- foldDyn (++) "0" =<< events1+      return (current d)++  , testB "mapDyn"  $ do+      d <- foldDyn (++) "0" =<< events1+      return $ current $ fmap (map toUpper) d++  , testB "combineDyn"  $ do+      d1 <- foldDyn (++) "0" =<< events1+      d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2++      return $ current $ zipDynWith (<>) d1 d2++  , testB "buildDynamicStrictness"  $ do+      rec+        d'' <- pushDyn return d'+        d' <- pushDyn return d+        d <- holdDyn "0" =<< events1++      _ <- sample (current d'')+      return (current d'')++  , testB "factorDyn"  $ do+      d <- holdDyn (Left "a") =<< eithers++      eithers' <- eitherDyn d+      let unFactor = either id id+      return $ current (join (fmap unFactor eithers'))++  , testB "pushDynDeep"  $ do+      _ <- events1+      _ <- events2++      d1 <- holdDyn "d1" =<< events1+      d2 <- holdDyn "d2" =<< events2++      d <- flip pushDyn d1 $ \a ->+        flip pushDyn d2 $ \b ->+          flip pushDyn d1 $ \c ->+            return (a <> b <> c)++      d' <- pushDyn scanInnerDyns d >>= scanInnerDyns+      return $ current d'++  , testE "fan-1" $ do+      e <- fmap toMap <$> events1+      let es = select (fanMap e) . Const2 <$> values++      return (mergeList es)++  , testE "fan-2" $ do+      e <- fmap toMap <$> events3+      let es = select (fanMap e) . Const2 <$> values++      return (mergeList es)++  , testE "fan-3" $ do+      f <- fanMap . fmap toMap <$> events3+      return $  select f (Const2 'c')++  , testE "fan-4" $ do+      e <- fmap toMap <$> events1+      return $ toUpper <$> select (fanMap e) (Const2 'a')++  , testE "fan-5" $ do+      e <- fmap toMap <$> events2+      return $ toUpper <$> select (fanMap e) (Const2 'c')++  , testE "fan-6" $ do+      f <- fanMap . fmap toMap <$> events1+      return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]++  , testE "difference" $ do+      e1 <- events1+      e2 <- events2+      return $ e1 `difference ` e2++  , testE "lazy-hold" $ do+      let lazyHold :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => m (Event t ())+          lazyHold = do+            rec !b <- hold never e+                let e = never <$ switch b+            return $ void e+      lazyHold+  , testE "now-1" $ do+      e1 <- events1+      switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1+  , testE "now-2" $ do+      e1 <- events1+      let e = pushAlways (\a -> if a == "a" then now else return never) e1+      x <- accumDyn (<>) never e +      return . coincidence $ updated x+  ] where++    events1, events2, events3 ::  TestPlan t m => m (Event t String)+    events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]+    events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]+    events3 = liftA2 mappend events1 events2++    -- Unit-valued event occurrences on consecutive frames, for the height/teardown+    -- regression tests below (which need occurrences but not their values).+    ticks :: TestPlan t m => m (Event t ())+    ticks = plan [(1, ()), (2, ()), (3, ()), (4, ()), (5, ()), (6, ())]++    eithers ::  TestPlan t m => m (Event t (Either String String))+    eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]+++    values = "abcde"+    toMap str = Map.fromList $ map (\c -> (c, c)) str++    behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)+    behavior1 =  hold "1" =<< events1+    behavior2 =  hold "2" =<< events2++    deep e = leftmost [e, e]+    leftmost2 e1 e2 = leftmost [e1, e2]
+ test/Reflex/TestPlan.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+module Reflex.TestPlan+  ( TestPlan(..)++  , TestCase (..)+  , testE, testB+  , TestE, TestB++  , planList++  ) where++import Control.DeepSeq+import Control.Monad.Fix+import Data.Word+import Reflex.Class+++import Prelude++class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where+  -- | Specify a plan of an input Event firing+  -- Occurrences must be in the future (i.e. Time > 0)+  -- Initial specification is++  plan :: [(Word, a)] -> m (Event t a)+++planList :: TestPlan t m => [a] -> m (Event t a)+planList xs = plan $ zip [1..] xs++type TestE a = forall t m. TestPlan t m => m (Event t a)+type TestB a = forall t m. TestPlan t m => m (Behavior t a)++data TestCase  where+  TestE  :: (Show a, Eq a, NFData a) => TestE a -> TestCase+  TestB  :: (Show a, Eq a, NFData a) => TestB a -> TestCase++-- Helpers to declare test cases+testE :: (Eq a, Show a, NFData a) => String -> TestE a -> (String, TestCase)+testE name test = (name, TestE test)++testB :: (Eq a, Show a, NFData a) => String -> TestB a -> (String, TestCase)+testB name test = (name, TestB test)+
+ test/RequesterT.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Control.Lens hiding (has)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Class (MonadIO)+import Data.Constraint.Extras+import Data.Constraint.Extras.TH+import Data.Constraint.Forall+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum+import Data.Functor.Misc+import Data.List (words)+import Data.Map (Map)+import qualified Data.Map as M+#if !MIN_VERSION_these(4,11,0)+import Data.Semigroup ((<>))+#endif+import Data.Text (Text)+import Data.These+import Text.Read (readMaybe)++#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))+import Data.These.Lens+#endif++import Reflex+import Reflex.Requester.Base+import Reflex.Requester.Class+import Test.Run++data RequestInt a where+  RequestInt :: Int -> RequestInt Int++data TestRequest a where+  TestRequest_Reverse :: String -> TestRequest String+  TestRequest_Increment :: Int -> TestRequest Int++deriveArgDict ''TestRequest++instance Show (TestRequest a) where+  show = \case+    TestRequest_Reverse str -> "reverse " <> str+    TestRequest_Increment i -> "increment " <> show i++main :: IO ()+main = do+  os1 <- runApp' (unwrapApp testOrdering) $+    [ Just ()+    ]+  print os1+  os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $+    [ This ()+    , That ()+    , This ()+    , These () ()+    ]+  print os2+  os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]+  print os3+  os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]+  print os4+  os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]+  print os5+  os6 <- runApp' (unwrapApp delayedPulse) [Just ()]+  print os6+  os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]+  print os7+  os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]+  print os8+  let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'+  let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2+  let ![[Nothing, Just [2]]] = os3+  let ![[Nothing, Just [2]]] = os4+  let ![[Nothing, Just [1, 2]]] = os5+  -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved+  let !(Just [(1,"2")]) = M.toList <$> head (head os7)+  let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)++  return ()++unwrapRequest :: DSum tag RequestInt -> Int+unwrapRequest (_ :=> RequestInt i) = i++unwrapApp :: ( Reflex t, Monad m )+          => (a -> RequesterT t RequestInt Identity m ())+          -> a+          -> m (Event t [Int])+unwrapApp x appIn = do+  ((), e) <- runRequesterT (x appIn) never+  return $ fmap (map unwrapRequest . requesterDataToList) e++testOrdering :: ( Response m ~ Identity+                , Request m ~ RequestInt+                , Requester t m+                , Adjustable t m)+             => Event t ()+             -> m ()+testOrdering pulse = forM_ [10,9..1] $ \i ->+  requestingIdentity (RequestInt i <$ pulse)++testSimultaneous :: ( Response m ~ Identity+                    , Request m ~ RequestInt+                    , Requester t m+                    , Adjustable t m)+                 => Event t (These () ())+                 -> m ()+testSimultaneous pulse = do+  let tellE = fmapMaybe (^? here) pulse+      switchE = fmapMaybe (^? there) pulse+  forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->+    requestingIdentity (RequestInt (i+1) <$ tellE)++-- | Test that a widget requesting and event which fires at the same time it has been replaced+-- doesn't count along with the new widget.+testMoribundRequest+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     , Response m ~ Identity+     , Request m ~ RequestInt+     , Requester t m+     )+  => Event t ()+  -> m ()+testMoribundRequest pulse = do+  rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished+      (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse+  return ()++-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.+testMoribundRequestDMap+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     , Response m ~ Identity+     , Request m ~ RequestInt+     , Requester t m+     )+  => Event t ()+  -> m ()+testMoribundRequestDMap pulse = do+  rec let requestIntOnReplace :: Int -> m ()+          requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished+      (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-+        traverseDMapWithKeyWithAdjust+          (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)+          (mapToDMap $ M.singleton () 1)+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)+  return ()++-- | Ensures that elements which are _not_ removed can still fire requests+-- during the same frame as other elements are updated.+testLiveRequestDMap+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     , Response m ~ Identity+     , Request m ~ RequestInt+     , Requester t m+     )+  => Event t ()+  -> m ()+testLiveRequestDMap pulse = do+  rec let requestIntOnReplace :: Int -> m ()+          requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished+      (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-+        traverseDMapWithKeyWithAdjust+          (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)+          (mapToDMap $ M.singleton 1 ())+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)+  return ()++delayedPulse+  :: forall t m+  .  ( Reflex t+     , Adjustable t m+     , MonadHold t m+     , MonadFix m+     , Response m ~ Identity+     , Request m ~ RequestInt+     , PerformEvent t m+     , Requester t m+     )+  => Event t ()+  -> m ()+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do+    -- This has the effect of delaying pulse' from pulse+    (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse+    requestingIdentity pulse'++testMatchRequestsWithResponses+  :: forall m t req a+   . ( MonadFix m+     , MonadHold t m+     , Reflex t+     , PerformEvent t m+     , MonadIO (Performable m)+     , ForallF Show req+     , Has Read req+     )+  => Event t (req a) -> m (Event t (Map Int String))+testMatchRequestsWithResponses pulse = mdo+  (_, requests) <- runRequesterT (requesting pulse) responses+  let rawResponses = M.map (\v ->+        case words v of+          ["reverse", str] -> reverse str+          ["increment", i] -> show $ succ $ (read i :: Int)+        ) <$> rawRequestMap+  (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)+  pure rawResponses+  where+    reqEncoder :: forall a. req a -> (String, String -> Maybe a)+    reqEncoder r =+      ( whichever @Show @req @a $ show r+      , \x -> has @Read r $ readMaybe x+      )
+ test/Test/Run.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+module Test.Run where++import Control.Monad+import Control.Monad.Ref+import Data.Dependent.Sum+import Data.Functor.Identity+import Data.These++import Reflex+import Reflex.Host.Class++data AppIn t b e = AppIn+  { _appIn_behavior :: Behavior t b+  , _appIn_event :: Event t e+  }++data AppOut t b e = AppOut+  { _appOut_behavior :: Behavior t b+  , _appOut_event :: Event t e+  }++runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+       => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut))+       -> bIn+       -> [Maybe (These bIn eIn)]+       -> IO [[(bOut, Maybe eOut)]]+runApp app b0 input = runSpiderHost $ do+  (appInHoldE, pulseHoldTriggerRef) <- newEventWithTriggerRef+  (appInE, pulseEventTriggerRef) <- newEventWithTriggerRef+  appInB <- hold b0 appInHoldE+  (out, FireCommand fire) <- hostPerformEventT $ app $ AppIn+    { _appIn_event = appInE+    , _appIn_behavior = appInB+    }+  hnd <- subscribeEvent (_appOut_event out)+  mpulseB <- readRef pulseHoldTriggerRef+  mpulseE <- readRef pulseEventTriggerRef+  let readPhase = do+        b <- sample (_appOut_behavior out)+        frames <- sequence =<< readEvent hnd+        return (b, frames)+  forM input $ \case+    Nothing ->+      fire [] $ readPhase+    Just i -> case i of+      This b' -> case mpulseB of+        Nothing -> error "tried to fire in-behavior but ref was empty"+        Just pulseB -> fire [ pulseB :=> Identity b' ] $ readPhase+      That e' -> case mpulseE of+        Nothing -> error "tried to fire in-event but ref was empty"+        Just pulseE -> fire [ pulseE :=> Identity e' ] $ readPhase+      These b' e' -> case mpulseB of+        Nothing -> error "tried to fire in-behavior but ref was empty"+        Just pulseB -> case mpulseE of+          Nothing -> error "tried to fire in-event but ref was empty"+          Just pulseE -> fire [ pulseB :=> Identity b', pulseE :=> Identity e' ] $ readPhase++runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+        => (Event t eIn -> PerformEventT t m (Event t eOut))+        -> [Maybe eIn]+        -> IO [[Maybe eOut]]+runApp' app input = do+  let app' = fmap (AppOut (pure ())) . app+  map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)++runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)+        => (Event t eIn -> PerformEventT t m (Behavior t bOut))+        -> [Maybe eIn]+        -> IO [[bOut]]+runAppB app input = do+  let app' = fmap (flip AppOut never) . app+  map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input)
+ test/behaviorLeak.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Test whether Applicative combination of Behaviors leaks memory when one of+-- the Behaviors' source events never occurs.+-- (https://github.com/reflex-frp/reflex/issues/490)++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Primitive (touch)+import Control.Monad.Ref+import Data.Dependent.Sum+import Data.Functor.Identity+import Data.Maybe (fromJust)+import GHC.Stats+import Reflex+import Reflex.Host.Class+import System.Exit+import System.Mem (performMajorGC)+import Text.Printf++warmupTicks :: Int+warmupTicks = 200000+windowTicks :: Int+windowTicks = 200000+samplesPerWindow :: Int+samplesPerWindow = 20+ticksBetweenWindows :: Int+ticksBetweenWindows = 9 * windowTicks+allowedGrowthBytes :: Integer+allowedGrowthBytes = 512 * 1024++testCase :: (Reflex t, MonadHold t m) => Event t b -> m (Behavior t (Int, Int))+testCase tickE = do+  a <- hold (0 :: Int) (0 <$ tickE)+  c <- hold (0 :: Int) never+  pure $ (,) <$> a <*> c++main :: IO ()+main = do+  enabled <- getRTSStatsEnabled+  unless enabled $ do+    putStrLn "Failed: RTS stats not enabled (run with +RTS -T)"+    exitFailure++  runSpiderHost $ do+    (tickE, tickTriggerRef) <- newEventWithTriggerRef+    b <- runHostFrame $ testCase tickE+    trigger <- fromJust <$> readRef tickTriggerRef+    let fireOnce = void $ fireEventsAndRead [trigger :=> Identity ()] $ do+          v <- sample b+          v `seq` pure ()+        liveBytes = liftIO $ do+          performMajorGC+          fromIntegral . gcdetails_live_bytes . gc <$> getRTSStats :: IO Integer+        measureWindow = do+          let chunk = windowTicks `div` samplesPerWindow+          samples <- replicateM samplesPerWindow $ do+            replicateM_ chunk fireOnce+            liveBytes+          pure $ sum samples `div` fromIntegral samplesPerWindow++    replicateM_ warmupTicks fireOnce+    firstWindowAvg <- measureWindow+    replicateM_ ticksBetweenWindows fireOnce+    secondWindowAvg <- measureWindow+    liftIO $ touch b+    liftIO $ do+      let growth = secondWindowAvg - firstWindowAvg+      if growth <= allowedGrowthBytes+        then putStrLn "Succeeded"+        else do+          printf "Failed: Behavior Applicative space leak\n"+          printf "    first-window avg live bytes:  %d\n" firstWindowAvg+          printf "    second-window avg live bytes: %d\n" secondWindowAvg+          printf "    growth over %d intervening ticks: %d bytes (allowed %d)\n"+            ticksBetweenWindows growth allowedGrowthBytes+          exitFailure
+ test/hlint.hs view
@@ -0,0 +1,39 @@+module Main where++import Control.Monad+import Language.Haskell.HLint (hlint)+import System.Directory+import System.Exit (exitFailure, exitSuccess)+import System.FilePath+import System.FilePath.Find++main :: IO ()+main = do+  pwd <- getCurrentDirectory+  let runHlint f = hlint $ f:+        [ "--ignore=Redundant do"+        , "--ignore=Use camelCase"+        , "--ignore=Redundant $"+        , "--ignore=Use &&"+        , "--ignore=Use &&&"+        , "--ignore=Use const"+        , "--ignore=Use >=>"+        , "--ignore=Use ."+        , "--ignore=Use unless"+        , "--ignore=Reduce duplication"+        , "--ignore=Replace case with maybe"+        , "--cpp-define=DEBUG"+        , "--ignore=Use tuple-section"+        ]+      recurseInto = and <$> sequence+        [ fileType ==? Directory+        , fileName /=? ".git"+        ]+      matchFile = and <$> sequence+        [ extension ==? ".hs"+        ]+  files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.+  ideas <- fmap concat $ forM files $ \f -> do+    putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "+    runHlint f+  if null ideas then exitSuccess else exitFailure
+ test/rootCleanup.hs view
@@ -0,0 +1,25 @@+import Control.Concurrent+import Control.Monad+import Data.IORef+import Reflex+import Reflex.Host.Class+import System.Exit+import System.Mem++main :: IO ()+main = do+  numSubscriptions <- newIORef 0+  replicateM_ 1000 $ do+    runSpiderHost $ do+      e <- newEventWithTrigger $ \_ -> do+        modifyIORef' numSubscriptions succ+        return $ modifyIORef' numSubscriptions pred+      _ <- hold () e+      return ()+    replicateM_ 100 $ do+      performMajorGC+      threadDelay 1+  n <- readIORef numSubscriptions+  if n == 0+    then putStrLn "Succeeded"+    else putStrLn "Failed" >> exitFailure
+ test/semantics.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module Main (main) where++import Reflex.Test++import Data.Bifunctor+import Data.Functor+import Data.List+import qualified Reflex.Bench.Focused as Focused+import qualified Reflex.Test.Micro as Micro++import System.Environment+import System.Exit++import Prelude++matchPrefixes :: [String] -> (String -> Bool)+matchPrefixes []   = const True+matchPrefixes args = \name -> any (`isPrefixOf` name) args+++main :: IO ()+main = do+  args <- getArgs++  case args of+    ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1)+    _          -> case filter (matchPrefixes args . fst) allTests of+                    []    -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1)+                    tests -> runTests tests++  where+    allTests = concat+     [ makeGroup "micro" Micro.testCases+     , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)+     , makeGroup "firing 1000" (Focused.firing 1000)+     , makeGroup "merge 100" (Focused.merging 100)+     , makeGroup "fan 50" (Focused.fans 50)+     ]++    makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests