diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/Quickref.md b/Quickref.md --- a/Quickref.md +++ b/Quickref.md @@ -54,18 +54,19 @@ [ ] 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 (WrapArg Event k) -> Event (DMap k) +[ ] 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) -> 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) +[ ] 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 @@ -166,7 +167,7 @@ -- Flatten Behavior-of-Event to Event. Old Event is used during switchover. [ ] switch :: Behavior (Event a) -> Event a --- Flatten Dyanmic-of-Event to Event. New Event is used immediately. +-- 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. @@ -198,7 +199,7 @@ 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. -Th typeclasses and their associated annotations include: +The typeclasses and their associated annotations include: - `PostBuild` Fire an Event when an FRP network has been set up. @@ -206,7 +207,7 @@ [B] -- Function runs in any monad supporting PostBuild ``` -- `Adjustable` +- `Adjustable` Use Events to add or remove pieces of an FRP network. ```haskell [A] -- Function runs in any monad supporting Adjustable @@ -271,7 +272,7 @@ ```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. +-- 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) @@ -295,17 +296,20 @@ ## Networks ```haskell --- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a) +-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a) --- 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, +[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) +[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 +-- 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) +[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) +[P,A] untilReady :: m a -> m b -> m (a, Event b) +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,19 +1,24 @@ -## Reflex -### Practical Functional Reactive Programming +# [Reflex](https://reflex-frp.org/) -Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. +[![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) -[Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. +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. -Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/reflex-frp/reflex-platform and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c). +Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface. -A summary of Reflex functions is available in the [quick reference](Quickref.md). +**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).** -### Additional resources -[Get started with Reflex](https://github.com/reflex-frp/reflex-platform) +## Resources -[/r/reflexfrp](https://www.reddit.com/r/reflexfrp) +* [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) -[hackage](https://hackage.haskell.org/package/reflex) +## Hacking -[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) +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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -12,6 +12,7 @@ import Control.Concurrent.STM import Control.DeepSeq import Control.Exception (evaluate) +import Control.Monad import Control.Monad.Identity import Control.Monad.IO.Class import Criterion.Main @@ -27,11 +28,6 @@ main :: IO () main = defaultMain [ bgroup "micro" micros ] - -#if !(MIN_VERSION_deepseq(1,4,2)) -instance NFData (IORef a) where - rnf x = seq x () -#endif instance NFData (TVar a) where rnf x = seq x () diff --git a/bench/RunAll.hs b/bench/RunAll.hs --- a/bench/RunAll.hs +++ b/bench/RunAll.hs @@ -121,6 +121,7 @@ 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 @@ -131,6 +132,10 @@ , merging 50 , merging 100 , merging 200 + , shared 30 + , shared 100 + , shared 300 + , shared 1000 ] pattern RunTestCaseFlag = "--run-test-case" diff --git a/reflex.cabal b/reflex.cabal --- a/reflex.cabal +++ b/reflex.cabal @@ -1,364 +1,523 @@ -Name: reflex -Version: 0.5.0.1 -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://reflex-frp.org -bug-reports: https://github.com/reflex-frp/reflex/issues -extra-source-files: - README.md - Quickref.md +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 -flag use-reflex-optimizer - description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. - default: False - manual: True +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. + . + -flag use-template-haskell - description: Use template haskell to generate lenses - default: True - manual: True +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 + description: + Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow! -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 + default: False + manual: True -library - hs-source-dirs: src - build-depends: - MemoTrie == 0.6.*, - base >= 4.9 && < 4.13, - bifunctors >= 5.2 && < 5.6, - comonad, - containers >= 0.5 && < 0.7, - data-default >= 0.5 && < 0.8, - dependent-map >= 0.2.4 && < 0.3, - exception-transformers == 0.4.*, - lens >= 4.7 && < 5, - monad-control >= 1.0.1 && < 1.1, - monoidal-containers == 0.4.*, - mtl >= 2.1 && < 2.3, - prim-uniq >= 0.1.0.1 && < 0.2, - primitive >= 0.5 && < 0.7, - random == 1.1.*, - ref-tf == 0.4.*, - reflection == 2.1.*, - semigroupoids >= 4.0 && < 6, - semigroups >= 0.16 && < 0.19, - stm >= 2.4 && < 2.6, - syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.7.7, - time >= 1.4 && < 1.9, - transformers >= 0.2, - transformers-compat >= 0.3, - unbounded-delays >= 0.1.0.0 && < 0.2 +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 - exposed-modules: - Data.AppendMap, - Data.FastMutableIntMap, - Data.FastWeakBag, - Data.Functor.Misc, - Data.Map.Misc, - Data.WeakBag, - Reflex, - Reflex.Class, - Reflex.Adjustable.Class, - Reflex.BehaviorWriter.Base, - Reflex.BehaviorWriter.Class, - Reflex.Collection, - Reflex.Dynamic, - 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.Network, - Reflex.NotReady.Class, - Reflex.Patch, - Reflex.Patch.Class, - Reflex.Patch.DMap, - Reflex.Patch.DMapWithMove, - Reflex.Patch.IntMap, - Reflex.Patch.Map, - Reflex.Patch.MapWithMove, - 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.Class, - Reflex.Spider, - Reflex.Spider.Internal, - Reflex.Time, - Reflex.TriggerEvent.Base, - Reflex.TriggerEvent.Class, - Reflex.Widget.Basic, - Reflex.Workflow + default: False + manual: True - ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively +flag debug-propagation + description: Enable debugging of spider internals + default: False + manual: True - if flag(debug-trace-events) - cpp-options: -DDEBUG_TRACE_EVENTS - build-depends: bytestring +flag debug-cycles + description: Enable debugging of event cycles + default: False + manual: True - if flag(use-reflex-optimizer) - cpp-options: -DUSE_REFLEX_OPTIMIZER - build-depends: ghc - exposed-modules: Reflex.Optimizer +flag split-these + description: Use split these/semialign packages + manual: False + default: True - if flag(use-template-haskell) - cpp-options: -DUSE_TEMPLATE_HASKELL - build-depends: - dependent-sum >= 0.3 && < 0.5, - haskell-src-exts >= 1.16 && < 1.21, - haskell-src-meta >= 0.6 && < 0.9, - template-haskell >= 2.9 && < 2.15 +library exposed-modules: - Reflex.Dynamic.TH - other-extensions: TemplateHaskell - else + 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 + + 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 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -fwarn-redundant-constraints -fwarn-tabs + -funbox-strict-fields -O2 -fspecialise-aggressively + build-depends: - dependent-sum == 0.4.* + 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 - if flag(fast-weak) && impl(ghcjs) - cpp-options: -DGHCJS_FAST_WEAK + other-extensions: + TemplateHaskell - if impl(ghcjs) - build-depends: ghcjs-base + 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 - ghc-options: -O2 -Wall -rtsopts - build-depends: - base, - bifunctors, - containers, - deepseq >= 1.3 && < 1.5, - dependent-map, - dependent-sum, - mtl, - ref-tf, - reflex, - split, - transformers >= 0.3 - other-modules: - Reflex.Bench.Focused - Reflex.Plan.Pure - Reflex.Plan.Reflex - Reflex.Test - Reflex.Test.Micro - Reflex.TestPlan + 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 - ghc-options: -O2 -Wall -rtsopts - build-depends: - base, - containers, - dependent-map, - dependent-sum, - deepseq >= 1.3 && < 1.5, - mtl, - transformers, - ref-tf, - reflex - other-modules: - Reflex.Test - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Plan.Pure + 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 - build-depends: base - , directory - , filepath - , filemanip - , hlint - if impl(ghcjs) - buildable: False + 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 - build-depends: base - , containers - , deepseq >= 1.3 && < 1.5 - , dependent-map - , dependent-sum - , lens - , mtl - , these - , transformers - , reflex - , ref-tf - other-modules: - Reflex.Test - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Plan.Pure - Test.Run + 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 - build-depends: base - , dependent-sum - , dependent-map - , lens - , these - , transformers - , reflex - , ref-tf - buildable: False - other-modules: - Reflex.TestPlan - Reflex.Plan.Pure + 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 - build-depends: base - , containers - , dependent-map - , dependent-sum - , deepseq >= 1.3 && < 1.5 - , lens - , monoidal-containers - , mtl - , ref-tf - , reflex - , semigroups - , these - , transformers - other-modules: - Test.Run - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Plan.Pure + 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 - build-depends: base - , containers - , dependent-sum - , dependent-map - , deepseq >= 1.3 && < 1.5 - , mtl - , these - , transformers - , reflex - , ref-tf - if impl(ghc < 8) - build-depends: semigroups - other-modules: - Reflex.Plan.Pure - Reflex.Plan.Reflex - Reflex.TestPlan - Test.Run + 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 - build-depends: base - , containers - , deepseq >= 1.3 && < 1.5 - , dependent-sum - , mtl - , reflex - , ref-tf - , these - other-modules: - Reflex.Plan.Pure - Reflex.TestPlan - Test.Run + 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 test - main-is: Main.hs - ghc-options: -Wall -O2 -rtsopts - build-depends: - base, - containers, - criterion >= 1.1 && < 1.6, - deepseq >= 1.3 && < 1.5, - dependent-map, - dependent-sum, - ref-tf, - mtl, - primitive, - reflex, - split, - stm, - transformers >= 0.3 - other-modules: - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Bench.Focused + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench test + other-modules: + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Bench.Focused + 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 - hs-source-dirs: bench test - c-sources: bench-cbits/checkCapability.c - main-is: RunAll.hs - ghc-options: -Wall -O2 -rtsopts -threaded - build-depends: - base, - containers >= 0.5 && < 0.7, - criterion >= 1.1 && < 1.6, - deepseq >= 1.3 && < 1.5, - dependent-map, - dependent-sum, - loch-th, - mtl, - primitive, - process, - ref-tf, - reflex, - split, - stm, - time, - transformers >= 0.3 - other-modules: - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Bench.Focused + 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 -source-repository head - type: git - location: https://github.com/reflex-frp/reflex + 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 diff --git a/src/Control/Monad/ReaderIO.hs b/src/Control/Monad/ReaderIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ReaderIO.hs @@ -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 #-} diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -1,53 +1,48 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | 'Data.Map' with a better 'Monoid' instance --- --- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has --- @mappend = unionWith mappend@ instead. + +-- | +-- 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 (map, null) +import Prelude hiding (null) import Data.Coerce import Data.Default import Data.Map (Map) -#if MIN_VERSION_containers(0,5,11) import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) -#else -import qualified Data.Map as Map (showTree, showTreeWith) -#endif import Data.Map.Monoidal -import Reflex.Class (FunctorMaybe (..)) -import Reflex.Patch (Additive, Group (..)) + {-# 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 -instance FunctorMaybe (MonoidalMap k) where - fmapMaybe = mapMaybe - -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) nonEmptyDelete k vs = @@ -56,24 +51,22 @@ 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 = fmapMaybe f as + let bs = mapMaybe f as in if null bs then Nothing else Just bs --- TODO: Move instances to `Reflex.Patch` -instance (Ord k, Group q) => Group (MonoidalMap k q) where - negateG = map negateG - -instance (Ord k, Additive q) => Additive (MonoidalMap k q) - +-- 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) diff --git a/src/Data/FastMutableIntMap.hs b/src/Data/FastMutableIntMap.hs --- a/src/Data/FastMutableIntMap.hs +++ b/src/Data/FastMutableIntMap.hs @@ -1,4 +1,10 @@ {-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: +-- Data.FastMutableIntMap +-- Description: +-- A mutable version of 'IntMap' module Data.FastMutableIntMap ( FastMutableIntMap , new @@ -16,6 +22,7 @@ , patchIntMapNewElements , patchIntMapNewElementsMap , getDeletions + , toList ) where --TODO: Pure JS version @@ -29,36 +36,46 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef -import Reflex.Patch.Class -import Reflex.Patch.IntMap +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 @@ -69,8 +86,13 @@ 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 diff --git a/src/Data/FastWeakBag.hs b/src/Data/FastWeakBag.hs --- a/src/Data/FastWeakBag.hs +++ b/src/Data/FastWeakBag.hs @@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif #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 @@ -18,6 +16,7 @@ , isEmpty , insert , traverse + , traverse_ , remove -- * Internal functions -- These will not always be available. @@ -50,7 +49,7 @@ #else data FastWeakBag a = FastWeakBag { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? - , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) + , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag' } #endif @@ -116,14 +115,14 @@ isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag) #endif -{-# INLINE traverse #-} +{-# 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 () +traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () #ifdef GHCJS_FAST_WEAK -traverse wb f = do +traverse_ wb f = do let go cursor = when (not $ js_isNull cursor) $ do val <- liftIO $ js_getTicketValue cursor f $ unsafeFromRawJSVal val @@ -134,12 +133,16 @@ --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 +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'. diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs deleted file mode 100644 --- a/src/Data/Functor/Misc.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif --- | This module provides types and functions with no particular theme, but --- which are relevant to the use of 'Functor'-based datastructures like --- 'Data.Dependent.Map.DMap'. -module Data.Functor.Misc - ( -- * Const2 - Const2 (..) - , unConst2 - , dmapToMap - , dmapToIntMap - , dmapToMapWith - , mapToDMap - , weakenDMapWith - -- * WrapArg - , WrapArg (..) - -- * Convenience functions for DMap - , mapWithFunctorToDMap - , intMapWithFunctorToDMap - , mapKeyValuePairsMonotonic - , combineDMapsWithKey - , EitherTag (..) - , dmapToThese - , eitherToDSum - , dsumToEither - -- * Deprecated functions - , sequenceDmap - , wrapDMap - , rewrapDMap - , unwrapDMap - , unwrapDMapMaybe - , extractFunctorDMap - , ComposeMaybe (..) - ) where - -import Control.Applicative (Applicative, (<$>)) -import Control.Monad.Identity -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Sum -import Data.GADT.Compare -import Data.GADT.Show -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 qualified Data.Some as Some -import Data.These -import Data.Typeable hiding (Refl) - --------------------------------------------------------------------------------- --- Const2 --------------------------------------------------------------------------------- - --- | 'Const2' stores a value of a given type 'k' and ensures that a particular --- type 'v' is always given for the last type parameter -data Const2 :: * -> x -> x -> * where - Const2 :: k -> Const2 k v v - deriving (Typeable) - --- | Extract the value from a Const2 -unConst2 :: Const2 k v v' -> k -unConst2 (Const2 k) = k - -deriving instance Eq k => Eq (Const2 k v v') -deriving instance Ord k => Ord (Const2 k v v') -deriving instance Show k => Show (Const2 k v v') -deriving instance Read k => Read (Const2 k v v) - -instance Show k => GShow (Const2 k v) where - gshowsPrec n x@(Const2 _) = showsPrec n x - -instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where - showTaggedPrec (Const2 _) = showsPrec - -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 - --- | Convert a 'DMap' to a regular 'Map' -dmapToMap :: DMap (Const2 k v) Identity -> Map k v -dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList - --- | Convert a 'DMap' to an 'IntMap' -dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v -dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList - --- | Convert a 'DMap' to a regular 'Map', applying the given function to remove --- the wrapping 'Functor' -dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v' -dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList - --- | Convert a regular 'Map' to a 'DMap' -mapToDMap :: Map k v -> DMap (Const2 k v) Identity -mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList - --- | Convert a regular 'Map', where the values are already wrapped in a functor, --- to a 'DMap' -mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f -mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList - --- | Convert a regular 'IntMap', where the values are already wrapped in a --- functor, to a 'DMap' -intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f -intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList - --- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with --- the keys, using a function to remove the wrapping 'Functor' -weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v' -weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList - --------------------------------------------------------------------------------- --- WrapArg --------------------------------------------------------------------------------- - --- | 'WrapArg' can be used to tag a value in one functor with a type --- representing another functor. This was primarily used with dependent-map < --- 0.2, in which the value type was not wrapped in a separate functor. -data WrapArg :: (k -> *) -> (k -> *) -> * -> * where - WrapArg :: f a -> WrapArg g f (g a) - -deriving instance Eq (f a) => Eq (WrapArg g f (g' a)) -deriving instance Ord (f a) => Ord (WrapArg g f (g' a)) -deriving instance Show (f a) => Show (WrapArg g f (g' a)) -deriving instance Read (f a) => Read (WrapArg g f (g a)) - -instance GEq f => GEq (WrapArg g f) where - geq (WrapArg a) (WrapArg b) = (\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 - --------------------------------------------------------------------------------- --- Convenience functions for DMap --------------------------------------------------------------------------------- - --- | Map over all key/value pairs in a 'DMap', potentially altering the key as --- well as the value. The provided function MUST preserve the ordering of the --- keys, or the resulting 'DMap' will be malformed. -mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v' -mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList - -{-# INLINE combineDMapsWithKey #-} --- | Union two 'DMap's of different types, yielding another type. Each key that --- is present in either input map will be present in the output. -combineDMapsWithKey :: forall f g h i. - GCompare f - => (forall a. f a -> These (g a) (h a) -> i a) - -> DMap f g - -> DMap f h - -> DMap f i -combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh) - where go :: [DSum f g] -> [DSum f h] -> [DSum f i] - go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs - go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs - go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of - GLT -> (gk :=> f gk (This gv)) : go gs' hs - GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs' - GGT -> (hk :=> f hk (That hv)) : go gs hs' - --- | Extract the values of a 'DMap' of 'EitherTag's. -dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b) -dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of - (Nothing, Nothing) -> Nothing - (Just (Identity a), Nothing) -> Just $ This a - (Nothing, Just (Identity b)) -> Just $ That b - (Just (Identity a), Just (Identity b)) -> Just $ These a b - --- | 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 - deriving (Typeable) - -deriving instance Show (EitherTag l r a) -deriving instance Eq (EitherTag l r a) -deriving instance Ord (EitherTag l r a) - -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) Identity where - showTaggedPrec t n (Identity 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) Identity -eitherToDSum = \case - Left a -> (LeftTag :=> Identity a) - Right b -> (RightTag :=> Identity b) - --- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'. -dsumToEither :: DSum (EitherTag a b) Identity -> Either a b -dsumToEither = \case - (LeftTag :=> Identity a) -> Left a - (RightTag :=> Identity b) -> Right b - --------------------------------------------------------------------------------- --- ComposeMaybe --------------------------------------------------------------------------------- - --- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would --- make the 'f' parameter have a nominal type role. We need f to be --- representational so that we can use safe 'coerce'. -newtype ComposeMaybe f a = - ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord) - -deriving instance Functor f => Functor (ComposeMaybe f) - --------------------------------------------------------------------------------- --- Deprecated functions --------------------------------------------------------------------------------- - -{-# INLINE sequenceDmap #-} -{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-} --- | Run the actions contained in the 'DMap' -sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity) -sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t - -{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-} --- | Replace the 'Identity' functor for a 'DMap''s values with a different functor -wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f -wrapDMap f = DMap.map $ f . runIdentity - -{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-} --- | Replace one functor for a 'DMap''s values with a different functor -rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g -rewrapDMap = DMap.map - -{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-} --- | Replace one functor for a 'DMap''s values with the 'Identity' functor -unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity -unwrapDMap f = DMap.map $ Identity . f - -{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-} --- | Like 'unwrapDMap', but possibly delete some values from the DMap -unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity -unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a - -{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-} --- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the --- underlying functor -extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f -extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v diff --git a/src/Data/Map/Misc.hs b/src/Data/Map/Misc.hs --- a/src/Data/Map/Misc.hs +++ b/src/Data/Map/Misc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} + -- | Additional functions for manipulating 'Map's. module Data.Map.Misc ( @@ -43,7 +44,7 @@ -- |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 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'. +-- 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 diff --git a/src/Data/WeakBag.hs b/src/Data/WeakBag.hs --- a/src/Data/WeakBag.hs +++ b/src/Data/WeakBag.hs @@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | 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 @@ -15,6 +13,7 @@ , singleton , insert , traverse + , traverse_ , remove -- * Internal functions -- These will not always be available. @@ -99,17 +98,21 @@ ticket <- insert a bag wbRef finalizer return (bag, ticket) -{-# INLINE traverse #-} +{-# 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 +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'. diff --git a/src/Reflex.hs b/src/Reflex.hs --- a/src/Reflex.hs +++ b/src/Reflex.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + -- | 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 @@ -13,12 +14,11 @@ import Reflex.Dynamic as X import Reflex.EventWriter.Base as X import Reflex.EventWriter.Class as X -#ifdef USE_TEMPLATE_HASKELL import Reflex.Dynamic.TH as X -#endif 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 diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -3,14 +3,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + +-- | +-- 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 @@ -24,7 +28,8 @@ import Control.Monad.Identity import Control.Monad.Reader -import Data.Dependent.Map (DMap, GCompare (..)) +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 @@ -33,7 +38,7 @@ import Data.Map (Map) import Reflex.Class -import Reflex.Patch.DMapWithMove +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 @@ -94,13 +99,32 @@ r <- ask lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm' -sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity)) +-- | 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 -sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k 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 -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')) +-- | 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') @@ -110,4 +134,5 @@ -------------------------------------------------------------------------------- {-# DEPRECATED MonadAdjust "Use Adjustable instead" #-} +-- | Synonym for 'Adjustable' type MonadAdjust = Adjustable diff --git a/src/Reflex/BehaviorWriter/Base.hs b/src/Reflex/BehaviorWriter/Base.hs --- a/src/Reflex/BehaviorWriter/Base.hs +++ b/src/Reflex/BehaviorWriter/Base.hs @@ -1,6 +1,6 @@ {-| Module: Reflex.BehaviorWriter.Base -Description: Implementation of MonadBehaviorWriter +Description: Implementation of BehaviorWriter -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,20 +10,22 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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.Identity +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 @@ -36,6 +38,10 @@ 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 @@ -46,9 +52,23 @@ import Reflex.Requester.Class import Reflex.TriggerEvent.Class --- | A basic implementation of 'MonadBehaviorWriter'. +-- | A basic implementation of 'BehaviorWriter'. newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + -- 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. @@ -73,9 +93,6 @@ deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m) deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m) -instance MonadTrans (BehaviorWriterT t w) where - lift = BehaviorWriterT . lift - instance MonadRef m => MonadRef (BehaviorWriterT t w m) where type Ref (BehaviorWriterT t w m) = Ref m newRef = lift . newRef @@ -89,7 +106,7 @@ newEventWithTrigger = lift . newEventWithTrigger newFanEventWithTrigger f = lift $ newFanEventWithTrigger f -instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where +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 diff --git a/src/Reflex/BehaviorWriter/Class.hs b/src/Reflex/BehaviorWriter/Class.hs --- a/src/Reflex/BehaviorWriter/Class.hs +++ b/src/Reflex/BehaviorWriter/Class.hs @@ -1,26 +1,29 @@ {-| Module: Reflex.BehaviorWriter.Class -Description: This module defines the 'MonadBehaviorWriter' class +Description: This module defines the 'BehaviorWriter' class -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.BehaviorWriter.Class - ( MonadBehaviorWriter (..) + ( MonadBehaviorWriter + , BehaviorWriter(..) ) where import Control.Monad.Reader (ReaderT, lift) import Reflex.Class (Behavior) --- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior' +{-# 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) => MonadBehaviorWriter t w m | m -> t w where +class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where tellBehavior :: Behavior t w -> m () -instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where +instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where tellBehavior = lift . tellBehavior diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -17,31 +16,38 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif +{-# LANGUAGE Trustworthy #-} --- | 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 +-- 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 Reflex.Patch + ( 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 @@ -56,6 +62,7 @@ , alignEventWithMaybe -- ** Breaking up 'Event's , splitE + , fan , fanEither , fanThese , fanMap @@ -80,6 +87,7 @@ , gate -- ** Combining 'Dynamic's , distributeDMapOverDynPure + , distributeDMapOverDynPureG , distributeListOverDyn , distributeListOverDynWith , zipDyn @@ -133,8 +141,10 @@ -- * Unsafe functions , unsafeDynamic , unsafeMapIncremental - -- * 'FunctorMaybe' - , FunctorMaybe (..) + -- * '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 @@ -144,10 +154,11 @@ , ffor2 , ffor3 -- * Deprecated functions - , appendEvents - , onceE - , sequenceThese + , switchPromptly + , switchPromptOnly + -- * "Cheap" functions , fmapMaybeCheap + , mapMaybeCheap , fmapCheap , fforCheap , fforMaybeCheap @@ -155,13 +166,24 @@ , tagCheap , mergeWithCheap , mergeWithCheap' - , switchPromptly - , switchPromptOnly -- * 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 @@ -173,29 +195,33 @@ import Data.Bifunctor import Data.Coerce import Data.Default -import Data.Dependent.Map (DMap, DSum (..)) +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.FastMutableIntMap (PatchIntMap) +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, sconcat, stimes, (<>)) -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Semigroup (Semigroup (..)) +import Data.Some (Some(Some)) import Data.String import Data.These import Data.Type.Coercion -import Reflex.FunctorMaybe -import Reflex.Patch -import qualified Reflex.Patch.MapWithMove as PatchMapWithMove +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) @@ -213,25 +239,25 @@ ) => 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 :: * -> * + 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 :: * -> * + 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 :: * -> * + 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 :: * -> * + data Incremental t :: Type -> Type -- | A monad for doing complex push-based calculations efficiently - type PushM t :: * -> * + type PushM t :: Type -> Type -- | A monad for doing complex pull-based calculations efficiently - type PullM t :: * -> * + type PullM t :: Type -> Type -- | An 'Event' with no occurrences never :: Event t a -- | Create a 'Behavior' that always has the given value @@ -248,16 +274,21 @@ -- | 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 :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --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 Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it + + --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 + -- | 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 @@ -271,9 +302,14 @@ -- that value. unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p -- | Create a merge whose parents can change over time - mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) + 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 - mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) + 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' @@ -289,10 +325,28 @@ -- | 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 @@ -308,6 +362,12 @@ 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'; @@ -360,27 +420,99 @@ -- | 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 -accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p) +-- | 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 -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) + +-- | 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 -accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p) + +-- | 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 -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) + +-- | 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' -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) + +-- | 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 -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) + +-- | 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 -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) + +-- | 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 -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) + +-- | 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' @@ -388,9 +520,10 @@ return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- holdIncremental z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + 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' @@ -399,18 +532,31 @@ -- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a -- key. This is much more efficient than filtering for each key with --- 'fmapMaybe'. +-- '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 'fmapMaybe' to select only the relevant + -- (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 } -------------------------------------------------------------------------------- @@ -426,6 +572,7 @@ 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 @@ -436,6 +583,7 @@ 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 @@ -446,6 +594,7 @@ 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 @@ -456,6 +605,7 @@ 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 @@ -466,6 +616,7 @@ 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 @@ -476,6 +627,7 @@ holdIncremental a0 = lift . holdIncremental a0 buildDynamic a0 = lift . buildDynamic a0 headE = lift . headE + now = lift now -------------------------------------------------------------------------------- -- Convenience functions @@ -524,12 +676,17 @@ 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. - return = constant +#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 - mappend a b = pull $ liftM2 mappend (sample a) (sample b) mconcat = pull . fmap mconcat . mapM sample instance (Reflex t, Num a) => Num (Behavior t a) where @@ -541,41 +698,47 @@ negate = fmap negate signum = fmap signum -instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where - a <> b = pull $ liftM2 (<>) (sample a) (sample b) - sconcat = pull . fmap sconcat . mapM sample -#if MIN_VERSION_semigroups(0,17,0) - stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif +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 (-) --- | Flipped version of 'fmapMaybe'. -fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b -fforMaybe = flip fmapMaybe +-- | 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. --- Relies on 'fforMaybe'. -ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a -ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing +ffilter :: Filterable f => (a -> Bool) -> f a -> f a +ffilter = W.filter -- | Filter 'Left's from 'f (Either a b)' into 'a'. -filterLeft :: FunctorMaybe f => f (Either a b) -> f a -filterLeft = fmapMaybe (either Just (const Nothing)) +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 :: FunctorMaybe f => f (Either a b) -> f b -filterRight = fmapMaybe (either (const Nothing) Just) +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 (convenient interface to 'coincidence'). +-- | 'Event' intersection. Only occurs when both events are co-incident. instance Reflex t => Apply (Event t) where - evf <.> evx = coincidence (fmap (<$> evx) evf) + 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) @@ -583,14 +746,19 @@ instance Reflex t => Functor (Event t) where {-# INLINE fmap #-} - fmap f = fmapMaybe $ Just . f + 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 f = push $ return . f + 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 @@ -738,11 +906,7 @@ instance (Semigroup a, Reflex t) => Semigroup (Event t a) where (<>) = alignWith (mergeThese (<>)) sconcat = fmap sconcat . mergeList . toList -#if MIN_VERSION_semigroups(0,17,0) stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif instance (Semigroup a, Reflex t) => Monoid (Event t a) where mempty = never @@ -777,7 +941,12 @@ 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 + :: (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 @@ -807,7 +976,7 @@ fanEither e = let justLeft = either Just (const Nothing) justRight = either (const Nothing) Just - in (fmapMaybe justLeft e, fmapMaybe justRight e) + 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'. @@ -819,7 +988,7 @@ that (That y) = Just y that (These _ y) = Just y that _ = Nothing - in (fmapMaybe this e, fmapMaybe that e) + in (mapMaybe this e, mapMaybe that e) -- | Split the event into an 'EventSelector' that allows efficient selection of -- the individual 'Event's. @@ -894,6 +1063,9 @@ 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 @@ -918,8 +1090,25 @@ 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 @@ -959,27 +1148,31 @@ instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where (<>) = zipDynWith (<>) -#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 (Dynamic t a) where mconcat = distributeListOverDynWith mconcat mempty = constDyn mempty - mappend = zipDynWith mappend -- | 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 dm = case DMap.toList dm of +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] -> fmap (DMap.singleton k . Identity) v + [k :=> v] -> DMap.singleton k <$> nt v _ -> - let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm - edmPre = merge $ DMap.map updated dm + 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 @@ -991,21 +1184,32 @@ -- | 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 (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..] +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 + _ -> 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 = - fmapMaybe (f <=< dmapToThese) - $ merge - $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +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 @@ -1023,7 +1227,10 @@ 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 @@ -1035,9 +1242,9 @@ -> 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.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv' + key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv' let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case - Some.This oldKey -> case newKey `geq` oldKey of + Some oldKey -> case newKey `geq` oldKey of Just Refl -> return Nothing Nothing -> do newInner <- filterEventKey newKey kv' @@ -1073,26 +1280,94 @@ 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) -accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a) +-- | 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 -accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a) + +-- | 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 -accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a) + +-- | 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 -accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a) + +-- | 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' -mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c) + +-- | 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 -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) + +-- | 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 -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) + +-- | 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 -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) + +-- | 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' @@ -1100,18 +1375,42 @@ return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- holdDyn z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + 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 + :: (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 + :: (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 + :: (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 @@ -1120,16 +1419,42 @@ 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 + :: (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 + :: (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 + :: (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 @@ -1139,8 +1464,8 @@ return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- hold z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + 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'. @@ -1284,38 +1609,70 @@ -- 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 f = pushCheap $ return . f +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 fmapMaybeCheap +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 = @@ -1328,31 +1685,11 @@ -- Deprecated functions -------------------------------------------------------------------------------- --- | 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'. -{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-} -appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a -appendEvents = alignWith $ mergeThese mappend - --- | Alias for 'headE' -{-# DEPRECATED onceE "Use 'headE' instead" #-} -onceE :: MonadHold t m => Event t a -> m (Event t a) -onceE = headE - --- | Run both sides of a 'These' monadically, combining the results. -{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-} -#ifdef USE_TEMPLATE_HASKELL -{-# ANN sequenceThese "HLint: ignore Use fmap" #-} -#endif -sequenceThese :: Monad m => These (m a) (m b) -> m (These a b) -sequenceThese t = case t of - This ma -> fmap This ma - These ma mb -> liftM2 These ma mb - That mb -> fmap That mb - {-# 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 diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -7,15 +7,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + +-- | +-- Module: +-- Reflex.Collection module Reflex.Collection ( -- * Widgets on Collections listHoldWithKey , listWithKey - , listWithKey' , listWithKeyShallowDiff , listViewWithKey , selectViewListWithKey @@ -25,7 +25,15 @@ , simpleList ) where -import Control.Monad.Identity +#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) @@ -33,11 +41,18 @@ 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) @@ -62,7 +77,7 @@ --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) + . (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)) @@ -94,16 +109,7 @@ , tag (current vals) postBuild ] listHoldWithKey Map.empty changeVals $ \k v -> - mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k) - -{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-} -listWithKey' - :: (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)) -listWithKey' = listWithKeyShallowDiff + 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' @@ -127,7 +133,7 @@ Nothing -> Just Nothing -- We don't want to let spurious re-creations of items through - Just _ -> Nothing + Just _ -> Nothing listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) @@ -144,7 +150,7 @@ -- 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) + :: (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)) @@ -152,7 +158,7 @@ switch . fmap mergeMap <$> listViewWithKey' vals mkChild listViewWithKey' - :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) + :: (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)) @@ -162,7 +168,7 @@ -- selected at any time. selectViewListWithKey :: forall t m k v a - . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) + . (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) @@ -182,9 +188,11 @@ 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) + . (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) @@ -202,7 +210,7 @@ -- 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) + :: (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)) @@ -210,7 +218,7 @@ -- | Create a dynamically-changing set of widgets from a Dynamic list. simpleList - :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) + :: (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]) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -14,11 +14,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif --- | This module contains various functions for working with 'Dynamic' values. --- 'Dynamic' and its primitives have been moved to the 'Reflex' class. + +-- | +-- 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 @@ -49,10 +51,12 @@ , foldDynMaybe , foldDynMaybeM , joinDynThroughMap + , joinDynThroughIntMap , traceDyn , traceDynWith , splitDynPure , distributeMapOverDynPure + , distributeIntMapOverDynPure , distributeDMapOverDynPure , distributeListOverDynPure , Demux @@ -70,48 +74,33 @@ , distributeFHListOverDynPure -- * Unsafe , unsafeDynamic - -- * Deprecated functions - , apDyn - , attachDyn - , attachDynWith - , attachDynWithMaybe - , collectDyn - , combineDyn - , distributeDMapOverDyn - , distributeFHListOverDyn - , forDyn - , getDemuxed - , joinDyn - , mapDyn - , mconcatDyn - , nubDyn - , splitDyn - , tagDyn - , uniqDyn - , uniqDynBy ) where -import Data.Functor.Compose -import Data.Functor.Misc -import Reflex.Class - -import Control.Applicative ((<*>)) -import Control.Monad import Control.Monad.Fix import Control.Monad.Identity import Data.Align import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..)) -import Data.Functor.Product -import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) +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.Monoid hiding (Product) import Data.These +import Data.Type.Equality ((:~:) (..)) -import Debug.Trace +import Debug.Trace (trace) +#if !MIN_VERSION_base(4,18,0) +import Control.Monad +import Data.Monoid ((<>)) +#endif + +import Reflex.Class + -- | 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) @@ -218,26 +207,28 @@ distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v) distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap +-- | 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 + -- | 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 = - fmap (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 +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 = joinDyn . fmap distributeMapOverDynPure +joinDynThroughMap = (distributeMapOverDynPure =<<) +-- | 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. @@ -318,6 +309,8 @@ 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) @@ -325,6 +318,9 @@ 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 @@ -339,6 +335,7 @@ inner' <- filterEventKey k (updated d) inner <- holdDyn v inner' return $ k :=> Compose inner + -------------------------------------------------------------------------------- -- Demux -------------------------------------------------------------------------------- @@ -352,7 +349,7 @@ -- -- > demuxed (demux d) k === fmap (== k) d -- --- However, the when getDemuxed is used multiple times, the complexity is only +-- 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) @@ -385,7 +382,7 @@ -- | 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::[*]) where +data HList (l::[Type]) where HNil :: HList '[] HCons :: e -> HList l -> HList (e ': l) @@ -441,7 +438,7 @@ deriving instance Eq (HListPtr l a) deriving instance Ord (HListPtr l a) -fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f +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 (HListPtr l') f] go = \case @@ -481,8 +478,8 @@ -- | Indicates that all elements in a type-level list are applications of the -- same functor. -class AllAreFunctors (f :: a -> *) (l :: [a]) where - type FunctorList f l :: [*] +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) @@ -506,7 +503,7 @@ -- | 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 --- consitutent 'Dynamic's. +-- constituent 'Dynamic's. collectDynPure :: ( RebuildSortedHList (HListElems b) , IsHList a, IsHList b , AllAreFunctors (Dynamic t) (HListElems b) @@ -517,7 +514,7 @@ -- | 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 @@ -547,134 +544,3 @@ #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 - --------------------------------------------------------------------------------- --- Deprecated functions --------------------------------------------------------------------------------- - --- | Map a function over a 'Dynamic'. -{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-} -mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) -mapDyn f = return . fmap f - --- | Flipped version of 'mapDyn'. -{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-} -forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) -forDyn a = return . ffor a - --- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value --- of the tuple. -{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-} -splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) -splitDyn = return . splitDynPure - --- | Merge the 'Dynamic' values using their 'Monoid' instance. -{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-} -mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) -mconcatDyn = return . mconcat - --- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'. -{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-} -distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) -distributeDMapOverDyn = return . distributeDMapOverDynPure - --- | 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. -{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-} -combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) -combineDyn f a b = return $ zipDynWith f a b - --- | A psuedo applicative version of ap for 'Dynamic'. Example useage: --- --- > do --- > person <- Person `mapDyn` dynFirstName --- > `apDyn` dynListName --- > `apDyn` dynAge --- > `apDyn` dynAddress -{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-} -#ifdef USE_TEMPLATE_HASKELL -{-# ANN apDyn "HLint: ignore Use fmap" #-} -#endif -apDyn :: forall t m a b. (Reflex t, Monad m) - => m (Dynamic t (a -> b)) - -> Dynamic t a - -> m (Dynamic t b) -apDyn m a = fmap (<*> a) m - ---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 --- | This function no longer needs to be monadic, so it has been replaced by --- 'demuxed', which is pure. -{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-} -getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) -getDemuxed d = return . demuxed d - --- | This function no longer needs to be monadic, so it has been replaced by --- 'distributeFHListOverDynPure', which is pure. -{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} -distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) -distributeFHListOverDyn = return . distributeFHListOverDynPure - --- | This function no longer needs to be monadic, so it has been replaced by --- 'collectDynPure', which is pure. -{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} -collectDyn :: ( RebuildSortedHList (HListElems b) - , IsHList a, IsHList b - , AllAreFunctors (Dynamic t) (HListElems b) - , Reflex t, Monad m - , HListElems a ~ FunctorList (Dynamic t) (HListElems b) - ) => a -> m (Dynamic t b) -collectDyn = return . collectDynPure - --- | This function has been renamed to 'tagPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-} -tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a -tagDyn = tagPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-} -attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) -attachDyn = attachPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDynWith' to clarify its --- semantics. -{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-} -attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c -attachDynWith = attachPromptlyDynWith - --- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify --- its semantics. -{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-} -attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c -attachDynWithMaybe = attachPromptlyDynWithMaybe - --- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s --- current value will always be equal to the current value's current value, and --- will change whenever either the inner or the outer (or both) values change. -{-# DEPRECATED joinDyn "Use 'join' instead" #-} -joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a -joinDyn = join - --- | WARNING: This function is only pure if @a@'s 'Eq' instance tests --- representational equality. Use 'holdUniqDyn' instead, which is pure in all --- circumstances. Also, note that, unlike 'nub', this function does not prevent --- all recurrences of a value, only consecutive recurrences. -{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -nubDyn = uniqDyn - --- | WARNING: This function is only pure if @a@'s 'Eq' instance tests --- representational equality. Use 'holdUniqDyn' instead, which is pure in all --- circumstances. -{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -uniqDyn = uniqDynBy (==) - --- | WARNING: This function is impure. Use 'holdUniqDynBy' instead. -{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a -uniqDynBy eq d = - let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d) - in unsafeDynamic (current d) e' diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -5,31 +5,29 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | Template Haskell helper functions for building complex 'Dynamic' values. module Reflex.Dynamic.TH ( qDynPure , unqDyn , mkDynPure - -- * Deprecated functions - , qDyn - , mkDyn ) where -import Reflex.Dynamic - import Control.Monad.State import Data.Data import Data.Generics -import Data.Monoid import qualified Language.Haskell.Exts as Hs import qualified Language.Haskell.Meta.Syntax.Translate as Hs import Language.Haskell.TH import Language.Haskell.TH.Quote import qualified Language.Haskell.TH.Syntax as TH +#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@ @@ -47,9 +45,15 @@ _ -> gmapM f d (e', exprsReversed) <- runStateT (gmapM f e) [] let exprs = reverse exprsReversed - arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs - param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs - [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(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. @@ -84,11 +88,10 @@ } 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 -> 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 -#if MIN_VERSION_haskell_src_exts(1,18,0) antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo antiE x = case x of Hs.SpliceExp l se -> @@ -96,35 +99,6 @@ Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v Hs.ParenSplice _ ps -> ps _ -> x -#else - 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 - _ -> x -#endif reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName'))) | modName == modName' && occName == occName' = 'unqMarker reinstateUnqDyn x = x - --------------------------------------------------------------------------------- --- Deprecated --------------------------------------------------------------------------------- - -{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-} --- | Like 'qDynPure', but wraps its result monadically using 'return'. This is --- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. -qDyn :: Q Exp -> Q Exp -qDyn qe = [| return $(qDynPure qe) |] - -{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-} --- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is --- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. -mkDyn :: QuasiQuoter -mkDyn = QuasiQuoter - { quoteExp = \s -> [| return $(mkDynExp s) |] - , quotePat = error "mkDyn: pattern splices are not supported" - , quoteType = error "mkDyn: type splices are not supported" - , quoteDec = error "mkDyn: declaration splices are not supported" - } diff --git a/src/Reflex/Dynamic/Uniq.hs b/src/Reflex/Dynamic/Uniq.hs --- a/src/Reflex/Dynamic/Uniq.hs +++ b/src/Reflex/Dynamic/Uniq.hs @@ -2,9 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | 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 @@ -14,8 +12,12 @@ , alreadyUniqDynamic ) where -import Control.Applicative (Applicative (..)) 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 @@ -101,5 +103,3 @@ instance Reflex t => Monad (UniqDynamic t) where UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f - _ >> b = b - return = pure diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -8,20 +8,23 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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.Identity +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 @@ -34,25 +37,26 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Semigroup 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 Reflex.Patch.MapWithMove as MapWithMove +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 -instance MonadTrans (DynamicWriterT t w) where - lift = DynamicWriterT . lift - 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) @@ -87,9 +91,23 @@ 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 'MonadDynamicWriter'. +-- | A basic implementation of 'DynamicWriter'. newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + -- 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) @@ -110,12 +128,12 @@ -- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided -- along with the result of the action. -runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w) +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) => MonadDynamicWriter t w (DynamicWriterT t w m) where +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 @@ -140,12 +158,16 @@ 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, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where +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') @@ -154,7 +176,7 @@ 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)), MonadFix m, Monoid w, Reflex t, MonadHold t m) +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) @@ -181,7 +203,7 @@ 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)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p') +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) @@ -205,7 +227,7 @@ return (liftedResult0, liftedResult') -- | Map a function over the output of a 'DynamicWriterT'. -withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m) +withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m) => (w -> w') -> DynamicWriterT t w m a -> DynamicWriterT t w' m a diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs --- a/src/Reflex/DynamicWriter/Class.hs +++ b/src/Reflex/DynamicWriter/Class.hs @@ -1,24 +1,26 @@ --- | This module defines the 'MonadDynamicWriter' class. +-- | This module defines the 'DynamicWriter' class. +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.DynamicWriter.Class - ( MonadDynamicWriter (..) + ( 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) => MonadDynamicWriter t w m | m -> t w where +class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where tellDyn :: Dynamic t w -> m () -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where +instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where tellDyn = lift . tellDyn - diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -10,9 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.EventWriter.Base ( EventWriterT (..) , runEventWriterT @@ -25,7 +23,7 @@ import Reflex.Adjustable.Class import Reflex.Class import Reflex.EventWriter.Class (EventWriter, tellEvent) -import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn) +import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn) import Reflex.Host.Class import Reflex.PerformEvent.Class import Reflex.PostBuild.Class @@ -33,14 +31,18 @@ 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, DSum (..)) +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 (..)) @@ -52,7 +54,7 @@ import Data.Semigroup import Data.Some (Some) import Data.Tuple -import Data.Type.Equality hiding (apply) +import Data.Type.Equality import Unsafe.Coerce @@ -96,7 +98,20 @@ -- | A basic implementation of 'EventWriter'. newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a } - deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) + 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) @@ -116,9 +131,6 @@ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old } -instance MonadTrans (EventWriterT t w) where - lift = EventWriterT . lift - instance MonadSample t m => MonadSample t (EventWriterT t w m) where sample = lift . sample @@ -133,6 +145,8 @@ 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' @@ -278,7 +292,7 @@ askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where +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 diff --git a/src/Reflex/EventWriter/Class.hs b/src/Reflex/EventWriter/Class.hs --- a/src/Reflex/EventWriter/Class.hs +++ b/src/Reflex/EventWriter/Class.hs @@ -2,17 +2,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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) diff --git a/src/Reflex/FastWeak.hs b/src/Reflex/FastWeak.hs --- a/src/Reflex/FastWeak.hs +++ b/src/Reflex/FastWeak.hs @@ -6,14 +6,18 @@ {-# LANGUAGE JavaScriptFFI #-} #endif --- | '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). +-- | +-- 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 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. +-- 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 @@ -147,6 +151,16 @@ -- | 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 diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -1,43 +1,45 @@ --- | This module defines the FunctorMaybe class, which extends Functors with the --- ability to delete values. +{-# 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 qualified Data.IntMap as IntMap import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe +#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'@. Also similar is the --- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@, --- and e.g. 'Event' is instance of neither. --- --- A definition of 'fmapMaybe' must satisfy the following laws: --- --- [/identity/] --- @'fmapMaybe' 'Just' ≡ 'id'@ --- --- [/composition/] --- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@ +-- 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 --- | @fmapMaybe = (=<<) instance FunctorMaybe Maybe where - fmapMaybe = (=<<) + fmapMaybe = mapMaybe --- | @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 = Map.mapMaybe + fmapMaybe = mapMaybe instance FunctorMaybe IntMap where - fmapMaybe = IntMap.mapMaybe + fmapMaybe = mapMaybe diff --git a/src/Reflex/Host/Class.hs b/src/Reflex/Host/Class.hs --- a/src/Reflex/Host/Class.hs +++ b/src/Reflex/Host/Class.hs @@ -4,15 +4,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | 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. @@ -43,6 +41,7 @@ import Control.Monad.Trans.Writer (WriterT) import Data.Dependent.Sum (DSum (..)) import Data.GADT.Compare +import Data.Kind (Type) -- | Framework implementation support class for the reflex implementation -- represented by @t@. @@ -53,9 +52,9 @@ , MonadFix (HostFrame t) , MonadSubscribeEvent t (HostFrame t) ) => ReflexHost t where - type EventTrigger t :: * -> * - type EventHandle t :: * -> * - type HostFrame t :: * -> * + 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 @@ -115,7 +114,7 @@ , MonadSample t (ReadPhase m) , MonadHold t (ReadPhase m) ) => MonadReflexHost t m | m -> t where - type ReadPhase m :: * -> * + 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 diff --git a/src/Reflex/Host/Headless.hs b/src/Reflex/Host/Headless.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Host/Headless.hs @@ -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 diff --git a/src/Reflex/Network.hs b/src/Reflex/Network.hs --- a/src/Reflex/Network.hs +++ b/src/Reflex/Network.hs @@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + +-- | +-- Module: +-- Reflex.Network +-- Description: +-- This module provides combinators for building FRP graphs/networks and modifying them dynamically. module Reflex.Network ( networkView , networkHold @@ -14,18 +17,19 @@ import Reflex.NotReady.Class import Reflex.PostBuild.Class --- | 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 'switchPromptly'). +-- | 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. +-- | 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 diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -3,19 +3,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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) @@ -39,6 +39,10 @@ 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 @@ -48,6 +52,10 @@ 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 diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs deleted file mode 100644 --- a/src/Reflex/Optimizer.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | This module provides a GHC plugin designed to improve code that uses --- Reflex. Currently, it just adds an INLINABLE pragma to any top-level --- definition that doesn't have an explicit inlining pragma. In the future, --- additional optimizations are likely to be added. -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -module Reflex.Optimizer - ( plugin - ) where - -#ifdef ghcjs_HOST_OS -import Plugins -#else -import Control.Arrow -import CoreMonad -import Data.String -import GhcPlugins - -#if MIN_VERSION_base(4,9,0) -import Prelude hiding ((<>)) -#endif - -#endif - -#ifdef ghcjs_HOST_OS - --- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used. -plugin :: Plugin -plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS." - -#else - --- | The GHC plugin itself. See "GhcPlugins" for more details. -plugin :: Plugin -plugin = defaultPlugin { installCoreToDos = install } - -install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install [] p = do - liftIO $ putStrLn $ showSDocUnsafe $ ppr p - let f = \case - simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl] - x -> [x] - return $ makeInlinable : concatMap f p -install options@(_:_) p = do - warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options" - install [] p - -makeInlinable :: CoreToDo -makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do - let f v = setIdInfo v $ let i = idInfo v in - setInlinePragInfo i $ let p = inlinePragInfo i in - if isDefaultInlinePragma p - then defaultInlinePragma { inl_inline = Inlinable } - else p - newBinds = flip map (mg_binds modGuts) $ \case - NonRec b e -> NonRec (f b) e - Rec bes -> Rec $ map (first f) bes - return $ modGuts { mg_binds = newBinds } - -#endif diff --git a/src/Reflex/Patch.hs b/src/Reflex/Patch.hs deleted file mode 100644 --- a/src/Reflex/Patch.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | This module defines the 'Patch' class, which is used by Reflex to manage --- changes to 'Reflex.Class.Incremental' values. -{-# LANGUAGE TypeFamilies #-} -module Reflex.Patch - ( module Reflex.Patch - , module X - ) where - -import Reflex.Patch.Class as X -import Reflex.Patch.DMap as X hiding (getDeletions) -import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove, - patchDMapWithMoveToPatchMapWithMoveWith, - traversePatchDMapWithMoveWithKey, unPatchDMapWithMove, - unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith) -import Reflex.Patch.IntMap as X hiding (getDeletions) -import Reflex.Patch.Map as X -import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, - patchMapWithMoveNewElementsMap, unPatchMapWithMove, - unsafePatchMapWithMove) - -import Data.Semigroup (Semigroup (..), (<>)) - ----- Patches based on commutative groups - --- | A 'Group' is a 'Monoid' where every element has an inverse. -class (Semigroup q, Monoid q) => Group q where - negateG :: q -> q - (~~) :: q -> q -> q - r ~~ s = r <> negateG s - --- | An 'Additive' 'Semigroup' is one where (<>) is commutative -class Semigroup q => Additive q where - --- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type. -newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p } - -instance Additive p => Patch (AdditivePatch p) where - type PatchTarget (AdditivePatch p) = p - apply (AdditivePatch p) q = Just $ p <> q diff --git a/src/Reflex/Patch/Class.hs b/src/Reflex/Patch/Class.hs deleted file mode 100644 --- a/src/Reflex/Patch/Class.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} --- | The interface for types which represent changes made to other types -module Reflex.Patch.Class where - -import Control.Monad.Identity -import Data.Maybe -import Data.Semigroup - --- | A 'Patch' type represents a kind of change made to a datastructure. --- --- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey --- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@. -class Patch p where - type PatchTarget p :: * - -- | Apply the patch @p a@ to the value @a@. If no change is needed, return - -- 'Nothing'. - apply :: p -> PatchTarget p -> Maybe (PatchTarget p) - --- | Apply a 'Patch'; if it does nothing, return the original value -applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p -applyAlways p t = fromMaybe t $ apply p t - --- | 'Identity' can be used as a 'Patch' that always fully replaces the value -instance Patch (Identity a) where - type PatchTarget (Identity a) = a - apply (Identity a) _ = Just a - --- | Like '(.)', but composes functions that return patches rather than --- functions that return new values. The Semigroup instance for patches must --- apply patches right-to-left, like '(.)'. -composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p -composePatchFunctions g f a = - let fp = f a - in g (applyAlways fp a) <> fp diff --git a/src/Reflex/Patch/DMap.hs b/src/Reflex/Patch/DMap.hs deleted file mode 100644 --- a/src/Reflex/Patch/DMap.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} --- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions. -module Reflex.Patch.DMap where - -import Reflex.Patch.Class -import Reflex.Patch.IntMap -import Reflex.Patch.Map - -import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) -import qualified Data.Dependent.Map as DMap -import Data.Functor.Constant -import Data.Functor.Misc -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Semigroup (Semigroup (..)) -import Data.Some (Some) - --- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted. --- Insertions are represented as @'ComposeMaybe' (Just value)@, --- while deletions are represented as @'ComposeMaybe' Nothing@. -newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) } - -deriving instance GCompare k => Semigroup (PatchDMap k v) - -deriving instance GCompare k => Monoid (PatchDMap k v) - --- | Apply the insertions or deletions to a given 'DMap'. -instance GCompare k => Patch (PatchDMap k v) where - type PatchTarget (PatchDMap k v) = DMap k v - apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? - where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff - deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff - nothingToJust = \case - Nothing -> Just $ Constant () - Just _ -> Nothing - --- | Map a function @v a -> v' a@ over any inserts/updates in the given --- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. -mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v' -mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p - --- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given --- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. -traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v') -traversePatchDMap f = traversePatchDMapWithKey $ const f - --- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates --- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. -traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v') -traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p - --- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function --- @v a -> v'@ to weaken each value contained in the patch. -weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v' -weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p - --- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of --- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@. -patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v' -patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p - --- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@. -const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v' -const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p - where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v') - g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) - --- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@. -const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f -const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p - where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f) - g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) - --- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'. -getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v' -getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs deleted file mode 100644 --- a/src/Reflex/Patch/DMapWithMove.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and --- move values between keys. -module Reflex.Patch.DMapWithMove where - -import Reflex.Patch.Class -import Reflex.Patch.MapWithMove (PatchMapWithMove (..)) -import qualified Reflex.Patch.MapWithMove as MapWithMove - -import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Sum (EqTag (..)) -import Data.Functor.Constant -import Data.Functor.Misc -import Data.Functor.Product -import Data.GADT.Compare (GEq (..)) -import Data.GADT.Show (GShow, gshow) -import qualified Data.Map as Map -import Data.Maybe -import Data.Semigroup (Semigroup (..), (<>)) -import Data.Some (Some) -import qualified Data.Some as Some -import Data.These - --- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and --- destinations. --- --- Invariants: --- --- * A key should not move to itself. --- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@) -newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v)) - --- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key --- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move. -data NodeInfo k v a = NodeInfo - { _nodeInfo_from :: !(From k v a) - -- ^Change applying to the current key, be it an insert, move, or delete. - , _nodeInfo_to :: !(To k a) - -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'. - } - deriving (Show) - --- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a --- key (@From_Delete@), or moving a key (@From_Move@). -data From (k :: a -> *) (v :: a -> *) :: a -> * where - -- |Insert a new or update an existing key with the given value @v a@ - From_Insert :: v a -> From k v a - -- |Delete the existing key - From_Delete :: From k v a - -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@, - -- usually but not necessarily with @From_Delete@. - From_Move :: !(k a) -> From k v a - deriving (Show, Read, Eq, Ord) - --- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other --- operation. -type To = ComposeMaybe - --- |Test whether a 'PatchDMapWithMove' satisfies its invariants. -validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool -validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove - --- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid. -validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String] -validationErrorsForPatchDMapWithMove m = - noSelfMoves <> movesBalanced - where - noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m - selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side" - selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side" - selfMove _ = Nothing - movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m - unbalancedMove (dst :=> NodeInfo (From_Move src) _) = - case DMap.lookup src m of - Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch" - Just (NodeInfo _ (ComposeMaybe (Just dst'))) -> - if isNothing (dst' `geq` dst) - then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead" - else Nothing - _ -> - Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key" - unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) = - case DMap.lookup dst m of - Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch" - Just (NodeInfo (From_Move src') _) -> - if isNothing (src' `geq` src) - then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead" - else Nothing - - _ -> - Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving" - unbalancedMove _ = Nothing - --- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations. -instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where - PatchDMapWithMove a == PatchDMapWithMove b = a == b - --- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 -data Pair1 f g a = Pair1 (f a) (g a) - --- |Helper data structure used for composing patches using the monoid instance. -data Fixup k v a - = Fixup_Delete - | Fixup_Update (These (From k v a) (To k a)) - --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance GCompare k => Semigroup (PatchDMapWithMove k v) where - PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m - where - connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb - h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)] - h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of - (Just toAfter, From_Move fromBefore) - | isJust $ fromBefore `geq` toAfter - -> [toAfter :=> Fixup_Delete] - | otherwise - -> [ toAfter :=> Fixup_Update (This editBefore) - , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter)) - ] - (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map - (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)] - (Nothing, _) -> [] - mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete - mergeFixups _ (Fixup_Update a) (Fixup_Update b) - | This x <- a, That y <- b - = Fixup_Update $ These x y - | That y <- a, This x <- b - = Fixup_Update $ These x y - mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups" - fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections - combineNodeInfos _ nia nib = NodeInfo - { _nodeInfo_from = _nodeInfo_from nia - , _nodeInfo_to = _nodeInfo_to nib - } - applyFixup _ ni = \case - Fixup_Delete -> Nothing - Fixup_Update u -> Just $ NodeInfo - { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u - , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u - } - m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups - getHere :: These a b -> Maybe a - getHere = \case - This a -> Just a - These a _ -> Just a - That _ -> Nothing - getThere :: These a b -> Maybe b - getThere = \case - This _ -> Nothing - These _ b -> Just b - That b -> Just b - --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance GCompare k => Monoid (PatchDMapWithMove k v) where - mempty = PatchDMapWithMove mempty - mappend = (<>) - -{- -mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v -PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src - where - getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself - removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing - removeRedundantDst _ a = Just a - f :: forall a. k a -> From k v a -> Maybe (From k v a) - f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of - From_Move fromKey -> getDstAction fromKey dstBefore - nonMove -> nonMove - dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore - getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m - removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing - removeRedundantSrc _ a = Just a - g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a) - g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of - ComposeMaybe Nothing -> ComposeMaybe Nothing - ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter - src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore --} - --- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'. -insertDMapKey :: k a -> v a -> PatchDMapWithMove k v -insertDMapKey k v = - PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing) - --- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to: --- --- @ --- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap)) --- @ -moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v -moveDMapKey src dst = case src `geq` dst of - Nothing -> PatchDMapWithMove $ DMap.fromList - [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing) - , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst) - ] - Just _ -> mempty - --- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: --- --- @ --- let aMay = DMap.lookup a dmap --- bMay = DMap.lookup b dmap --- in maybe id (DMap.insert a) (bMay `mplus` aMay) --- . maybe id (DMap.insert b) (aMay `mplus` bMay) --- . DMap.delete a . DMap.delete b $ dmap --- @ -swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v -swapDMapKey src dst = case src `geq` dst of - Nothing -> PatchDMapWithMove $ DMap.fromList - [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src) - , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst) - ] - Just _ -> mempty - --- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'. -deleteDMapKey :: k a -> PatchDMapWithMove k v -deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing - -{- -k1, k2 :: Const2 Int () () -k1 = Const2 1 -k2 = Const2 2 -p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity -p1 = moveDMapKey k1 k2 -p2 = moveDMapKey k2 k1 -p12 = p1 <> p2 -p21 = p2 <> p1 -p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2 -p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1 - -testPatchDMapWithMove = do - print p1 - print p2 - print $ p12 == deleteDMapKey k1 - print $ p21 == deleteDMapKey k2 - print $ p12Slow == deleteDMapKey k1 - print $ p21Slow == deleteDMapKey k2 - -dst (PatchDMapWithMove x _) = x -src (PatchDMapWithMove _ x) = x --} - --- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'. -unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v) -unPatchDMapWithMove (PatchDMapWithMove p) = p - --- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants. --- --- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked. -unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v -unsafePatchDMapWithMove = PatchDMapWithMove - --- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned --- otherwise @Left errors@. -patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v) -patchDMapWithMove dm = - case validationErrorsForPatchDMapWithMove dm of - [] -> Right $ unsafePatchDMapWithMove dm - errs -> Left errs - --- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@. -mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v' -mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ - DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p - where g :: forall a. From k v a -> From k v' a - g = \case - From_Insert v -> From_Insert $ f v - From_Delete -> From_Delete - From_Move k -> From_Move k - --- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. -traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') -traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f - --- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. -traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') -traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p - where g :: forall a. k a -> From k v a -> m (From k v' a) - g k = \case - From_Insert v -> From_Insert <$> f k v - From_Delete -> pure From_Delete - From_Move fromKey -> pure $ From_Move fromKey - --- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@. -nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a -nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } - --- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@. -nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a) -nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni - --- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to --- values. -weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v' -weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p - where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v' - g ni = MapWithMove.NodeInfo - { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of - From_Insert v -> MapWithMove.From_Insert $ f v - From_Delete -> MapWithMove.From_Delete - From_Move k -> MapWithMove.From_Move $ Some.This k - , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni) - } - --- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any --- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank. -patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v' -patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p - where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v' - g ni = MapWithMove.NodeInfo - { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of - From_Insert v -> MapWithMove.From_Insert $ f v - From_Delete -> MapWithMove.From_Delete - From_Move (Const2 k) -> MapWithMove.From_Move k - , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni) - } - --- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed --- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@. --- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith' -const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v' -const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p - where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v') - g (k, ni) = Const2 k :=> NodeInfo - { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of - MapWithMove.From_Insert v -> From_Insert $ f v - MapWithMove.From_Delete -> From_Delete - MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey - , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni - } - --- | Apply the insertions, deletions, and moves to a given 'DMap'. -instance GCompare k => Patch (PatchDMapWithMove k v) where - type PatchTarget (PatchDMapWithMove k v) = DMap k v - apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? - where insertions = DMap.mapMaybeWithKey insertFunc p - insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a) - insertFunc _ ni = case _nodeInfo_from ni of - From_Insert v -> Just v - From_Move k -> DMap.lookup k old - From_Delete -> Nothing - deletions = DMap.mapMaybeWithKey deleteFunc p - deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a) - deleteFunc _ ni = case _nodeInfo_from ni of - From_Delete -> Just $ Constant () - _ -> Nothing - --- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'. -getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k)) -getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p - where f _ v ni = Pair v $ _nodeInfo_to ni diff --git a/src/Reflex/Patch/IntMap.hs b/src/Reflex/Patch/IntMap.hs deleted file mode 100644 --- a/src/Reflex/Patch/IntMap.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} --- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for --- insert/update or delete of associations. -module Reflex.Patch.IntMap where - -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Data.Maybe -import Data.Semigroup -import Reflex.Patch.Class - --- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping. --- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update --- and @Nothing@ means delete. -newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid) - --- | Apply the insertions or deletions to a given 'IntMap'. -instance Patch (PatchIntMap a) where - type PatchTarget (PatchIntMap a) = IntMap a - apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $ - let removes = IntMap.filter isNothing p - adds = IntMap.mapMaybe id p - in IntMap.union adds $ v `IntMap.difference` removes - --- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. --- If the same key is modified by both patches, the one on the left will take --- precedence. -instance Semigroup (PatchIntMap v) where - PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map - -- PatchMap is idempotent, so stimes n is id for every n -#if MIN_VERSION_semigroups(0,17,0) - stimes = stimesIdempotentMonoid -#else - times1p n x = case compare n 0 of - LT -> error "stimesIdempotentMonoid: negative multiplier" - EQ -> mempty - GT -> x -#endif - --- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@ --- (that is, all inserts/updates), producing a @PatchIntMap b@. -mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b -mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m - --- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@ --- (that is, all inserts/updates), producing a @f (PatchIntMap b)@. -traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b) -traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m - --- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@. -patchIntMapNewElements :: PatchIntMap a -> [a] -patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m - --- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all --- the inserts/updates in the given patch. -patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a -patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m - --- | Subset the given @'IntMap' a@ to contain only the keys that would be --- deleted by the given @'PatchIntMap' a@. -getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v' -getDeletions (PatchIntMap m) v = IntMap.intersection v m diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs deleted file mode 100644 --- a/src/Reflex/Patch/Map.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} --- | 'Patch'es on 'Map' that consist only of insertions (including overwrites) --- and deletions -module Reflex.Patch.Map where - -import Reflex.Patch.Class - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Semigroup - --- | A set of changes to a 'Map'. Any element may be inserted/updated or --- deleted. Insertions are represented as values wrapped in 'Just', while --- deletions are represented as 'Nothing's -newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } - deriving (Show, Read, Eq, Ord) - --- | Apply the insertions or deletions to a given 'Map'. -instance Ord k => Patch (PatchMap k v) where - type PatchTarget (PatchMap k v) = Map k v - {-# INLINABLE apply #-} - apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? - where insertions = Map.mapMaybeWithKey (const id) p - deletions = Map.mapMaybeWithKey (const nothingToJust) p - nothingToJust = \case - Nothing -> Just () - Just _ -> Nothing - --- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. --- If the same key is modified by both patches, the one on the left will take --- precedence. -instance Ord k => Semigroup (PatchMap k v) where - PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map - -- PatchMap is idempotent, so stimes n is id for every n -#if MIN_VERSION_semigroups(0,17,0) - stimes = stimesIdempotentMonoid -#else - times1p n x = case compare n 0 of - LT -> error "stimesIdempotentMonoid: negative multiplier" - EQ -> mempty - GT -> x -#endif - --- | The empty 'PatchMap' contains no insertions or deletions -instance Ord k => Monoid (PatchMap k v) where - mempty = PatchMap mempty - mappend = (<>) - --- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert. --- Deletions are unaffected. -instance Functor (PatchMap k) where - fmap f = PatchMap . fmap (fmap f) . unPatchMap - --- | Returns all the new elements that will be added to the 'Map' -patchMapNewElements :: PatchMap k v -> [v] -patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p - --- | Returns all the new elements that will be added to the 'Map' -patchMapNewElementsMap :: PatchMap k v -> Map k v -patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs deleted file mode 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to --- another -module Reflex.Patch.MapWithMove where - -import Reflex.Patch.Class - -import Control.Arrow -import Control.Monad.State -import Data.Foldable -import Data.Function -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Semigroup (Semigroup (..), (<>)) -import qualified Data.Set as Set -import Data.These (These(..)) -import Data.Tuple - --- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ --- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@, --- and vice versa. There should never be any unpaired From/To keys. -newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable) - --- | Holds the information about each key: where its new value should come from, --- and where its old value should go to -data NodeInfo k v = NodeInfo - { _nodeInfo_from :: !(From k v) - -- ^ Where do we get the new value for this key? - , _nodeInfo_to :: !(To k) - -- ^ If the old value is being kept (i.e. moved rather than deleted or - -- replaced), where is it going? - } - deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - --- | Describe how a key's new value should be produced -data From k v - = From_Insert v -- ^ Insert the given value here - | From_Delete -- ^ Delete the existing value, if any, from here - | From_Move !k -- ^ Move the value here from the given key - deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - --- | Describe where a key's old value will go. If this is 'Just', that means --- the key's old value will be moved to the given other key; if it is 'Nothing', --- that means it will be deleted. -type To = Maybe - --- | Create a 'PatchMapWithMove', validating it -patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v) -patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing - where valid = forwardLinks == backwardLinks - forwardLinks = Map.mapMaybe _nodeInfo_to m - backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) -> - case _nodeInfo_from v of - From_Move from -> Just (from, to) - _ -> Nothing - --- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map' -patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v -patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo - { _nodeInfo_from = From_Insert v - , _nodeInfo_to = Nothing - } - --- | Extract the internal representation of the 'PatchMapWithMove' -unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v) -unPatchMapWithMove (PatchMapWithMove p) = p - --- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'. -insertMapKey :: k -> v -> PatchMapWithMove k v -insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing - --- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: --- --- @ --- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) --- @ -moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v -moveMapKey src dst - | src == dst = mempty - | otherwise = - PatchMapWithMove $ Map.fromList - [ (dst, NodeInfo (From_Move src) Nothing) - , (src, NodeInfo From_Delete (Just dst)) - ] - --- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: --- --- @ --- let aMay = Map.lookup a map --- bMay = Map.lookup b map --- in maybe id (Map.insert a) (bMay `mplus` aMay) --- . maybe id (Map.insert b) (aMay `mplus` bMay) --- . Map.delete a . Map.delete b $ map --- @ -swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v -swapMapKey src dst - | src == dst = mempty - | otherwise = - PatchMapWithMove $ Map.fromList - [ (dst, NodeInfo (From_Move src) (Just src)) - , (src, NodeInfo (From_Move dst) (Just dst)) - ] - --- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'. -deleteMapKey :: k -> PatchMapWithMove k v -deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing - --- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants. --- --- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked. -unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v -unsafePatchMapWithMove = PatchMapWithMove - --- | Apply the insertions, deletions, and moves to a given 'Map' -instance Ord k => Patch (PatchMapWithMove k v) where - type PatchTarget (PatchMapWithMove k v) = Map k v - apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? - where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of - From_Insert v -> Just v - From_Move k -> Map.lookup k old - From_Delete -> Nothing - deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of - From_Delete -> Just () - _ -> Nothing - --- | Returns all the new elements that will be added to the 'Map'. -patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v] -patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap - --- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@. -patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v -patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p - where f ni = case _nodeInfo_from ni of - From_Insert v -> Just v - From_Move _ -> Nothing - From_Delete -> Nothing - --- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort --- its values using the given ordering function. The set keys of the 'Map' is --- not changed. -patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v -patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted - where unsorted = Map.toList m - sorted = sortBy (cmp `on` snd) unsorted - f (to, _) (from, _) = if to == from then Nothing else - Just (from, to) - reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted - g (to, _) (from, _) = if to == from then Nothing else - let Just movingTo = Map.lookup from reverseMapping - in Just (to, NodeInfo (From_Move from) $ Just movingTo) - --- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, --- will produce a 'Map' with the same values as the second 'Map' but with the --- values sorted with the given ordering function. -patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v -patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex - where newList = Map.toList newByIndexUnsorted - newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList - --- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, --- will produce the second 'Map'. -patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v -patchThatChangesMap oldByIndex newByIndex = patch - where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex - (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do - let f k v = do - remainingValues <- get - let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys - then Map.delete v remainingValues - else Map.insert v remainingKeys remainingValues - case Map.lookup v remainingValues of - Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take - Just fromKs -> - if k `Set.member` fromKs - then do - putRemainingKeys $ Set.delete k fromKs - return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary - else do - (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here - putRemainingKeys remainingKeys - return $ NodeInfo (From_Move fromK) $ Just undefined - Map.traverseWithKey f newByIndex - unusedOldKeys = fold unusedValuesByValue - pointlessMove k = \case - From_Move k' | k == k' -> True - _ -> False - keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys) - then Just undefined - else Nothing - patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex - --- | Change the 'From' value of a 'NodeInfo' -nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v -nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } - --- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or --- 'Applicative', 'Monad', etc.) action to get the new value -nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v) -nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni - --- | Set the 'To' field of a 'NodeInfo' -nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v -nodeInfoSetTo to ni = ni { _nodeInfo_to = to } - --- |Helper data structure used for composing patches using the monoid instance. -data Fixup k v - = Fixup_Delete - | Fixup_Update (These (From k v) (To k)) - --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance Ord k => Semigroup (PatchMapWithMove k v) where - PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m - where - connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb - h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)] - h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of - (Just toAfter, From_Move fromBefore) - | fromBefore == toAfter - -> [(toAfter, Fixup_Delete)] - | otherwise - -> [ (toAfter, Fixup_Update (This editBefore)) - , (fromBefore, Fixup_Update (That mToAfter)) - ] - (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map - (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))] - (Nothing, _) -> [] - mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete - mergeFixups _ (Fixup_Update a) (Fixup_Update b) - | This x <- a, That y <- b - = Fixup_Update $ These x y - | That y <- a, This x <- b - = Fixup_Update $ These x y - mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups" - fixups = Map.fromListWithKey mergeFixups $ concatMap h connections - combineNodeInfos _ nia nib = NodeInfo - { _nodeInfo_from = _nodeInfo_from nia - , _nodeInfo_to = _nodeInfo_to nib - } - applyFixup _ ni = \case - Fixup_Delete -> Nothing - Fixup_Update u -> Just $ NodeInfo - { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u - , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u - } - m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups - getHere :: These a b -> Maybe a - getHere = \case - This a -> Just a - These a _ -> Just a - That _ -> Nothing - getThere :: These a b -> Maybe b - getThere = \case - This _ -> Nothing - These _ b -> Just b - That b -> Just b - ---TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance Ord k => Monoid (PatchMapWithMove k v) where - mempty = PatchMapWithMove mempty - mappend = (<>) diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs --- a/src/Reflex/PerformEvent/Base.hs +++ b/src/Reflex/PerformEvent/Base.hs @@ -15,25 +15,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.PerformEvent.Base ( PerformEventT (..) , FireCommand (..) , hostPerformEventT ) where -import Reflex.Class 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.Lens +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Exception -import Control.Monad.Identity +import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref @@ -41,10 +39,15 @@ 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 @@ -63,19 +66,22 @@ 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 (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where +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, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where +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 @@ -86,7 +92,7 @@ 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), PrimMonad (HostFrame t), Reflex t) +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 @@ -97,7 +103,7 @@ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) +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 @@ -119,9 +125,7 @@ -- at the appropriate time. {-# INLINABLE hostPerformEventT #-} hostPerformEventT :: forall t m a. - ( Monad m - , MonadSubscribeEvent t m - , MonadReflexHost t m + ( MonadReflexHost t m , MonadRef m , Ref m ~ Ref IO ) @@ -141,7 +145,7 @@ case mToPerform of Nothing -> return [result'] Just toPerform -> do - responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform + responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform mrt <- readRef responseTrigger let followupEventTriggers = case mrt of Just rt -> [rt :=> Identity responses] @@ -164,6 +168,8 @@ 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) diff --git a/src/Reflex/PerformEvent/Class.hs b/src/Reflex/PerformEvent/Class.hs --- a/src/Reflex/PerformEvent/Class.hs +++ b/src/Reflex/PerformEvent/Class.hs @@ -1,35 +1,38 @@ --- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the +-- | 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 MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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 -import Control.Monad.Reader - -- | '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 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' @@ -62,3 +65,8 @@ 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 diff --git a/src/Reflex/PostBuild/Base.hs b/src/Reflex/PostBuild/Base.hs --- a/src/Reflex/PostBuild/Base.hs +++ b/src/Reflex/PostBuild/Base.hs @@ -9,11 +9,8 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.PostBuild.Base ( PostBuildT (..) , runPostBuildT @@ -22,16 +19,9 @@ , mapDMapWithAdjustImpl ) where -import Reflex.Class -import Reflex.Adjustable.Class -import Reflex.Host.Class -import Reflex.PerformEvent.Class -import Reflex.PostBuild.Class -import Reflex.TriggerEvent.Class - -import Control.Applicative (liftA2) +import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception -import Control.Monad.Identity +import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref @@ -43,8 +33,33 @@ 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) +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 @@ -56,7 +71,6 @@ -- 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 - mappend = liftA2 mappend instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where (<>) = liftA2 (S.<>) @@ -84,6 +98,8 @@ 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 diff --git a/src/Reflex/PostBuild/Class.hs b/src/Reflex/PostBuild/Class.hs --- a/src/Reflex/PostBuild/Class.hs +++ b/src/Reflex/PostBuild/Class.hs @@ -4,14 +4,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.PostBuild.Class ( PostBuild (..) ) where diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,9 +9,18 @@ {-# 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.Lens hiding (children) import Control.Monad import Control.Monad.Exception import Control.Monad.Fix @@ -18,27 +28,42 @@ 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, GCompare) +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.Monoid ((<>)) 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 System.IO.Unsafe -import Unsafe.Coerce +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class data ProfiledTimeline t @@ -71,9 +96,9 @@ go (cc : l) parent toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree -toCostCentreTree ccs n = do - ccList <- getCostCentreStack ccs - return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList +toCostCentreTree ccs n = + foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) + <$> getCostCentreStack ccs getCostCentreTree :: IO CostCentreTree getCostCentreTree = do @@ -127,27 +152,32 @@ 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 - merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity) - merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t)) - fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e) + 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' - mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t))) - mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t))) + 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 a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a))) + 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)) @@ -160,10 +190,21 @@ 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 @@ -174,6 +215,39 @@ 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 diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -5,19 +5,21 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif - +{-# 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 #-} --- | 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 +-- 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 (..) @@ -26,14 +28,10 @@ , Incremental (..) ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Control.Monad -import Data.Dependent.Map (DMap, GCompare) +import Data.Dependent.Map (DMap) +import Data.GADT.Compare (GCompare) import qualified Data.Dependent.Map as DMap -import Data.Functor.Identity import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe @@ -41,10 +39,11 @@ 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 +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 @@ -77,17 +76,19 @@ -- [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 + -- being present in the original class definition. - --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) - merge events = Event $ memo $ \t -> - let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events + --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 - fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k - fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k +-- 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 @@ -110,8 +111,8 @@ --a) -> Incremental (Pure t) p a unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) - mergeIncremental = mergeIncrementalImpl - mergeIncrementalWithMove = mergeIncrementalImpl + mergeIncrementalG = mergeIncrementalImpl + mergeIncrementalWithMoveG = mergeIncrementalImpl currentIncremental i = Behavior $ \t -> fst $ unIncremental i t @@ -126,14 +127,17 @@ 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 (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity) -mergeIncrementalImpl i = Event $ \t -> - let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t +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 @@ -204,3 +208,4 @@ Just x -> fromMaybe lastValue $ apply x lastValue headE = slowHeadE + now t = Event $ guard . (t ==) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -17,38 +17,47 @@ , mapQueryResult , dynWithQueryT , withQueryT + , mapQueryT ) where -import Control.Applicative (liftA2) +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, DSum (..)) +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 Data.Monoid ((<>)) import qualified Data.Semigroup as S -import Data.Some (Some) -import qualified Data.Some as Some +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 Reflex.Patch.MapWithMove as MapWithMove +import qualified Data.Patch.MapWithMove as MapWithMove import Reflex.PerformEvent.Class import Reflex.PostBuild.Class import Reflex.Query.Class @@ -56,12 +65,12 @@ 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) + 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, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q)) +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)) @@ -74,26 +83,19 @@ getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q] getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w -{- -let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q - sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty - bs' = fmapCheap snd $ r' - patches = unsafeBuildIncremental (sampleBs bs0) $ - flip pushCheap bs' $ \bs -> do - p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches) - return (Just (AdditivePatch p)) --} +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, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where +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 pushAlwaysCheap bs' $ \newBs -> do + let patches = flip pushCheap bs' $ \newBs -> do oldBs <- sample bbs - (~~) <$> sampleBs newBs <*> sampleBs oldBs + maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs QueryT $ lift $ tellEvent patches return (r0, fmapCheap fst r') @@ -143,7 +145,7 @@ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') - traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.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 :: 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 @@ -152,10 +154,10 @@ 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.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + 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.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p + 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' @@ -171,24 +173,24 @@ 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 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 -> sampleBs newBs + 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 -> negateG <$> sampleBs oldBs + 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 -> (~~) <$> sampleBs newBs <*> 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 <- AdditivePatch . fold <$> Map.traverseWithKey p bs' - return (apply pbs bs0, Just patch) + 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 :: * -> *) v v'. (DMap.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 :: 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 @@ -196,10 +198,10 @@ 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.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + 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.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -} + 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' @@ -216,28 +218,28 @@ 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 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 -> sampleBs newBs + MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs MapWithMove.From_Move k' -> case Map.lookup k' bs0 of - Nothing -> return mempty - Just newBs -> sampleBs newBs + 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 -> negateG <$> sampleBs oldBs + 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 -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) MapWithMove.From_Move k' - | k' == k -> return mempty + | 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 -> negateG <$> sampleBs oldBs - Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + 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 <- AdditivePatch . fold <$> Map.traverseWithKey p bs' - return (apply pbs bs0, Just patch) + 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') @@ -245,6 +247,9 @@ 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 @@ -284,7 +289,7 @@ (<>) = 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', Additive q, Additive q', Query q') +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 @@ -296,8 +301,12 @@ (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, Additive q, Group q', Additive q', Query q') +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 @@ -322,7 +331,7 @@ 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, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where +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)))) @@ -340,5 +349,5 @@ instance EventWriter t w m => EventWriter t w (QueryT t q m) where tellEvent = lift . tellEvent -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where +instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where tellDyn = lift . tellDyn diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -1,11 +1,19 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# 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 (..) @@ -15,6 +23,7 @@ , MonadQuery (..) , tellQueryDyn , queryDyn + , subQuery , mapQuery , mapQueryResult ) where @@ -25,23 +34,66 @@ 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 +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 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 --- | NB: QueryMorphism's must be group homomorphisms when acting on the query type --- and compatible with the query relationship when acting on the query result +-- | 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 @@ -54,13 +106,16 @@ , _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 keeps track of the multiplicity of elements of the view selector that are being used by the app +-- | 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) @@ -74,26 +129,36 @@ instance Group SelectedCount where negateG (SelectedCount a) = SelectedCount (negate a) -instance Additive SelectedCount +instance Commutative SelectedCount --- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted. +-- | 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) -class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where +-- | 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 (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where +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) -queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q)) +-- | 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) diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -1,26 +1,7 @@ --- | This module provides 'RequesterT', the standard implementation of --- 'Requester'. -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# 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 #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif module Reflex.Requester.Base ( RequesterT (..) , runRequesterT + , withRequesterT , runWithReplaceRequesterTWith , traverseIntMapWithKeyWithAdjustRequesterTWith , traverseDMapWithKeyWithAdjustRequesterTWith @@ -30,405 +11,11 @@ , forRequesterData , requesterDataToList , singletonRequesterData + , matchResponsesWithRequests + , matchResponseMapWithRequests + , multiEntry + , unMultiEntry + , requesting' ) where -import Reflex.Class -import Reflex.Adjustable.Class -import Reflex.Dynamic -import Reflex.Host.Class -import Reflex.PerformEvent.Class -import Reflex.PostBuild.Class -import Reflex.Requester.Class -import Reflex.TriggerEvent.Class - -import Control.Applicative (liftA2) -import Control.Monad.Exception -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.Ref -import Control.Monad.State.Strict -import Data.Bits -import Data.Coerce -import Data.Dependent.Map (DMap, DSum (..)) -import qualified Data.Dependent.Map as DMap -import Data.Functor.Compose -import Data.Functor.Misc -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import Data.Proxy -import qualified Data.Semigroup as S -import Data.Some (Some) -import qualified Data.Some as Some -import Data.Type.Equality -import Data.Unique.Tag - -import GHC.Exts (Any) -import Unsafe.Coerce - ---TODO: Make this module type-safe - -newtype TagMap (f :: * -> *) = TagMap (IntMap Any) - -newtype RequesterData f = RequesterData (TagMap (Entry f)) - -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 :: {-# 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 $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v - RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v - -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 -> do - (k', e') <- Map.toList 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 -> traverse (traverse (traverseRequesterData f)) request - 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 :: * -> * 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 :: * -> *) -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) = Map (Some k) (IntMap (RequesterData request)) - EntryContents request Multi3 = IntMap (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 :: * -> *) 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 :: * -> *) = 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 :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a } - deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException --- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2 -#if MIN_VERSION_base(4,9,1) - , MonadAsyncException -#endif - ) - -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) - --- 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 - mappend = liftA2 mappend - -instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where - (<>) = liftA2 (S.<>) - - --- | 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) - -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 :: 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 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) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, 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 = unEntry - pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k) - pack = Entry - 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) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This 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') +import Reflex.Requester.Base.Internal diff --git a/src/Reflex/Requester/Base/Internal.hs b/src/Reflex/Requester/Base/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Requester/Base/Internal.hs @@ -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) diff --git a/src/Reflex/Requester/Class.hs b/src/Reflex/Requester/Class.hs --- a/src/Reflex/Requester/Class.hs +++ b/src/Reflex/Requester/Class.hs @@ -6,23 +6,23 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + 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 @@ -33,11 +33,13 @@ -- '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 Request m :: Type -> Type -- | The type of responses that this 'Requester' can receive - type Response m :: * -> * + 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 () diff --git a/src/Reflex/Spider.hs b/src/Reflex/Spider.hs --- a/src/Reflex/Spider.hs +++ b/src/Reflex/Spider.hs @@ -1,17 +1,21 @@ {-# LANGUAGE CPP #-} --- | This module exports all of the user-facing functionality of the 'Spider' --- 'Reflex' engine + +-- | +-- 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 + ( Spider + , SpiderTimeline + , Global + , SpiderHost + , runSpiderHost + , runSpiderHostForTimeline + , newSpiderTimeline + , withSpiderTimeline + -- * Deprecated + , SpiderEnv + ) where import Reflex.Spider.Internal diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -9,2630 +9,2954 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif --- | 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 - -#if MIN_VERSION_base(4,10,0) -import Control.Applicative (liftA2) -#endif -import Control.Concurrent -import Control.Exception -import Control.Monad hiding (forM, forM_, mapM, mapM_) -import Control.Monad.Exception -import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) -import Control.Monad.Primitive -import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) -import Control.Monad.Ref -import Data.Align -import Data.Coerce -import Data.Dependent.Map (DMap, DSum (..)) -import qualified Data.Dependent.Map as DMap -import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..)) -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.Maybe -import Data.Monoid ((<>)) -import Data.Proxy -import Data.These -import Data.Traversable -import GHC.Exts -import GHC.IORef (IORef (..)) -import GHC.Stack -import Reflex.FastWeak -import Reflex.FunctorMaybe -import System.IO.Unsafe -import System.Mem.Weak -import Unsafe.Coerce - -#ifdef DEBUG_CYCLES -import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence) -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Monoid (mempty) -import Data.Tree (Forest, Tree (..), drawForest) -#endif - -import Data.FastWeakBag (FastWeakBag) -import qualified Data.FastWeakBag as FastWeakBag -import Data.Reflection -import Data.Some (Some) -import qualified Data.Some as Some -import Data.Type.Coercion -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 Reflex.Patch -import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove - -#ifdef DEBUG_TRACE_EVENTS -import qualified Data.ByteString.Char8 as BS8 -import System.IO (stderr) -#endif - -#ifdef DEBUG_TRACE_EVENTS - -withStackOneLine :: (BS8.ByteString -> a) -> a -withStackOneLine expr = unsafePerformIO $ do - stack <- currentCallStack - return (expr (BS8.pack (unwords (reverse stack)))) - -#endif - -debugPropagate :: Bool - -debugInvalidateHeight :: Bool - -debugInvalidate :: Bool - -#ifdef DEBUG - -#define DEBUG_NODEIDS - -debugPropagate = True - -debugInvalidateHeight = False - -debugInvalidate = True - -class HasNodeId a where - getNodeId :: a -> Int - -instance HasNodeId (Hold x p a) where - getNodeId = holdNodeId - -instance HasNodeId (PushSubscribed x a b) where - getNodeId = pushSubscribedNodeId - -instance HasNodeId (SwitchSubscribed x a) where - getNodeId = switchSubscribedNodeId - -instance HasNodeId (FanSubscribed x 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 = ("#"<>) . show . getNodeId - -showSubscriberType :: Subscriber x a -> String -showSubscriberType = \case - SubscriberPush _ _ -> "SubscriberPush" - SubscriberMerge _ _ -> "SubscriberMerge" - SubscriberFan _ -> "SubscriberFan" - SubscriberMergeChange _ -> "SubscriberMergeChange" - SubscriberHold _ -> "SubscriberHold" - SubscriberHoldIdentity _ -> "SubscriberHoldIdentity" - SubscriberSwitch _ -> "SubscriberSwitch" - SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter" - SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner" - SubscriberHandle -> "SubscriberHandle" - -showEventType :: Event x a -> String -showEventType = \case - EventRoot _ _ -> "EventRoot" - EventNever -> "EventNever" - EventPush _ -> "EventPush" - EventMerge _ -> "EventMerge" - EventFan _ _ -> "EventFan" - EventSwitch _ -> "EventSwitch" - EventCoincidence _ -> "EventCoincidence" - EventHold _ -> "EventHold" - EventDyn _ -> "EventDyn" - EventHoldIdentity _ -> "EventHoldIdentity" - EventDynIdentity _ -> "EventDynIdentity" - -#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 _ = "" - -#endif - -#ifdef DEBUG_NODEIDS -{-# NOINLINE nextNodeIdRef #-} -nextNodeIdRef :: IORef Int -nextNodeIdRef = unsafePerformIO $ newIORef 1 - -newNodeId :: IO Int -newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n) - -{-# NOINLINE unsafeNodeId #-} -unsafeNodeId :: a -> Int -unsafeNodeId a = unsafePerformIO $ do - touch a - newNodeId -#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 $ 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 $ 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 :: (MonadIO m, 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 $ \_ -> clearParent - when (isJust occ) clearParent - return $ Event $ \sub -> do - liftIO (readIORef parent) >>= \case - Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing) - 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)) - } - --- | 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 - let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) - !mSubscribedRef = unsafeNewIORef e emptyFastWeak - in \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 - subscribers <- liftIO FastWeakBag.empty - occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below - (parentSub, occ) <- subscribeAndRead e $ Subscriber - { subscriberPropagate = \a -> do - liftIO $ writeIORef occRef $ Just a - scheduleClear occRef - propagateFast a subscribers - , subscriberInvalidateHeight = \old -> do - FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old - , subscriberRecalculateHeight = \new -> do - FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new - } - 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 - } - subscribedTicket <- liftIO $ mkFastWeakTicket subscribed - liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket - return subscribedTicket - liftIO $ do - subscribed <- getFastWeakTicketValue subscribedTicket - ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed - occ <- readIORef $ _cacheSubscribed_occurrence subscribed - let es = EventSubscription - { _eventSubscription_unsubscribe = do - FastWeakBag.remove ticket - isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed - when isEmpty $ do - writeIORef mSubscribedRef emptyFastWeak - unsubscribe $ _cacheSubscribed_parent subscribed - touch ticket - touch subscribedTicket - , _eventSubscription_subscribed = EventSubscribed - { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed - , eventSubscribedRetained = toAny subscribedTicket - } - } - 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 => k a -> Root x k -> Event x a -eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r - -eventNever :: Event x a -eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing) - -eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x 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 ()) - } - ---TODO: Move this comment to WeakBag --- 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. - -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. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity)) -newSubscriberFan subscribed = return $ Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do - subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed - tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" - liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a - scheduleClear $ fanSubscribedOccurrence subscribed - let f _ (Pair (Identity 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 - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed - subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" - , subscriberRecalculateHeight = \new -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed - subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" - } - -newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a) -newSubscriberSwitch subscribed = return $ Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do - tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed - liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a - scheduleClear $ switchSubscribedOccurrence subscribed - propagate a $ switchSubscribedSubscribers subscribed - , subscriberInvalidateHeight = \_ -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed - oldHeight <- readIORef $ switchSubscribedHeight subscribed - when (oldHeight /= invalidHeight) $ do - writeIORef (switchSubscribedHeight subscribed) $! invalidHeight - WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" - , subscriberRecalculateHeight = \new -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed - updateSwitchHeight new subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" - } - -newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b)) -newSubscriberCoincidenceOuter subscribed = return $ Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do - tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed - 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 -> do - 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 = \_ -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed - invalidateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" - , subscriberRecalculateHeight = \_ -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed - recalculateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done" - } - -newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a) -newSubscriberCoincidenceInner subscribed = return $ Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do - tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed - occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed - case occ of - Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event - Nothing -> do - liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a - scheduleClear $ coincidenceSubscribedOccurrence subscribed - propagate a $ coincidenceSubscribedSubscribers subscribed - , subscriberInvalidateHeight = \_ -> do - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed - invalidateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" - , subscriberRecalculateHeight = \_ -> do - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed - recalculateCoincidenceHeight subscribed - when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done" - } - -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 :: a -> WeakBag (Subscriber x a) -> EventM x () -propagate a subscribers = withIncreasedDepth $ do - -- 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 :: a -> FastWeakBag (Subscriber x a) -> EventM x () -propagateFast a subscribers = withIncreasedDepth $ do - -- 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 - -data EventSubscribed x = EventSubscribed - { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height) - , eventSubscribedRetained :: {-# NOUNPACK #-} !Any -#ifdef DEBUG_CYCLES - , eventSubscribedGetParents :: !(IO [Some (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 - } - -eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x -eventSubscribedFan !subscribed = EventSubscribed - { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed - , eventSubscribedRetained = toAny subscribed -#ifdef DEBUG_CYCLES - , eventSubscribedGetParents = return [Some.This $ _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 [Some.This $ _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 = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed - innerParents = maybeToList $ fmap Some.This 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 [Some (EventSubscribed x)] -walkInvalidHeightParents s0 = do - subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do - h <- liftIO $ readIORef $ eventSubscribedHeightRef s - when (h == invalidHeight) $ do - when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed - modify (Some.This s :) - mapM_ loop =<< liftIO (eventSubscribedGetParents s) - forM_ subscribers $ \(Some.This 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 (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 [] - holdInits <- askBehaviorHoldInits - a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) - 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 - -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_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :)) - liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected - return result - -{-# 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 --------------------------------------------------------------------------------- - -data Dynamic x p = Dynamic - { dynamicCurrent :: !(Behavior x (PatchTarget p)) - , dynamicUpdated :: !(Event x p) - } - -dynamicHold :: Hold x p -> Dynamic x p -dynamicHold !h = Dynamic - { dynamicCurrent = behaviorHold h - , dynamicUpdated = eventHold h - } - -dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a) -dynamicHoldIdentity = dynamicHold - -dynamicConst :: PatchTarget p -> Dynamic x p -dynamicConst !a = Dynamic - { dynamicCurrent = behaviorConst a - , dynamicUpdated = eventNever - } - -dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p -dynamicDyn !d = Dynamic - { dynamicCurrent = behaviorDyn d - , dynamicUpdated = eventDyn d - } - -dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a) -dynamicDynIdentity = dynamicDyn - --------------------------------------------------------------------------------- --- Combinators --------------------------------------------------------------------------------- - ---TODO: Figure out why certain things are not 'representational', then make them ---representational so we can use coerce - ---type role Hold representational -data Hold x p - = Hold { holdValue :: !(IORef (PatchTarget p)) - , holdInvalidators :: !(IORef [Weak (Invalidator 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@ -data SpiderTimelineEnv x = SpiderTimelineEnv - { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ()) - , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x) -#ifdef DEBUG - , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int) -#endif - } -type role SpiderTimelineEnv nominal - -instance Eq (SpiderTimelineEnv x) where - _ == _ = True -- Since only one exists of each type - -instance GEq SpiderTimelineEnv where - a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock 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 [SomeClear]) -- Needed for Subscribe - , eventEnvIntClears :: !(IORef [SomeIntClear]) - , eventEnvRootClears :: !(IORef [SomeRootClear]) - , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe - , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe - , 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 (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 SomeClear (EventM x) where - {-# INLINE getDeferralQueue #-} - getDeferralQueue = asksEventEnv eventEnvClears - -{-# INLINE scheduleClear #-} -scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m () -scheduleClear r = defer $ SomeClear r - -instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where - {-# INLINE getDeferralQueue #-} - getDeferralQueue = asksEventEnv eventEnvIntClears - -{-# INLINE scheduleIntClear #-} -scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m () -scheduleIntClear r = defer $ SomeIntClear r - -instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where - {-# INLINE getDeferralQueue #-} - getDeferralQueue = asksEventEnv eventEnvRootClears - -{-# INLINE scheduleRootClear #-} -scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m () -scheduleRootClear r = defer $ SomeRootClear 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 [] - 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]) - ---type role BehaviorM representational --- BehaviorM can sample behaviors -newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix) - -instance Monad (BehaviorM x) where - {-# INLINE (>>=) #-} - BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f - {-# INLINE (>>) #-} - BehaviorM x >> BehaviorM y = BehaviorM $ x >> y - {-# INLINE return #-} - return x = BehaviorM $ return x - {-# INLINE fail #-} - fail s = BehaviorM $ fail s - -data BehaviorSubscribed x a - = forall p. BehaviorSubscribedHold (Hold x p) - | BehaviorSubscribedPull (PullSubscribed x a) - -data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a) - ---type role PullSubscribed representational -data PullSubscribed x a - = PullSubscribed { pullSubscribedValue :: !a - , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator 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) -- 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 - -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 - -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 a = FanSubscribedChildren - { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a)) - , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k) - , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k))) - } - -data FanSubscribed (x :: *) k - = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k))) - , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity))) - , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty - , fanSubscribedParent :: !(EventSubscription x) -#ifdef DEBUG_NODEIDS - , fanSubscribedNodeId :: Int -#endif - } - -data Fan x k - = Fan { fanParent :: !(Event x (DMap k Identity)) - , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k))) - } - -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))) - } - -#ifdef USE_TEMPLATE_HASKELL -{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-} -#endif -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 => FunctorMaybe (Event x) where - fmapMaybe f = push $ return . f - -instance HasSpiderTimeline x => Align (Event x) where - nil = eventNever - align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] - -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 p = Dyn { unDyn :: IORef (DynType x p) } - -newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic 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) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic 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 $ unsafeNewIORef x $ UnsafeDyn x - where x = (readV0, v') - --- ResultM can read behaviors and events -type ResultM = EventM - -{-# NOINLINE unsafeNewIORef #-} -unsafeNewIORef :: a -> b -> IORef b -unsafeNewIORef a b = unsafePerformIO $ do - touch a - newIORef b - -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 = behaviorPull $ Pull - { pullCompute = a - , pullValue = unsafeNewIORef a Nothing -#ifdef DEBUG_NODEIDS - , pullNodeId = unsafeNodeId a -#endif - } - -{-# INLINABLE switch #-} -switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a -switch a = eventSwitch $ Switch - { switchParent = a - , switchSubscribed = unsafeNewIORef a Nothing - } - -coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a -coincidence a = eventCoincidence $ Coincidence - { coincidenceParent = a - , coincidenceSubscribed = unsafeNewIORef a Nothing - } - --- 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 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 - -data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a)) - -data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a)) - -data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity)) - -data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator 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 $ putStrLn $ "finalizing: " ++ debugNote - else Nothing - -type WeakList a = [Weak a] - -{-# INLINE withIncreasedDepth #-} -#ifdef DEBUG -withIncreasedDepth :: CanTrace x m => m a -> m a -withIncreasedDepth a = do - spiderTimeline <- askSpiderTimelineEnv - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ - result <- a - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred - return result -#else -withIncreasedDepth :: m a -> m a -withIncreasedDepth = id -#endif - -type CanTrace x m = (HasSpiderTimeline x, MonadIO m) - -{-# INLINE tracePropagate #-} -tracePropagate :: (CanTrace x m) => proxy x -> String -> m () -tracePropagate p = traceWhen p debugPropagate - -{-# INLINE traceInvalidate #-} -traceInvalidate :: String -> IO () -traceInvalidate = when debugInvalidate . liftIO . putStrLn - -{-# INLINE traceWhen #-} -traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m () -traceWhen p b message = traceMWhen p b $ return message - -{-# INLINE traceMWhen #-} -traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m () -traceMWhen _ b getMessage = when b $ do - message <- getMessage -#ifdef DEBUG - spiderTimeline <- askSpiderTimelineEnv - d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline -#else - let d = 0 -#endif - liftIO $ putStrLn $ replicate d ' ' <> message - -whoCreatedIORef :: IORef a -> IO [String] -whoCreatedIORef (IORef a) = whoCreated $! a - -#ifdef DEBUG_CYCLES -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 l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l -#endif - -{-# INLINE propagateSubscriberHold #-} -propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x () -propagateSubscriberHold h a = do - {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do - invalidators <- liftIO $ readIORef $ holdInvalidators h - return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators) - v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h - case {-# SCC "apply" #-} apply a v of - Nothing -> return () - Just v' -> do - {-# SCC "trace2" #-} withIncreasedDepth $ 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' - -data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset - -runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a -runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits) - -askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x))) -askInvalidator = do - (!m, _) <- BehaviorM ask - case m of - Nothing -> return Nothing - Just (!wi, _) -> return $ Just wi - -askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x])) -askParentsRef = do - (!m, _) <- BehaviorM ask - case m of - Nothing -> return Nothing - Just (_, !p) -> return $ Just p - -askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x]) -askBehaviorHoldInits = do - (_, !his) <- BehaviorM 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 :: GCompare k => 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 - when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit" - uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) - writeIORef uninitRef $! uninit - let !subscribed = RootSubscribed - { rootSubscribedKey = k - , rootSubscribedCachedSubscribed = cached - , rootSubscribedOccurrence = getOcc - , rootSubscribedSubscribers = subs - , rootSubscribedUninit = uninit - , rootSubscribedWeakSelf = weakSelf -#ifdef DEBUG_NODEIDS - , rootSubscribedNodeId = unsafeNodeId (k, r, subs) -#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) - -#ifdef USE_TEMPLATE_HASKELL -{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-} -#endif -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)) - } - -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" - return $ FanInt - { _fanInt_subscribers = subscribers - , _fanInt_subscriptionRef = subscriptionRef - , _fanInt_occRef = occRef - } - -{-# NOINLINE unsafeNewFanInt #-} -unsafeNewFanInt :: b -> FanInt x a -unsafeNewFanInt b = unsafePerformIO $ do - touch b - newFanInt - -fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a -fanInt p = - let self = unsafeNewFanInt p - in 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 - (subscription, parentOcc) <- subscribeAndRead p $ Subscriber - { subscriberPropagate = \m -> do - liftIO $ writeIORef (_fanInt_occRef self) m - scheduleIntClear $ _fanInt_occRef self - FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse? - FastWeakBag.traverse b $ \s -> do - subscriberPropagate s v - , subscriberInvalidateHeight = \old -> do - FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do - FastWeakBag.traverse b $ \s -> do - subscriberInvalidateHeight s old - , subscriberRecalculateHeight = \new -> do - FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do - FastWeakBag.traverse b $ \s -> do - 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 - t <- liftIO $ FastWeakBag.insert sub b - currentOcc <- readIORef (_fanInt_occRef self) - (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self) - return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) - -{-# INLINABLE getFanSubscribed #-} -getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe 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 - let subscribed = FanSubscribed - { fanSubscribedCachedSubscribed = fanSubscribed f - , fanSubscribedOccurrence = occRef - , fanSubscribedParent = subscription - , fanSubscribedSubscribers = subscribersRef -#ifdef DEBUG_NODEIDS - , fanSubscribedNodeId = unsafeNodeId f -#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) -> 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 -> Subscriber x 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 - 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 = unsafeNodeId s -#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 - let subscribed = CoincidenceSubscribed - { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c - , coincidenceSubscribedOccurrence = occRef - , coincidenceSubscribedHeight = heightRef - , coincidenceSubscribedSubscribers = subs - , coincidenceSubscribedOuter = subOuter - , coincidenceSubscribedOuterParent = outerSubscription - , coincidenceSubscribedInnerParent = innerSubdRef - , coincidenceSubscribedWeakSelf = weakSelf -#ifdef DEBUG_NODEIDS - , coincidenceSubscribedNodeId = unsafeNodeId c -#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 merge #-} -merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -merge d = cacheEvent (mergeCheap d) - -{-# INLINE mergeWithMove #-} -mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeWithMove d = cacheEvent (mergeCheapWithMove d) - -{-# INLINE [1] mergeCheap #-} -mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy - where - updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (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 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 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 e s - height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) 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. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy - where - updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k) - updateMe subscriber heightBagRef oldParents p = do - -- Prepare new parents for insertion - let subscribeParent :: forall a. k a -> Event x 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 subscribeParent p - -- Collect old parents for deletion and update the keys of moved parents - let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) 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 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 e s - height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) 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 x p s - = (forall a. EventM x (k a) -> Subscriber x a) - -> IORef HeightBag - -> DMap k s - -> p - -> EventM x ([EventSubscription x], DMap k s) - -type MergeInitFunc k x s - = DMap k (Event x) - -> (forall a. EventM x (k a) -> Subscriber x a) - -> EventM x (DMap k Identity, [Height], DMap k s) - -type MergeDestroyFunc k s - = DMap k s - -> IO () - -data Merge x k 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 Identity)) - , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity)) - } - -invalidateMergeHeight :: Merge x k 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 - when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents - writeIORef heightRef $! invalidHeight - subscriberInvalidateHeight sub oldHeight - - -revalidateMergeHeight :: Merge x k s -> IO () -revalidateMergeHeight m = do - currentHeight <- readIORef $ _merge_heightRef m - when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check - 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 - when debugInvalidateHeight $ putStrLn $ "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 s -> Height -> EventM x () -scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do - vals <- liftIO $ readIORef $ _merge_accumRef m - liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- 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 - --TODO: Assert that m is not empty - subscriberPropagate (_merge_sub m) vals - -mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a -mergeSubscriber 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 (Identity 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 - --TODO: assertions about height - currentHeight <- getCurrentHeight - when (height <= currentHeight) $ do - 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 $ do -#ifdef DEBUG_CYCLES - nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed - stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es - let cycleInfo = ":\n" <> drawForest (listsToForest stacks) -#else - let cycleInfo = "" -#endif - error $ "Causality loop found" <> cycleInfo - 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) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x -updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) - where updateMe = do - oldParents <- liftIO $ readIORef $ _merge_parentsRef m - (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p - liftIO $ writeIORef (_merge_parentsRef m) $! newParents - return subscriptionsToKill - -{-# INLINE mergeCheap' #-} -mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity) -mergeCheap' 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" - let m = Merge - { _merge_parentsRef = parentsRef - , _merge_heightBagRef = heightBagRef - , _merge_heightRef = heightRef - , _merge_sub = sub - , _merge_accumRef = accumRef - } - (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber 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) $ do - scheduleMergeSelf m myHeight - liftIO $ writeIORef accumRef $! accum - liftIO $ writeIORef heightRef $! myHeight - liftIO $ writeIORef heightBagRef $! myHeightBag - changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" - liftIO $ writeIORef parentsRef $! initialParentState - defer $ SomeMergeInit $ do - let s = Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do - tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change" - defer $ updateMerge m updateFunc a - , subscriberInvalidateHeight = \_ -> return () - , subscriberRecalculateHeight = \_ -> return () - } - (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s - forM_ change $ \c -> defer $ updateMerge 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 (s, changeSubscription) - let unsubscribeAll = destroy =<< readIORef parentsRef - return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef) - , occ - ) - -mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) -mergeInt = cacheEvent . mergeIntCheap - -{-# INLINABLE mergeIntCheap #-} -mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic 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 - let scheduleSelf = do - height <- liftIO $ readIORef $ heightRef - scheduleMerge' height heightRef $ do - vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum - subscriberPropagate sub vals - invalidateMyHeight = do - 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 - when debugInvalidateHeight $ putStrLn $ "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 - 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 - changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" - 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 s = Subscriber - { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do - tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change" - defer $ updateMe a - , subscriberInvalidateHeight = \_ -> return () - , subscriberRecalculateHeight = \_ -> return () - } - (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s - 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 (s, changeSubscription) - let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents - return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef) - , occ - ) - -newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a } - -fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k -fan e = - let f = Fan - { fanParent = e - , fanSubscribed = unsafeNewIORef e Nothing - } - in EventSelector $ \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 [] - delayedRef <- newIORef IntMap.empty - return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef - -clearEventEnv :: EventEnv x -> IO () -clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do - writeIORef toAssignRef [] - writeIORef holdInitRef [] - writeIORef dynInitRef [] - writeIORef mergeUpdateRef [] - writeIORef mergeInitRef [] - writeIORef heightRef zeroHeight - writeIORef toClearRef [] - writeIORef toClearIntRef [] - writeIORef toClearRootRef [] - writeIORef coincidenceInfosRef [] - 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 (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 $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing - toClearInt <- readIORef $ eventEnvIntClears env - forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty - toClearRoot <- readIORef $ eventEnvRootClears env - forM_ toClearRoot $ \(SomeRootClear 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 - when debugInvalidate $ putStrLn $ "Invalidating Hold" - writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef - mergeUpdates <- readIORef $ eventEnvMergeUpdates env - writeIORef (eventEnvMergeUpdates env) [] - when debugPropagate $ putStrLn "Updating merges" - mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates - when debugPropagate $ putStrLn "Updating merges done" - toReconnect <- readIORef toReconnectRef - clearEventEnv env - switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do - oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed - wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed - when debugInvalidate $ putStrLn $ "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 $ putStrLn $ (++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 mcs) -> do - unsubscribe subscription - mapM_ invalidateCoincidenceHeight mcs - forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs - 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 :: CoincidenceSubscribed x a -> IO () -invalidateCoincidenceHeight subscribed = do - oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed - when (oldHeight /= invalidHeight) $ do - writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight - 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] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x)) -invalidate toReconnectRef 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 [] -- 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 - -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 - -instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where - {-# INLINE return #-} - return = pure - {-# INLINE (>>=) #-} - x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x - {-# INLINE (>>) #-} - (>>) = (*>) - {-# INLINE fail #-} - fail _ = error "Dynamic does not support 'fail'" - -{-# INLINABLE newJoinDyn #-} -newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic 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 -#if MIN_VERSION_base(4,10,0) - liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b) -#endif - 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 - -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 - -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 - --------------------------------------------------------------------------------- --- 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 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 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 $ 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.This) - -data LocalSpiderTimeline x s - -instance Reifies s (SpiderTimelineEnv x) => - HasSpiderTimeline (LocalSpiderTimeline x s) where - spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s) - -localSpiderTimeline - :: Proxy s - -> SpiderTimelineEnv x - -> SpiderTimelineEnv (LocalSpiderTimeline x s) -localSpiderTimeline _ = unsafeCoerce - --- | 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 a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) - -type ComputeM = EventM - -newtype SpiderPushM x 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 :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad) - newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic 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 merge #-} - merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x)) - {-# INLINABLE fan #-} - fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) - {-# 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 = coerce $ SpiderEvent . dynamicUpdated . 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 mergeIncremental #-} - mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental - {-# INLINABLE mergeIncrementalWithMove #-} - mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . 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 = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance - {-# INLINABLE mergeIntIncremental #-} - mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental - {-# 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 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 - {-# INLINABLE (>>) #-} - SpiderHost x >> SpiderHost y = SpiderHost $ x >> y - {-# INLINABLE return #-} - return x = SpiderHost $ return x - {-# INLINABLE fail #-} - fail s = SpiderHost $ 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 a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } - deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) - -instance Monad (SpiderHostFrame x) where - {-# INLINABLE (>>=) #-} - SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f - {-# INLINABLE (>>) #-} - SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y - {-# INLINABLE return #-} - return x = SpiderHostFrame $ return x - {-# INLINABLE fail #-} - fail s = SpiderHostFrame $ fail s - -instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where - notReadyUntil _ = pure () - notReady = pure () - -newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a) -newEventWithTriggerIO f = do - es <- newFanEventWithTriggerIO $ \Refl -> f - return $ select es Refl - -newFanEventWithTriggerIO :: 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 +{-# 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 () diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -1,69 +1,79 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -#ifdef USE_TEMPLATE_HASKELL -{-# LANGUAGE TemplateHaskell #-} -#endif +-- | +-- Module: +-- Reflex.Time +-- Description: +-- Clocks, timers, and other time-related functions. module Reflex.Time where -import Reflex.Class -import Reflex.Dynamic -import Reflex.PerformEvent.Class -import Reflex.PostBuild.Class -import Reflex.TriggerEvent.Class - import Control.Concurrent import qualified Control.Concurrent.Thread.Delay as Concurrent -import Control.Lens hiding ((|>)) 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 Data.Typeable +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 since t0 + -- ^ Number of time periods or ticks since the start of the timer , _tickInfo_alreadyElapsed :: NominalDiffTime - -- ^ Amount of time already elapsed in the current tick period. + -- ^ Amount of time that has elapsed in the current tick period. } - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show) --- | Special case of 'tickLossyFrom' that uses the post-build event to start the --- tick thread. +-- | 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 --- | 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. +-- | 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 --- | Send events over time with the given basis time and interval --- 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 basis time +-- | 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 + -- ^ 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 @@ -71,12 +81,12 @@ -> m (Event t TickInfo) tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e --- | Generalization of tickLossyFrom that takes dt and t0 in the event. +-- | 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 + -- 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 @@ -87,12 +97,16 @@ 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 @@ -266,19 +280,100 @@ delayed <- delay t outE return outE -#ifdef USE_TEMPLATE_HASKELL -makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo -#else -tickInfo_lastUTC :: Lens' TickInfo UTCTime +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 :: Lens' TickInfo Integer +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 :: Lens' TickInfo NominalDiffTime -tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3 +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 #-} -#endif - diff --git a/src/Reflex/TriggerEvent/Base.hs b/src/Reflex/TriggerEvent/Base.hs --- a/src/Reflex/TriggerEvent/Base.hs +++ b/src/Reflex/TriggerEvent/Base.hs @@ -1,10 +1,13 @@ -- | 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 @@ -13,17 +16,23 @@ , EventTriggerRef (..) ) where -import Control.Applicative (liftA2) 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 Data.Monoid ((<>)) 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 @@ -40,7 +49,7 @@ -- | 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) + 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 @@ -122,6 +131,8 @@ 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 #-} diff --git a/src/Reflex/TriggerEvent/Class.hs b/src/Reflex/TriggerEvent/Class.hs --- a/src/Reflex/TriggerEvent/Class.hs +++ b/src/Reflex/TriggerEvent/Class.hs @@ -2,8 +2,8 @@ -- new 'Event's that can be triggered from 'IO'. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} + module Reflex.TriggerEvent.Class ( TriggerEvent (..) ) where @@ -13,6 +13,7 @@ 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 @@ -45,6 +46,11 @@ 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 diff --git a/src/Reflex/Widget/Basic.hs b/src/Reflex/Widget/Basic.hs --- a/src/Reflex/Widget/Basic.hs +++ b/src/Reflex/Widget/Basic.hs @@ -2,9 +2,6 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif module Reflex.Widget.Basic where @@ -13,7 +10,7 @@ import Reflex.Class import Reflex.Adjustable.Class -import Reflex.Patch.MapWithMove +import Data.Patch.MapWithMove -- | Build sortable content in such a way that re-sorting it can cause minimal diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -1,8 +1,15 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} -module Reflex.Workflow ( - -- * Workflows - Workflow (..) + +-- | +-- 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 @@ -18,21 +25,28 @@ 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)) } -workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t 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 -workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) +-- | 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) diff --git a/test/Adjustable.hs b/test/Adjustable.hs new file mode 100644 --- /dev/null +++ b/test/Adjustable.hs @@ -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 diff --git a/test/DebugCycles.hs b/test/DebugCycles.hs new file mode 100644 --- /dev/null +++ b/test/DebugCycles.hs @@ -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) diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs --- a/test/EventWriterT.hs +++ b/test/EventWriterT.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecursiveDo #-} @@ -12,6 +14,10 @@ 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 @@ -36,6 +42,9 @@ 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]) @@ -44,16 +53,13 @@ return e testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m () -testOrdering pulse = do - forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse) - return () +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) - return () -- | 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. @@ -112,3 +118,17 @@ (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' diff --git a/test/GC.hs b/test/GC.hs --- a/test/GC.hs +++ b/test/GC.hs @@ -18,15 +18,17 @@ import Data.IORef import Data.Semigroup import Data.These +import Data.Type.Equality ((:~:)(Refl)) import Data.Functor.Misc -import Reflex.Patch +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 @@ -46,7 +48,7 @@ eventToPerform <- Host.runHostFrame $ do (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) <- S.SpiderHostFrame - $ fmap ( S.merge + $ 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 @@ -55,8 +57,8 @@ { S.subscriberPropagate = S.subscriberPropagate sub } return (s, o)) - $ runIdentity <$> S.select - (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) + $ 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 @@ -82,7 +84,6 @@ Nothing -> [] Host.fireEventsAndRead followupEventTriggers $ return () return () - return () data Tell a where Action :: Tell () diff --git a/test/Headless.hs b/test/Headless.hs new file mode 100644 --- /dev/null +++ b/test/Headless.hs @@ -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) diff --git a/test/QueryT.hs b/test/QueryT.hs --- a/test/QueryT.hs +++ b/test/QueryT.hs @@ -17,14 +17,19 @@ 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 Reflex.Patch.MapWithMove +import Data.Patch.MapWithMove import Test.Run newtype MyQuery = MyQuery SelectedCount - deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group) + deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Commutative, Group) instance Query MyQuery where type QueryResult MyQuery = () @@ -58,7 +63,7 @@ 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)) => Additive (Selector k a) +instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Commutative (Selector k a) main :: IO () main = do diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs --- a/test/Reflex/Bench/Focused.hs +++ b/test/Reflex/Bench/Focused.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeApplications #-} module Reflex.Bench.Focused where @@ -130,6 +131,16 @@ 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) @@ -308,6 +319,8 @@ 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 @@ -364,6 +377,12 @@ 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 + ] diff --git a/test/Reflex/Plan/Pure.hs b/test/Reflex/Plan/Pure.hs --- a/test/Reflex/Plan/Pure.hs +++ b/test/Reflex/Plan/Pure.hs @@ -41,6 +41,7 @@ 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 diff --git a/test/Reflex/Plan/Reflex.hs b/test/Reflex/Plan/Reflex.hs --- a/test/Reflex/Plan/Reflex.hs +++ b/test/Reflex/Plan/Reflex.hs @@ -34,6 +34,7 @@ import Control.Applicative import Control.Monad +import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.State.Strict diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -21,11 +21,14 @@ import Reflex.Host.Class import qualified Reflex.Pure as P import qualified Reflex.Spider.Internal as S +import qualified Reflex.Profiled as Prof 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.Map (DSum (..)) +import Data.Dependent.Sum (DSum (..)) import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -35,8 +38,6 @@ import System.Exit import System.Mem -import System.IO.Unsafe - mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of Nothing -> error $ "mapToPureBehavior: no value for time " <> show t @@ -73,11 +74,14 @@ 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) @@ -102,9 +106,11 @@ 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 @@ -112,6 +118,7 @@ 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)) @@ -218,6 +225,11 @@ 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) =<< headE e diff --git a/test/Reflex/Test/Micro.hs b/test/Reflex/Test/Micro.hs --- a/test/Reflex/Test/Micro.hs +++ b/test/Reflex/Test/Micro.hs @@ -20,7 +20,9 @@ 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 @@ -214,6 +216,41 @@ 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 @@ -322,14 +359,25 @@ 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")] diff --git a/test/RequesterT.hs b/test/RequesterT.hs --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -1,15 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main where -import Control.Lens +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 @@ -18,20 +45,51 @@ 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@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $ + os1 <- 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 () () - ] + 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 @@ -43,7 +101,7 @@ -> m (Event t [Int]) unwrapApp x appIn = do ((), e) <- runRequesterT (x appIn) never - return $ fmap (map unwrapRequest . DMap.toList) e + return $ fmap (map unwrapRequest . requesterDataToList) e testOrdering :: ( Response m ~ Identity , Request m ~ RequestInt @@ -65,3 +123,114 @@ 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 + ) diff --git a/test/behaviorLeak.hs b/test/behaviorLeak.hs new file mode 100644 --- /dev/null +++ b/test/behaviorLeak.hs @@ -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 diff --git a/test/hlint.hs b/test/hlint.hs --- a/test/hlint.hs +++ b/test/hlint.hs @@ -1,7 +1,7 @@ module Main where import Control.Monad -import Language.Haskell.HLint3 (hlint) +import Language.Haskell.HLint (hlint) import System.Directory import System.Exit (exitFailure, exitSuccess) import System.FilePath @@ -21,7 +21,9 @@ , "--ignore=Use ." , "--ignore=Use unless" , "--ignore=Reduce duplication" - , "--cpp-define=USE_TEMPLATE_HASKELL" + , "--ignore=Replace case with maybe" + , "--cpp-define=DEBUG" + , "--ignore=Use tuple-section" ] recurseInto = and <$> sequence [ fileType ==? Directory @@ -29,16 +31,9 @@ ] matchFile = and <$> sequence [ extension ==? ".hs" - , let notElem' = liftOp notElem - in filePath `notElem'` filePathExceptions pwd ] 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 - -filePathExceptions :: FilePath -> [FilePath] -filePathExceptions pwd = map (pwd ) $ - [ "src/Data/AppendMap.hs" -- parse error when hlint runs - ]