diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,59 @@ # 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # [Reflex](https://reflex-frp.org/) -[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.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) +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE) Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse. @@ -15,6 +15,7 @@ * [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) 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,502 +1,523 @@ -Name: reflex -Version: 0.8.2.2 -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. - . - -License: BSD3 -License-file: LICENSE -Author: Ryan Trinkle -Maintainer: ryan.trinkle@gmail.com -Stability: Experimental -Category: FRP -Build-type: Simple -Cabal-version: 1.22 -homepage: https://reflex-frp.org -bug-reports: https://github.com/reflex-frp/reflex/issues -extra-source-files: - README.md - Quickref.md - ChangeLog.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.2 || ==9.0.1 || ==9.2.2, - GHCJS ==8.6 + 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! + default: False + manual: True + flag fast-weak - description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default - default: False - manual: True + description: + Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default + default: False + manual: True + flag debug-propagation - description: Enable debugging of spider internals - default: False - manual: True + description: Enable debugging of spider internals + default: False + manual: True flag debug-cycles - description: Enable debugging of event cycles - default: False - manual: True + description: Enable debugging of event cycles + default: False + manual: True flag split-these - description: Use split these/semialign packages - manual: False - default: True + description: Use split these/semialign packages + manual: False + default: True library - default-language: Haskell2010 - hs-source-dirs: src - build-depends: - MemoTrie == 0.6.*, - base >= 4.11 && < 4.17, - bifunctors >= 5.2 && < 5.6, - comonad >= 5.0.4 && < 5.1, - commutative-semigroups >= 0.1 && <0.2, - constraints >= 0.10 && <0.14, - constraints-extras >= 0.3 && < 0.5, - containers >= 0.6 && < 0.7, - data-default >= 0.5 && < 0.8, - dependent-map >= 0.3 && < 0.5, - exception-transformers == 0.4.*, - lens >= 4.7 && < 5.2, - mmorph >= 1.0 && < 1.2, - monad-control >= 1.0.1 && < 1.1, - mtl >= 2.1 && < 2.3, - patch >= 0.0.7 && < 0.1, - prim-uniq >= 0.1.0.1 && < 0.3, - primitive >= 0.5 && < 0.8, - profunctors >= 5.3 && < 5.7, - random >= 1.1 && < 1.3, - ref-tf >= 0.4 && < 0.6, - reflection == 2.1.*, - semigroupoids >= 4.0 && < 6, - stm >= 2.4 && < 2.6, - syb >= 0.5 && < 0.8, - time >= 1.4 && < 1.12, - transformers >= 0.5.6.0 && < 0.6, - unbounded-delays >= 0.1.0.0 && < 0.2, - witherable >= 0.4 && < 0.5 + exposed-modules: + Control.Monad.ReaderIO + Data.AppendMap + Data.FastMutableIntMap + Data.FastWeakBag + Data.Map.Misc + Data.WeakBag + Reflex + Reflex.Class + Reflex.Adjustable.Class + Reflex.BehaviorWriter.Base + Reflex.BehaviorWriter.Class + Reflex.Collection + Reflex.Dynamic + Reflex.Dynamic.TH + Reflex.Dynamic.Uniq + Reflex.DynamicWriter + Reflex.DynamicWriter.Base + Reflex.DynamicWriter.Class + Reflex.EventWriter + Reflex.EventWriter.Base + Reflex.EventWriter.Class + Reflex.FastWeak + Reflex.FunctorMaybe + Reflex.Host.Class + Reflex.Host.Headless + Reflex.Network + Reflex.NotReady.Class + Reflex.PerformEvent.Base + Reflex.PerformEvent.Class + Reflex.PostBuild.Base + Reflex.PostBuild.Class + Reflex.Profiled + Reflex.Pure + Reflex.Query.Base + Reflex.Query.Class + Reflex.Requester.Base + Reflex.Requester.Base.Internal + Reflex.Requester.Class + Reflex.Spider + Reflex.Spider.Internal + Reflex.Time + Reflex.TriggerEvent.Base + Reflex.TriggerEvent.Class + Reflex.Widget.Basic + Reflex.Workflow - if flag(split-these) - build-depends: these >= 1 && <1.3, - semialign >=1 && <1.3, - monoidal-containers >= 0.6.2.0 && < 0.7 - else - build-depends: these >= 0.4 && <0.9, - monoidal-containers == 0.4.0.0 + 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 - exposed-modules: - Control.Monad.ReaderIO - Data.AppendMap, - Data.FastMutableIntMap, - Data.FastWeakBag, - Data.Map.Misc, - Data.WeakBag, - Reflex, - Reflex.Class, - Reflex.Adjustable.Class, - Reflex.BehaviorWriter.Base, - Reflex.BehaviorWriter.Class, - Reflex.Collection, - Reflex.Dynamic, - Reflex.Dynamic.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.Class, - Reflex.Spider, - Reflex.Spider.Internal, - Reflex.Time, - Reflex.TriggerEvent.Base, - Reflex.TriggerEvent.Class, - Reflex.Widget.Basic, - Reflex.Workflow + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -fwarn-redundant-constraints -fwarn-tabs + -funbox-strict-fields -O2 -fspecialise-aggressively - 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 + build-depends: + MemoTrie == 0.6.* + , base >= 4.11 && < 4.22 + , bifunctors >= 5.2 && < 5.7 + , comonad >= 5.0.4 && < 5.1 + , commutative-semigroups >= 0.1 && <0.3 + , constraints >= 0.10 && <0.15 + , constraints-extras >= 0.3 && < 0.5 + , containers >= 0.6 && < 0.8 + , data-default >= 0.5 && < 0.9 + , dependent-map >= 0.3 && < 0.5 + , dependent-sum >= 0.6 && < 0.8 + , exceptions >= 0.10 && < 0.11 + , exception-transformers >= 0.4 && < 0.5 + , mmorph >= 1.0 && < 1.3 + , monad-control >= 1.0.1 && < 1.1 + , mtl >= 2.1 && < 2.4 + , patch >= 0.0.7 && < 0.1 + , prim-uniq >= 0.1.0.1 && < 0.3 + , primitive >= 0.5 && < 0.10 + , profunctors >= 5.3 && < 5.7 + , random >= 1.1 && < 1.4 + , ref-tf >= 0.4 && < 0.6 + , reflection == 2.1.* + , semigroupoids >= 4.0 && < 7 + , stm >= 2.4 && < 2.6 + , syb >= 0.5 && < 0.8 + , time >= 1.4 && < 1.15 + , transformers >= 0.5 && < 0.7 + , unbounded-delays >= 0.1.0.0 && < 0.2 + , witherable >= 0.4 && < 0.6 + , haskell-src-exts >= 1.16 && < 1.24 + , haskell-src-meta >= 0.6 && < 0.9 + , template-haskell >= 2.9 && < 2.24 - ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively + other-extensions: + TemplateHaskell - if flag(debug-trace-events) - cpp-options: -DDEBUG_TRACE_EVENTS - build-depends: - bytestring >= 0.10.8 && < 0.11 + if flag(split-these) + build-depends: + these >=1 && <1.3 + , semialign >=1 && <1.4 + , monoidal-containers >=0.6.2.0 && <0.7 - if flag(use-reflex-optimizer) - cpp-options: -DUSE_REFLEX_OPTIMIZER - build-depends: ghc - exposed-modules: Reflex.Optimizer + else + build-depends: + these >=0.4 && <0.9 + , monoidal-containers ==0.4.0.0 - if flag(debug-propagation) - cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION + if flag(debug-trace-events) + cpp-options: -DDEBUG_TRACE_EVENTS + build-depends: bytestring >=0.10.8 && <0.11 - if flag(debug-cycles) - cpp-options: -DDEBUG_CYCLES + if flag(debug-propagation) + cpp-options: + -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION - if flag(use-template-haskell) - cpp-options: -DUSE_TEMPLATE_HASKELL - build-depends: - dependent-sum >= 0.6 && < 0.8, - haskell-src-exts >= 1.16 && < 1.24, - haskell-src-meta >= 0.6 && < 0.9, - template-haskell >= 2.9 && < 2.19 - exposed-modules: - Reflex.Dynamic.TH - other-extensions: TemplateHaskell - else - build-depends: - dependent-sum >= 0.6 && < 0.8 + if flag(debug-cycles) + cpp-options: -DDEBUG_CYCLES - if flag(fast-weak) && impl(ghcjs) - cpp-options: -DGHCJS_FAST_WEAK + if flag(fast-weak) && impl(ghcjs >=0) + cpp-options: -DGHCJS_FAST_WEAK - if impl(ghcjs) - build-depends: - ghcjs-base == 0.2.* + if impl(ghcjs) + build-depends: ghcjs-base >=0.2 && <0.3 test-suite semantics - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: semantics.hs - hs-source-dirs: test - ghc-options: -O2 -Wall -rtsopts - build-depends: - base, - bifunctors, - containers, - deepseq, - dependent-map, - dependent-sum, - mtl, - ref-tf, - reflex, - split, - transformers - 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 - default-language: Haskell2010 - 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, - 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 -test-suite hlint - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: hlint.hs - hs-source-dirs: test - build-depends: base - , directory - , filepath - , filemanip - if impl(ghc >= 8.8) - build-depends: hlint >= 3 && < 4 - else - build-depends: hlint (< 2.1 || >= 2.2.2) && < 4 - if impl(ghcjs) - buildable: False + 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 EventWriterT - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: EventWriterT.hs - hs-source-dirs: test - build-depends: base - , containers - , deepseq - , dependent-map - , dependent-sum - , lens - , mtl - , these - , transformers - , reflex - , ref-tf +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base >= 4.11 && < 4.22 + , directory + , filepath + , filemanip - if flag(split-these) - build-depends: these-lens + if impl(ghc >=9.6) + buildable: False - other-modules: - Test.Run + if impl(ghc <9.2) + build-depends: hlint (<2.1 || >=2.2.2) && <3.5 + else + build-depends: hlint >=3.5 && <3.6 -test-suite DebugCycles - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: DebugCycles.hs - hs-source-dirs: test - ghc-options: -threaded - build-depends: base - , containers - , deepseq - , dependent-map - , dependent-sum - , hspec - , lens - , mtl - , these - , transformers - , reflex - , ref-tf - , witherable - , proctest + if impl(ghcjs >=0) || arch(javascript) + buildable: False +test-suite EventWriterT + type: exitcode-stdio-1.0 + main-is: EventWriterT.hs + hs-source-dirs: test + other-modules: Test.Run + default-language: Haskell2010 + build-depends: + base >= 4.11 && < 4.22 + , containers + , deepseq + , dependent-map + , dependent-sum + , lens + , mtl + , these + , transformers + , reflex + , ref-tf - if flag(split-these) - build-depends: these-lens, semialign + if flag(split-these) + build-depends: these-lens - other-modules: - Test.Run +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 - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: RequesterT.hs - hs-source-dirs: test - build-depends: base - , constraints - , constraints-extras - , containers - , deepseq - , dependent-map - , dependent-sum - , lens - , mtl - , ref-tf - , reflex - , text - , these - , transformers + type: exitcode-stdio-1.0 + main-is: RequesterT.hs + hs-source-dirs: test + other-modules: + Reflex.TestPlan + Reflex.Plan.Pure + Test.Run - if flag(split-these) - build-depends: these-lens + 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 - other-modules: - Reflex.TestPlan - Reflex.Plan.Pure - Test.Run + if flag(split-these) + build-depends: these-lens test-suite Headless - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: Headless.hs - hs-source-dirs: test - build-depends: base - , reflex + 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 - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: Adjustable.hs - hs-source-dirs: test - build-depends: base - , containers - , dependent-sum - , reflex - , ref-tf - , these - - other-modules: - Test.Run + 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 - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: QueryT.hs - hs-source-dirs: test - build-depends: base - , commutative-semigroups - , containers - , dependent-map - , dependent-sum - , deepseq - , lens - , monoidal-containers - , mtl - , patch - , ref-tf - , reflex - , these - , transformers + 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 - if flag(split-these) - build-depends: semialign, these-lens + 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 - other-modules: - Test.Run - Reflex.TestPlan - Reflex.Plan.Reflex - Reflex.Plan.Pure + if flag(split-these) + build-depends: + semialign + , these-lens test-suite GC-Semantics - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: GC.hs - hs-source-dirs: test - build-depends: base - , containers - , dependent-sum - , dependent-map - , deepseq - , mtl - , patch - , these - , transformers - , reflex - , ref-tf + 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 - if flag(split-these) - build-depends: semialign + default-language: Haskell2010 + build-depends: + base >= 4.11 && < 4.22 + , containers + , dependent-sum + , dependent-map + , deepseq + , mtl + , patch + , these + , transformers + , reflex + , ref-tf - other-modules: - Reflex.Plan.Pure - Reflex.Plan.Reflex - Reflex.TestPlan - Test.Run + if flag(split-these) + build-depends: semialign test-suite rootCleanup - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: rootCleanup.hs - hs-source-dirs: test - build-depends: base - , containers - , deepseq - , 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 - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: bench test - main-is: Main.hs - ghc-options: -Wall -O2 -rtsopts - build-depends: - base, - containers, - criterion, - deepseq, - dependent-map, - dependent-sum, - ref-tf, - mtl, - primitive, - reflex, - split, - stm, - transformers - 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 - default-language: Haskell2010 - 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, - criterion, - deepseq, - dependent-map, - dependent-sum, - loch-th, - mtl, - primitive, - process, - ref-tf, - reflex, - split, - stm, - time, - transformers - 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 --- a/src/Control/Monad/ReaderIO.hs +++ b/src/Control/Monad/ReaderIO.hs @@ -2,16 +2,12 @@ {-# language MultiParamTypeClasses #-} {-# language FlexibleInstances #-} {-# language CPP #-} + module Control.Monad.ReaderIO - ( - ReaderIO (..) - ) - where + ( ReaderIO (..) + ) where import Control.Monad.Fix -#if MIN_VERSION_base(4,10,0) -import Control.Applicative -#endif import Control.Monad import Control.Monad.Reader.Class import Control.Monad.IO.Class @@ -34,12 +30,10 @@ {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} -#if MIN_VERSION_base(4,10,0) +#if MIN_VERSION_base(4,18,0) liftA2 = liftM2 {-# INLINE liftA2 #-} #endif - (*>) = (>>) - {-# INLINE (*>) #-} instance Monad (ReaderIO e) where ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- Module: -- Data.AppendMap @@ -25,14 +26,8 @@ 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 qualified Data.Witherable as W import Data.Map.Monoidal -import qualified Data.Map.Monoidal as MonoidalMap {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} @@ -47,11 +42,6 @@ -- | Pattern synonym for 'MonoidalMap' pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m - -#if !MIN_VERSION_witherable(0,3,2) -instance W.Filterable (MonoidalMap k) where - mapMaybe = MonoidalMap.mapMaybe -#endif -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) 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,5 @@ {-# LANGUAGE TypeFamilies #-} + -- | -- Module: -- Data.FastMutableIntMap 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 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 ( 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 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,9 +14,7 @@ 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 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 @@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | -- Module: -- Reflex.Adjustable.Class 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 @@ -10,19 +10,20 @@ {-# 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 @@ -37,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 @@ -60,6 +65,9 @@ , MonadFix , MonadAsyncException , MonadException + , MonadCatch + , MonadThrow + , MonadMask ) -- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided 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 @@ -7,9 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.BehaviorWriter.Class ( MonadBehaviorWriter , BehaviorWriter(..) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -17,9 +17,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif -- | -- Module: @@ -185,6 +182,8 @@ #endif import Control.Applicative +import Control.Monad +import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict @@ -202,7 +201,6 @@ import Data.Functor.Compose import Data.Functor.Product import Data.GADT.Compare (GEq (..), GCompare (..)) -import Data.FastMutableIntMap (PatchIntMap) import Data.Foldable import Data.Functor.Bind import Data.Functor.Misc @@ -218,12 +216,12 @@ import Data.These import Data.Type.Coercion import Data.Type.Equality ((:~:) (..)) -import Data.Witherable (Filterable(..)) -import qualified Data.Witherable as W 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) @@ -678,14 +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 @@ -706,11 +707,6 @@ negate = fmap negate (-) = liftA2 (-) -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 - -- | Alias for 'mapMaybe' fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b fmapMaybe = mapMaybe @@ -1157,7 +1153,6 @@ 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 diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | -- Module: -- Reflex.Collection @@ -34,7 +32,8 @@ #endif #endif -import Control.Monad.Identity +import Control.Monad +import Control.Monad.Fix import Data.Align import Data.Functor.Misc import Data.Map (Map) @@ -42,6 +41,10 @@ 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 @@ -74,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)) @@ -106,7 +109,7 @@ , tag (current vals) postBuild ] listHoldWithKey Map.empty changeVals $ \k v -> - mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k) + 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' @@ -147,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)) @@ -155,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)) @@ -165,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) @@ -189,7 +192,7 @@ -- 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) @@ -207,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)) @@ -215,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,9 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | -- Module: -- Reflex.Dynamic @@ -78,28 +76,30 @@ , unsafeDynamic ) where -import Data.Functor.Compose -import Data.Functor.Misc -import Reflex.Class - -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.Compose +import Data.Functor.Misc import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.Kind (Type) import Data.Map (Map) import Data.Maybe -import Data.Monoid ((<>)) 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) 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,9 +5,7 @@ {-# 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 @@ -15,18 +13,21 @@ , mkDynPure ) 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@ @@ -91,7 +92,6 @@ 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 -> @@ -99,14 +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 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,19 +8,20 @@ {-# 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 @@ -36,10 +37,14 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Semigroup (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 @@ -99,6 +104,9 @@ , MonadFix , MonadAsyncException , MonadException + , MonadCatch + , MonadThrow + , MonadMask ) deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m) @@ -120,7 +128,7 @@ -- | 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) @@ -159,7 +167,7 @@ -- | 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') @@ -168,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) @@ -195,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) @@ -219,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 @@ -4,9 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.DynamicWriter.Class ( MonadDynamicWriter , DynamicWriter(..) 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 @@ -33,7 +31,9 @@ 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 @@ -108,6 +108,9 @@ , MonadIO , MonadException , MonadAsyncException + , MonadMask + , MonadCatch + , MonadThrow ) -- | Run a 'EventWriterT' action. 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 @@ -3,15 +3,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# 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/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,9,0) {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} -#endif -- | -- Module: @@ -19,7 +17,7 @@ #if !MIN_VERSION_base(4,16,0) import Data.Semigroup (Option(..)) #endif -import Data.Witherable +import Witherable --TODO: See if there's a better class in the standard libraries already 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 @@ -8,10 +8,9 @@ {-# 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. diff --git a/src/Reflex/Host/Headless.hs b/src/Reflex/Host/Headless.hs --- a/src/Reflex/Host/Headless.hs +++ b/src/Reflex/Host/Headless.hs @@ -1,42 +1,51 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} module Reflex.Host.Headless where import Control.Concurrent.Chan (newChan, readChan) -import Control.Monad (unless) +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_) +import Data.Foldable (for_, asum) import Data.Functor.Identity (Identity(..)) import Data.IORef (IORef, readIORef) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes) import Data.Traversable (for) import Reflex import Reflex.Host.Class type MonadHeadlessApp t m = - ( Adjustable 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 - , Reflex t , ReflexHost t , TriggerEvent t m ) @@ -46,10 +55,11 @@ -- classes to interface the FRP network with the outside world. Useful for -- testing. Each headless network runs on its own spider timeline. runHeadlessApp - :: (forall t m. MonadHeadlessApp t m => m (Event t ())) + :: 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 () + -> IO a runHeadlessApp guest = -- We are using the 'Spider' implementation of reflex. Running the host -- allows us to take actions on the FRP timeline. @@ -89,35 +99,46 @@ shutdown <- subscribeEvent result -- When there is a subscriber to the post-build event, fire the event. - soa <- for mPostBuildTrigger $ \postBuildTrigger -> - fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown + 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 - -- The main application loop. We wait for new events and fire those that - -- have subscribers. If we detect a shutdown request, the application - -- terminates. - unless (or (fromMaybe [] soa)) $ fix $ \loop -> do - -- Read the next event (blocking). - ers <- liftIO $ readChan events - stop <- do - -- Fire events that have subscribers. - fireEventTriggerRefs fc ers $ - -- Check if the shutdown 'Event' is firing. - isFiring shutdown - if or stop - then pure () - else loop + 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 - isFiring ev = readEvent ev >>= \case - Nothing -> pure False - Just _ -> pure True -- Use the given 'FireCommand' to fire events that have subscribers -- and call the callback for the 'TriggerInvocation' of each. fireEventTriggerRefs - :: MonadIO m + :: forall b m t + . MonadIO m => FireCommand t m -> [DSum (EventTriggerRef t) TriggerInvocation] - -> ReadPhase m a - -> m [a] + -> ReadPhase m b + -> m [b] fireEventTriggerRefs (FireCommand fire) ers rcb = do mes <- liftIO $ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do 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,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + -- | -- Module: -- Reflex.Network @@ -22,7 +20,7 @@ -- | 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 'switchPromptly'). +-- 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 @@ -30,8 +28,8 @@ 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. +-- 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 @@ -4,10 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.NotReady.Class ( NotReady(..) ) where diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs deleted file mode 100644 --- a/src/Reflex/Optimizer.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- Module: --- Reflex.Optimizer --- Description: --- 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. -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/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 ) 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 @@ -9,18 +9,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# 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 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 @@ -10,9 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif + module Reflex.PostBuild.Base ( PostBuildT (..) , runPostBuildT @@ -21,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 @@ -42,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 @@ -55,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.<>) 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 @@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# 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 #-} @@ -11,6 +12,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} + -- | -- Module: -- Reflex.Profiled @@ -36,7 +38,6 @@ 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 @@ -45,6 +46,12 @@ 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 @@ -57,8 +64,6 @@ import Reflex.Query.Class import Reflex.Requester.Class import Reflex.TriggerEvent.Class - -import System.IO.Unsafe data ProfiledTimeline t diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -5,17 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} - -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif - -- There are two expected orphan instances in this module: -- * MonadSample (Pure t) ((->) t) -- * MonadHold (Pure t) ((->) t) {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- Module: Reflex.Pure -- Description: @@ -212,6 +209,3 @@ 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} @@ -19,7 +20,7 @@ , 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 @@ -40,12 +41,16 @@ 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.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 @@ -60,7 +65,7 @@ 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) 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 @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + -- | -- Module: -- Reflex.Query.Class @@ -27,7 +28,6 @@ , mapQueryResult ) where -import Control.Applicative import Control.Category (Category) import qualified Control.Category as Cat import Control.Monad.Reader @@ -37,11 +37,15 @@ import Data.Kind (Type) import Data.Map.Monoidal (MonoidalMap) import qualified Data.Map.Monoidal as MonoidalMap -import Data.Semigroup (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 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,24 +1,3 @@ --- | 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 #-} -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif module Reflex.Requester.Base ( RequesterT (..) , runRequesterT @@ -39,570 +18,4 @@ , 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.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.Monoid ((<>)) -import Data.Proxy -import qualified Data.Semigroup as S -import Data.Some (Some(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 :: 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 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) - -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 - 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) - --- | 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) +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 @@ -8,16 +8,16 @@ {-# LANGUAGE FunctionalDependencies #-} {-# 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 @@ -38,6 +38,8 @@ 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,20 +1,21 @@ {-# LANGUAGE CPP #-} + -- | -- Module: -- Reflex.Spider -- Description: -- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine module Reflex.Spider - ( Spider - , SpiderTimeline - , Global - , SpiderHost - , runSpiderHost - , runSpiderHostForTimeline - , newSpiderTimeline - , withSpiderTimeline - -- * Deprecated - , SpiderEnv - ) where + ( 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 @@ -20,36 +20,32 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiWayIf #-} - -#ifdef USE_REFLEX_OPTIMIZER -{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} -#endif {-# 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 +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.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception -import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) +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 Control.Monad.Fail (MonadFail) 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, PatchIntMap (..)) +import Data.FastMutableIntMap (FastMutableIntMap) import qualified Data.FastMutableIntMap as FastMutableIntMap import Data.Foldable hiding (concat, elem, sequence_) import Data.Functor.Constant @@ -61,12 +57,10 @@ import Data.IORef import Data.Kind (Type) import Data.Maybe hiding (mapMaybe) -import Data.Monoid (mempty, (<>)) import Data.Proxy import Data.These import Data.Traversable import Data.Type.Equality ((:~:)(Refl)) -import Data.Witherable (Filterable, mapMaybe) import GHC.Exts hiding (toList) import GHC.IORef (IORef (..)) import GHC.Stack @@ -74,7 +68,18 @@ 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) @@ -91,7 +96,10 @@ 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 @@ -251,7 +259,7 @@ -- caching; if the computation function is very cheap, this is (much) more -- efficient than 'push' {-# INLINE [1] pushCheap #-} -pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b +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 @@ -272,7 +280,7 @@ -- | Subscribe to an Event only for the duration of one occurrence {-# INLINE subscribeAndReadHead #-} -subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a) +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 @@ -286,7 +294,7 @@ return (subscription, occ) --TODO: Make this lazy in its input event -headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a) +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 @@ -307,12 +315,10 @@ #endif } -nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ()) -nowSpiderEventM = - SpiderEvent <$> now +nowSpiderEventM :: HasSpiderTimeline x => EventM x (R.Event (SpiderTimeline x) ()) +nowSpiderEventM = SpiderEvent <$> now -now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x - ) => m (Event x ()) +now :: Defer (Some Clear) m => m (Event x ()) now = do nowOrNot <- liftIO $ newIORef $ Just () scheduleClear nowOrNot @@ -533,10 +539,12 @@ 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 _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event + 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 @@ -551,14 +559,14 @@ recalculateSubscriberHeight = flip subscriberRecalculateHeight -- | Propagate everything at the current height -propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x () +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. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x () +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 @@ -701,7 +709,7 @@ case val of Just subscribed -> do askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :)) - askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) + askInvalidator >>= mapM_ (liftIO . addInvalidatorAmortized (pullSubscribedInvalidators subscribed)) liftIO $ touch $ pullSubscribedOwnInvalidator subscribed return $ pullSubscribedValue subscribed Nothing -> do @@ -710,7 +718,8 @@ parentsRef <- liftIO $ newIORef [] holdInits <- askBehaviorHoldInits a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) - invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator + inv0 <- maybeToList <$> askInvalidator + invsRef <- liftIO $ newIORef $ InvalidatorList (length inv0) invalidatorPruneThreshold inv0 parents <- liftIO $ readIORef parentsRef let subscribed = PullSubscribed { pullSubscribedValue = a @@ -729,11 +738,49 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p) readHoldTracked h = do result <- liftIO $ readIORef $ holdValue h - askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) + 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 @@ -787,7 +834,7 @@ --type role Hold representational data Hold x p = Hold { holdValue :: !(IORef (PatchTarget p)) - , holdInvalidators :: !(IORef [Weak (Invalidator x)]) + , 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 @@ -837,6 +884,7 @@ , 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 ()])) } @@ -939,7 +987,7 @@ 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 [] + invsRef <- liftIO $ newIORef emptyInvalidatorList parentRef <- liftIO $ newIORef Nothing #ifdef DEBUG_NODEIDS nodeId <- liftIO newNodeId @@ -990,10 +1038,6 @@ 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 #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail s = BehaviorM $ fail s @@ -1008,7 +1052,7 @@ --type role PullSubscribed representational data PullSubscribed x a = PullSubscribed { pullSubscribedValue :: !a - , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)]) + , 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 } @@ -1057,7 +1101,8 @@ 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) +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 } @@ -1093,7 +1138,7 @@ _ -> IntMap.insert h (pred old) c heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag -heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where +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 @@ -1158,9 +1203,7 @@ , 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)) @@ -1336,7 +1379,7 @@ newtype RootClear k = RootClear (IORef (DMap k Identity)) -data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a +data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef (InvalidatorList x)) a debugFinalize :: Bool debugFinalize = False @@ -1349,8 +1392,6 @@ then Just $ debugStrLn $ "finalizing: " ++ debugNote else Nothing -type WeakList a = [Weak a] - type CanTrace x m = (HasSpiderTimeline x, MonadIO m) @@ -1470,7 +1511,7 @@ #ifdef DEBUG_HIDE_INTERNALS filterStack prefix = filter (not . (prefix `isPrefixOf`)) #else -filterStack prefix = id +filterStack _prefix = id #endif #ifdef DEBUG_CYCLES @@ -1499,8 +1540,8 @@ 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 - invalidators <- liftIO $ readIORef $ holdInvalidators h - return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators) + 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 @@ -1512,7 +1553,9 @@ 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 +-- | '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) @@ -1609,9 +1652,7 @@ 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 @@ -2052,7 +2093,7 @@ --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x () +checkCycle :: EventSubscribed x -> EventM x () checkCycle subscribed = liftIO $ do height <- readIORef (eventSubscribedHeightRef subscribed) @@ -2106,7 +2147,7 @@ {-# 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' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do +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" @@ -2256,8 +2297,6 @@ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions liftIO $ for_ oldParents $ \oldParent -> do oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent - - print ("updateMe", oldParentHeight) modifyIORef' heightBagRef $ heightBagRemove oldParentHeight return $ IntMap.elems oldParents let changeSubscriber = Subscriber @@ -2273,7 +2312,7 @@ -- 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 =<< FastMutableIntMap.getFrozenAndClear parents + let unsubscribeAll = traverse_ (unsubscribe . snd) =<< FastMutableIntMap.toList parents return (EventSubscription unsubscribeAll subscribed, occ) @@ -2322,11 +2361,12 @@ toClearIntRef <- newIORef [] toClearRootRef <- newIORef [] coincidenceInfosRef <- newIORef [] + invalidatedCoincidencesRef <- newIORef [] delayedRef <- newIORef IntMap.empty - return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef + 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 delayedRef) = do +clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef invalidatedCoincidencesRef delayedRef) = do writeIORef toAssignRef [] writeIORef holdInitRef [] writeIORef dynInitRef [] @@ -2337,6 +2377,7 @@ writeIORef toClearIntRef [] writeIORef toClearRootRef [] writeIORef coincidenceInfosRef [] + writeIORef invalidatedCoincidencesRef [] writeIORef delayedRef IntMap.empty -- | Run an event action outside of a frame @@ -2402,10 +2443,12 @@ 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 + forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mInvalidate) -> do unsubscribe subscription - mapM_ invalidateCoincidenceHeight mcs - forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs + 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 @@ -2436,11 +2479,13 @@ then invalidHeight else Height $ succ a -invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO () +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 () @@ -2471,8 +2516,8 @@ 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 +invalidate :: IORef [SomeSwitchSubscribed x] -> InvalidatorList x -> IO (InvalidatorList x) +invalidate toReconnectRef (InvalidatorList _ _ wis) = do forM_ wis $ \wi -> do mi <- deRefWeak wi case mi of @@ -2491,7 +2536,7 @@ 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 + 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 @@ -2548,12 +2593,8 @@ 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 (>>) #-} - (>>) = (*>) #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail _ = error "Dynamic does not support 'fail'" @@ -2579,9 +2620,7 @@ 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 @@ -2611,8 +2650,8 @@ 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 @@ -2834,15 +2873,12 @@ 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) +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 - {-# INLINABLE (>>) #-} - SpiderHost x >> SpiderHost y = SpiderHost $ x >> y - {-# INLINABLE return #-} - return x = SpiderHost $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail = MonadFail.fail @@ -2863,15 +2899,11 @@ runSpiderHostForTimeline (SpiderHost a) _ = a newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } - deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) + deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadMask, MonadThrow, MonadCatch) 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 #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail s = SpiderHostFrame $ fail s diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -4,13 +4,11 @@ {-# 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 @@ -18,30 +16,31 @@ -- 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.Semigroup (Semigroup(..)) 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 @@ -51,7 +50,7 @@ , _tickInfo_alreadyElapsed :: NominalDiffTime -- ^ Amount of time that has elapsed in the current tick period. } - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show) -- | Fires an 'Event' once every time provided interval elapses, approximately. -- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick. @@ -284,13 +283,13 @@ data ThrottleState b = ThrottleState_Immediate | ThrottleState_Buffered (ThrottleBuffer b) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) + 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, Typeable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data) instance Semigroup b => Semigroup (ThrottleBuffer b) where x <> y = case x of @@ -367,18 +366,14 @@ delayed <- lag (void outE) return outE -#ifdef USE_TEMPLATE_HASKELL -makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo -#else -tickInfo_lastUTC :: Lens' TickInfo UTCTime +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 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 @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} + module Reflex.TriggerEvent.Class ( TriggerEvent (..) ) where 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 diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} + -- | -- Module: -- Reflex.Workflow @@ -7,8 +8,8 @@ -- 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 (..) +module Reflex.Workflow + ( Workflow (..) , workflow , workflowView , mapWorkflow @@ -30,13 +31,13 @@ newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } -- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another). -workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) +workflow :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) workflow w0 = do rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult return $ fmap fst eResult -- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'. -workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) +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 diff --git a/test/DebugCycles.hs b/test/DebugCycles.hs --- a/test/DebugCycles.hs +++ b/test/DebugCycles.hs @@ -29,7 +29,7 @@ import Test.Run import Test.Hspec import Reflex.Spider.Internal (EventLoopException) -import Data.Witherable (Filterable) +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 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 @@ -376,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/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 @@ -24,6 +24,8 @@ 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.Sum (DSum (..)) 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 @@ -336,6 +373,11 @@ 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/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 @@ -21,7 +21,7 @@ , "--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" ]