reflex 0.6.1 → 0.6.2.1
raw patch · 20 files changed
+559/−272 lines, 20 filesdep +constraints-extrasdep +profunctorsdep ~dependent-mapdep ~dependent-sumdep ~haskell-src-exts
Dependencies added: constraints-extras, profunctors
Dependency ranges changed: dependent-map, dependent-sum, haskell-src-exts, monoidal-containers, these
Files
- ChangeLog.md +30/−11
- README.md +3/−2
- reflex.cabal +9/−7
- src/Data/AppendMap.hs +14/−4
- src/Data/FastMutableIntMap.hs +17/−0
- src/Data/FastWeakBag.hs +1/−1
- src/Data/Functor/Misc.hs +2/−11
- src/Reflex/Adjustable/Class.hs +30/−3
- src/Reflex/Class.hs +184/−26
- src/Reflex/Dynamic.hs +8/−10
- src/Reflex/DynamicWriter/Class.hs +1/−0
- src/Reflex/Patch/DMapWithMove.hs +6/−7
- src/Reflex/Profiled.hs +10/−6
- src/Reflex/Pure.hs +19/−12
- src/Reflex/Query/Base.hs +5/−6
- src/Reflex/Query/Class.hs +24/−4
- src/Reflex/Requester/Base.hs +2/−3
- src/Reflex/Spider/Internal.hs +189/−155
- src/Reflex/Workflow.hs +1/−1
- test/GC.hs +4/−3
ChangeLog.md view
@@ -1,17 +1,36 @@ # Revision history for reflex -## 0.6.0.0 -- 2019-03-20+## Unreleased -* Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now.-* Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name.-* Remove many deprecated functions.-* Add a Num instance for Dynamic.-* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you.-* Add withRequesterT to map functions over the request and response of a RequesterT.-* Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance.-* Add throttleBatchWithLag to Reflex.Time. See that module for details.+* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`+ values. +* Generalize merging functions:+ `merge` to `mergeG`, + `mergeIncremental` to `mergeIncrementalG`, + `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. +++## 0.6.2.0++* Fix `holdDyn` so that it is lazy in its event argument + These produce `DMap`s whose values needn't be `Identity`.+* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).+* Fix `holdDyn` so that it is lazy in its event argument.+ ## 0.6.1.0 -* Re-export all of Data.Map.Monoidal-* Fix QueryT and RequesterT tests+* Re-export all of `Data.Map.Monoidal`+* Fix `QueryT` and `RequesterT` tests++## 0.6.0.0 -- 2019-03-20++* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.+* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.+* Remove many deprecated functions.+* Add a `Num` instance for `Dynamic`.+* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.+* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.+* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.+* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.
README.md view
@@ -1,4 +1,7 @@ ## [Reflex](https://reflex-frp.org/)++[](http://hackage.haskell.org/package/reflex)+ ### Practical Functional Reactive Programming Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.@@ -13,8 +16,6 @@ [Get started with Reflex](https://github.com/reflex-frp/reflex-platform) [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)--[hackage](https://hackage.haskell.org/package/reflex) [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.6.1+Version: 0.6.2.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3@@ -44,13 +44,15 @@ base >= 4.9 && < 4.13, bifunctors >= 5.2 && < 5.6, comonad,+ constraints-extras >= 0.2, containers >= 0.5 && < 0.7, data-default >= 0.5 && < 0.8,- dependent-map >= 0.2.4 && < 0.3,+ dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*,+ profunctors, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1,- monoidal-containers == 0.4.*,+ monoidal-containers >= 0.4 && < 0.6, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7,@@ -61,7 +63,7 @@ semigroups >= 0.16 && < 0.19, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8,- these >= 0.4 && < 0.7.7,+ these >= 0.4 && < 0.9, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3,@@ -133,8 +135,8 @@ if flag(use-template-haskell) cpp-options: -DUSE_TEMPLATE_HASKELL build-depends:- dependent-sum >= 0.3 && < 0.5,- haskell-src-exts >= 1.16 && < 1.21,+ dependent-sum >= 0.6 && < 0.7,+ haskell-src-exts >= 1.16 && < 1.22, haskell-src-meta >= 0.6 && < 0.9, template-haskell >= 2.9 && < 2.15 exposed-modules:@@ -142,7 +144,7 @@ other-extensions: TemplateHaskell else build-depends:- dependent-sum == 0.4.*+ dependent-sum == 0.6.* if flag(fast-weak) && impl(ghcjs) cpp-options: -DGHCJS_FAST_WEAK
src/Data/AppendMap.hs view
@@ -7,10 +7,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}--- | 'Data.Map' with a better 'Monoid' instance------ 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has--- @mappend = unionWith mappend@ instead.+-- |+-- Module:+-- Data.AppendMap+-- Description:+-- Instances and convenience functions for 'Data.Map.Monoidal'. We use+-- monoidal-containers to take advantage of its better monoid instance.+-- 'Data.Map' has @mappend = union@, which is left-biased. 'MonoidalMap'+-- has @mappend = unionWith mappend@ instead. module Data.AppendMap ( module Data.AppendMap , module Data.Map.Monoidal@@ -30,12 +34,15 @@ import Data.Map.Monoidal {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}+-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap' type AppendMap = MonoidalMap {-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}+-- | A synonym for 'getMonoidalMap' _unAppendMap :: MonoidalMap k v -> Map k v _unAppendMap = getMonoidalMap +-- | Pattern synonym for 'MonoidalMap' pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m @@ -50,6 +57,7 @@ then Nothing else Just deleted +-- | Like 'mapMaybe' but indicates whether the resulting container is empty mapMaybeNoNull :: (a -> Maybe b) -> MonoidalMap token a -> Maybe (MonoidalMap token b)@@ -60,9 +68,11 @@ else Just bs -- TODO: Move instances to `Reflex.Patch`+-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details. showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String showTree = coerce (Map.showTree :: Map k a -> String) +-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string. showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
src/Data/FastMutableIntMap.hs view
@@ -1,4 +1,9 @@ {-# LANGUAGE TypeFamilies #-}+-- |+-- Module:+-- Data.FastMutableIntMap+-- Description:+-- A mutable version of 'IntMap' module Data.FastMutableIntMap ( FastMutableIntMap , new@@ -32,33 +37,43 @@ import Reflex.Patch.Class import Reflex.Patch.IntMap +-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.+-- Operations on 'FastMutableIntMap' run in IO. newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a)) +-- | Create a new 'FastMutableIntMap' out of an 'IntMap' new :: IntMap a -> IO (FastMutableIntMap a) new m = FastMutableIntMap <$> newIORef m +-- | Create a new empty 'FastMutableIntMap' newEmpty :: IO (FastMutableIntMap a) newEmpty = FastMutableIntMap <$> newIORef IntMap.empty +-- | Insert an element into a 'FastMutableIntMap' at the given key insert :: FastMutableIntMap a -> Int -> a -> IO () insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v +-- | Attempt to lookup an element by key in a 'FastMutableIntMap' lookup :: FastMutableIntMap a -> Int -> IO (Maybe a) lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r +-- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap' forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m () forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do a <- liftIO $ readIORef r traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b +-- | Runs the provided action over the values of a 'FastMutableIntMap' for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m () for_ (FastMutableIntMap r) f = do a <- liftIO $ readIORef r traverse_ f a +-- | Checks whether a 'FastMutableIntMap' is empty isEmpty :: FastMutableIntMap a -> IO Bool isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r +-- | Retrieves the size of a 'FastMutableIntMap' size :: FastMutableIntMap a -> IO Int size (FastMutableIntMap r) = IntMap.size <$> readIORef r @@ -69,6 +84,8 @@ writeIORef r IntMap.empty return result +-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'),+-- and returns an 'IntMap' with the modified keys and values. applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a) applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do v <- readIORef r
src/Data/FastWeakBag.hs view
@@ -50,7 +50,7 @@ #else data FastWeakBag a = FastWeakBag { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?- , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag' } #endif
src/Data/Functor/Misc.hs view
@@ -52,8 +52,7 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.These import Data.Typeable hiding (Refl) @@ -79,9 +78,6 @@ instance Show k => GShow (Const2 k v) where gshowsPrec n x@(Const2 _) = showsPrec n x -instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where- showTaggedPrec (Const2 _) = showsPrec- instance Eq k => GEq (Const2 k v) where geq (Const2 a) (Const2 b) = if a == b@@ -124,7 +120,7 @@ -- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with -- the keys, using a function to remove the wrapping 'Functor' weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'-weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList -------------------------------------------------------------------------------- -- WrapArg@@ -213,11 +209,6 @@ gshowsPrec _ a = case a of LeftTag -> showString "LeftTag" RightTag -> showString "RightTag"--instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where- showTaggedPrec t n (Identity a) = case t of- LeftTag -> showsPrec n a- RightTag -> showsPrec n a -- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
src/Reflex/Adjustable/Class.hs view
@@ -11,6 +11,13 @@ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif+-- |+-- Module:+-- Reflex.Adjustable.Class+-- Description:+-- A class for actions that can be "adjusted" over time based on some 'Event'+-- such that, when observed after the firing of any such 'Event', the result+-- is as though the action was originally run with the 'Event's value. module Reflex.Adjustable.Class ( -- * The Adjustable typeclass@@ -94,13 +101,32 @@ r <- ask lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm' -sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))+-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches+-- to the 'DMap' can add, remove, or update values.+sequenceDMapWithAdjust+ :: (GCompare k, Adjustable t m)+ => DMap k m+ -> Event t (PatchDMap k m)+ -> m (DMap k Identity, Event t (PatchDMap k Identity)) sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity -sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))+-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches+-- to the 'DMap' can add, remove, update, move, or swap values.+sequenceDMapWithAdjustWithMove+ :: (GCompare k, Adjustable t m)+ => DMap k m+ -> Event t (PatchDMapWithMove k m)+ -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity)) sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity -mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))+-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map'+-- can add, remove, update, move, or swap values.+mapMapWithAdjustWithMove+ :: forall t m k v v'. (Adjustable t m, Ord k)+ => (k -> v -> m v')+ -> Map k v+ -> Event t (PatchMapWithMove k v)+ -> m (Map k v', Event t (PatchMapWithMove k v')) mapMapWithAdjustWithMove f m0 m' = do (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m') return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')@@ -110,4 +136,5 @@ -------------------------------------------------------------------------------- {-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}+-- | Synonym for 'Adjustable' type MonadAdjust = Adjustable
src/Reflex/Class.hs view
@@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Trustworthy #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif@@ -40,12 +41,16 @@ , MonadHold (..) -- ** 'fan' related types , EventSelector (..)+ , EventSelectorG (..) , EventSelectorInt (..) -- * Convenience functions , constDyn , pushAlways -- ** Combining 'Event's , leftmost+ , merge+ , mergeIncremental+ , mergeIncrementalWithMove , mergeMap , mergeIntMap , mergeMapIncremental@@ -60,6 +65,7 @@ , alignEventWithMaybe -- ** Breaking up 'Event's , splitE+ , fan , fanEither , fanThese , fanMap@@ -84,6 +90,7 @@ , gate -- ** Combining 'Dynamic's , distributeDMapOverDynPure+ , distributeDMapOverDynPureG , distributeListOverDyn , distributeListOverDynWith , zipDyn@@ -193,8 +200,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Semigroup (Semigroup, sconcat, stimes, (<>))-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.String import Data.These import Data.Type.Coercion@@ -256,11 +262,16 @@ -- | Merge a collection of events; the resulting 'Event' will only occur if at -- least one input event is occurring, and will contain all of the input keys -- that are occurring simultaneously- merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty- -- | Efficiently fan-out an event to many destinations. This function should- -- be partially applied, and then the result applied repeatedly to create- -- child events- fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it++ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))+ -> DMap k q -> Event t (DMap k v)++ -- | Efficiently fan-out an event to many destinations. You should save the+ -- result in a @let@-binding, and then repeatedly 'selectG' on the result to+ -- create child events+ fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v+ -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a@@ -278,9 +289,14 @@ -- that value. unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p -- | Create a merge whose parents can change over time- mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)+ mergeIncrementalG :: GCompare k+ => (forall a. q a -> Event t (v a))+ -> Incremental t (PatchDMap k q)+ -> Event t (DMap k v) -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental- mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)+ mergeIncrementalWithMoveG :: GCompare k+ => (forall a. q a -> Event t (v a))+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v) -- | Extract the 'Behavior' component of an 'Incremental' currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p) -- | Extract the 'Event' component of an 'Incremental'@@ -299,7 +315,21 @@ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) fanInt :: Event t (IntMap a) -> EventSelectorInt t a +-- | Efficiently fan-out an event to many destinations. You should save the+-- result in a @let@-binding, and then repeatedly 'select' on the result to+-- create child events+fan :: forall t k. (Reflex t, GCompare k)+ => Event t (DMap k Identity) -> EventSelector t k+ --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it+fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)+ where+ fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a+ fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of+ Coercion -> coerce+ --TODO: Specialize this so that we can take advantage of knowing that there's no changing going on+-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple+-- keys simultaneously. mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a) mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never @@ -368,26 +398,91 @@ -- the supplied 'Event'. headE :: Event t a -> m (Event t a) -accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p)+-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',+-- using the combining function to produce a patch.+accumIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> p)+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p) accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o-accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p)++-- | Similar to 'accumIncremental' but the combining function runs in 'PushM'+accumMIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> PushM t p)+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p) accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o-accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p)++-- | Similar to 'accumIncremental' but allows filtering of updates (by dropping updates when the+-- combining function produces @Nothing@)+accumMaybeIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> Maybe p)+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p) accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o-accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p)++-- | Similar to 'accumMaybeMIncremental' but the combining function runs in 'PushM'+accumMaybeMIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> PushM t (Maybe p))+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p) accumMaybeMIncremental f z e = do rec let e' = flip push e $ \o -> do v <- sample $ currentIncremental d' f v o d' <- holdIncremental z e' return d'-mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)++-- | Accumulate an 'Incremental' by folding occurrences of an 'Event'+-- with a function that both accumulates and produces a value to fire+-- as an 'Event'. Returns both the accumulated value and the constructed+-- 'Event'.+mapAccumIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> (p, c))+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p, Event t c) mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o-mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)++-- | Like 'mapAccumIncremental' but the combining function runs in 'PushM'+mapAccumMIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> PushM t (p, c))+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p, Event t c) mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o-mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)++-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' with+-- a function that both optionally accumulates and optionally produces+-- a value to fire as a separate output 'Event'.+-- Note that because 'Nothing's are discarded in both cases, the output+-- 'Event' may fire even though the output 'Incremental' has not changed, and+-- the output 'Incremental' may update even when the output 'Event' is not firing.+mapAccumMaybeIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> (Maybe p, Maybe c))+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p, Event t c) mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o-mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)++-- | Like 'mapAccumMaybeIncremental' but the combining function is a 'PushM' action+mapAccumMaybeMIncremental+ :: (Reflex t, Patch p, MonadHold t m, MonadFix m)+ => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c))+ -> PatchTarget p+ -> Event t b+ -> m (Incremental t p, Event t c) mapAccumMaybeMIncremental f z e = do rec let e' = flip push e $ \o -> do v <- sample $ currentIncremental d'@@ -398,6 +493,7 @@ d' <- holdIncremental z $ mapMaybe fst e' return (d', mapMaybe snd e') +-- | A somewhat slow implementation of 'headE' slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) slowHeadE e = do rec be <- hold e $ fmapCheap (const never) e'@@ -418,6 +514,19 @@ select :: forall a. k a -> Event t a } +newtype EventSelectorG t k v = EventSelectorG+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is+ -- determined by the type of the key, so this can be used to fan-out+ -- 'Event's whose sub-'Event's have different types.+ --+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than+ -- (but equivalent to) using 'mapMaybe' to select only the relevant+ -- occurrences of an 'Event'.+ selectG :: forall a. k a -> Event t (v a)+ }++-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually+-- filtering by key. newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a } --------------------------------------------------------------------------------@@ -801,7 +910,12 @@ mergeList [] = never mergeList es = mergeWithFoldCheap' id es -unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'+unsafeMapIncremental+ :: (Reflex t, Patch p, Patch p')+ => (PatchTarget p -> PatchTarget p')+ -> (p -> p')+ -> Incremental t p+ -> Incremental t p' unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a -- | Create a new 'Event' combining the map of 'Event's into an 'Event' that@@ -918,6 +1032,9 @@ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } ] +-- | Given a 'PatchTarget' of events (e.g., a 'Map' with 'Event' values) and an event of 'Patch'es+-- (e.g., a 'PatchMap' with 'Event' values), produce an 'Event' of the 'PatchTarget' type that+-- fires with the patched value. switchHoldPromptOnlyIncremental :: forall t m p pt w . ( Reflex t@@ -942,8 +1059,12 @@ instance Reflex t => Align (Event t) where nil = never+#if MIN_VERSION_these(0, 8, 0)+instance Reflex t => Semialign (Event t) where+#endif align = alignEventWithMaybe Just + -- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and -- the 'Behavior' is true at the time of occurrence. gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a@@ -998,12 +1119,21 @@ -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same -- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)-distributeDMapOverDynPure dm = case DMap.toList dm of+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic++-- | This function converts a 'DMap' whose elements are 'Dynamic's into a+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.+distributeDMapOverDynPureG+ :: forall t k q v. (Reflex t, GCompare k)+ => (forall a. q a -> Dynamic t (v a))+ -> DMap k q -> Dynamic t (DMap k v)+distributeDMapOverDynPureG nt dm = case DMap.toList dm of [] -> constDyn DMap.empty- [k :=> v] -> fmap (DMap.singleton k . Identity) v+ [k :=> v] -> DMap.singleton k <$> nt v _ ->- let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm- edmPre = merge $ DMap.map updated dm+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do olds <- sample $ current result return $ DMap.unionWithKey (\_ _ new -> new) olds news@@ -1015,7 +1145,16 @@ -- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b-distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]+distributeListOverDynWith f =+ fmap (f . map fromDSum . DMap.toAscList) .+ distributeDMapOverDynPure .+ DMap.fromDistinctAscList .+ zipWith toDSum [0..]+ where+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)+ toDSum k v = Const2 k :=> v+ fromDSum :: DSum (Const2 Int a) Identity -> a+ fromDSum (Const2 _ :=> Identity v) = v -- | Create a new 'Event' that occurs when the first supplied 'Event' occurs -- unless the second supplied 'Event' occurs simultaneously.@@ -1064,9 +1203,9 @@ -> Event t (DSum k v) -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v)))) factorEvent k0 kv' = do- key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'+ key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv' let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case- Some.This oldKey -> case newKey `geq` oldKey of+ Some oldKey -> case newKey `geq` oldKey of Just Refl -> return Nothing Nothing -> do newInner <- filterEventKey newKey kv'@@ -1276,7 +1415,7 @@ -> m (Behavior t a, Event t c) mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o --- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action.+-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action. {-# INLINE mapAccumMaybeMB #-} mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) mapAccumMaybeMB f z e = do@@ -1467,6 +1606,23 @@ tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b tagCheap b = pushAlwaysCheap $ \_ -> sample b +-- | Merge a collection of events; the resulting 'Event' will only occur if at+-- least one input event is occurring, and will contain all of the input keys+-- that are occurring simultaneously+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)+merge = mergeG coerceEvent+{-# INLINE merge #-}++-- | Create a merge whose parents can change over time+mergeIncremental :: (Reflex t, GCompare k)+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)+mergeIncremental = mergeIncrementalG coerceEvent++-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental+mergeIncrementalWithMove :: (Reflex t, GCompare k)+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent+ -- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'. {-# INLINE mergeWithCheap #-} mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a@@ -1491,8 +1647,10 @@ -------------------------------------------------------------------------------- {-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}+-- | See 'switchHoldPromptly' switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) switchPromptly = switchHoldPromptly {-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}+-- | See 'switchHoldPromptOnly' switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) switchPromptOnly = switchHoldPromptOnly
src/Reflex/Dynamic.hs view
@@ -203,17 +203,9 @@ -- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with -- non-'Dynamic' elements, preserving the order of the elements.+{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-} distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]-distributeListOverDynPure =- fmap (map fromDSum . DMap.toAscList) .- distributeDMapOverDynPure .- DMap.fromDistinctAscList .- zipWith toDSum [0..]- where- toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)- toDSum k v = Const2 k :=> v- fromDSum :: DSum (Const2 Int a) Identity -> a- fromDSum (Const2 _ :=> Identity v) = v+distributeListOverDynPure = distributeListOverDyn --TODO: Generalize this to functors other than Maps -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'@@ -301,6 +293,8 @@ Left _ -> Nothing Right a -> Just a +-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that+-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right'). eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b))) eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)@@ -308,6 +302,9 @@ LeftTag :=> Compose a -> Left $ coerceDynamic a RightTag :=> Compose b -> Right $ coerceDynamic b +-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values.+-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner+-- 'Dynamic' represents updates within the current key. factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where@@ -322,6 +319,7 @@ inner' <- filterEventKey k (updated d) inner <- holdDyn v inner' return $ k :=> Compose inner+ -------------------------------------------------------------------------------- -- Demux --------------------------------------------------------------------------------
src/Reflex/DynamicWriter/Class.hs view
@@ -17,6 +17,7 @@ import Reflex.Class (Dynamic) {-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-}+-- | Type synonym for 'DynamicWriter' type MonadDynamicWriter = DynamicWriter -- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
src/Reflex/Patch/DMapWithMove.hs view
@@ -19,9 +19,9 @@ import Reflex.Patch.MapWithMove (PatchMapWithMove (..)) import qualified Reflex.Patch.MapWithMove as MapWithMove +import Data.Constraint.Extras import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) import qualified Data.Dependent.Map as DMap-import Data.Dependent.Sum (EqTag (..)) import Data.Functor.Constant import Data.Functor.Misc import Data.Functor.Product@@ -30,8 +30,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Semigroup (Semigroup (..), (<>))-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.These -- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and@@ -105,8 +104,8 @@ unbalancedMove _ = Nothing -- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.-instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where- PatchDMapWithMove a == PatchDMapWithMove b = a == b+instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where+ PatchDMapWithMove a == PatchDMapWithMove b = a == b -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 data Pair1 f g a = Pair1 (f a) (g a)@@ -311,8 +310,8 @@ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of From_Insert v -> MapWithMove.From_Insert $ f v From_Delete -> MapWithMove.From_Delete- From_Move k -> MapWithMove.From_Move $ Some.This k- , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)+ From_Move k -> MapWithMove.From_Move $ Some k+ , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni) } -- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
src/Reflex/Profiled.hs view
@@ -8,6 +8,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} -- | -- Module: -- Reflex.Profiled@@ -16,7 +18,6 @@ -- profiling/cost-center information. module Reflex.Profiled where -import Control.Lens hiding (children) import Control.Monad import Control.Monad.Exception import Control.Monad.Fix@@ -33,6 +34,7 @@ import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) import Data.Ord+import Data.Profunctor.Unsafe ((#.)) import qualified Data.Semigroup as S import Data.Type.Coercion import Foreign.Ptr@@ -133,17 +135,19 @@ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e pull = Behavior_Profiled . pull . coerce- merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)- merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))- fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)+ fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)+ mergeG :: forall (k :: z -> *) q v. GCompare k+ => (forall a. q a -> Event (ProfiledTimeline t) (v a))+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)+ mergeG nt = Event_Profiled #. mergeG (coerce nt) switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b) coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e) current (Dynamic_Profiled d) = coerce $ current d updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a' unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'- mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))- mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))+ mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
src/Reflex/Pure.hs view
@@ -5,6 +5,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif@@ -43,10 +46,11 @@ import Data.Monoid import Data.Type.Coercion import Reflex.Class+import Data.Kind (Type) -- | A completely pure-functional 'Reflex' timeline, identifying moments in time -- with the type @/t/@.-data Pure t+data Pure (t :: Type) -- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist -- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used@@ -79,17 +83,18 @@ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a -- warning because the GCompare instance is not used; however, removing the -- GCompare instance produces a different warning, due to that constraint- -- being present in the original class definition+ -- being present in the original class definition. - --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)- merge events = Event $ memo $ \t ->- let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))+ -- -> DMap k q -> Event (Pure t) (DMap k v)+ mergeG nt events = Event $ memo $ \t ->+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events in if DMap.null currentOccurrences then Nothing else Just currentOccurrences - fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k- fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k+ -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v+ fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t@@ -112,8 +117,8 @@ --a) -> Incremental (Pure t) p a unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) - mergeIncremental = mergeIncrementalImpl- mergeIncrementalWithMove = mergeIncrementalImpl+ mergeIncrementalG = mergeIncrementalImpl+ mergeIncrementalWithMoveG = mergeIncrementalImpl currentIncremental i = Behavior $ \t -> fst $ unIncremental i t @@ -133,9 +138,11 @@ mergeIntIncremental = mergeIntIncrementalImpl -mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)-mergeIncrementalImpl i = Event $ \t ->- let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t+mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)+ => (forall a. q a -> Event (Pure t) (v a))+ -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)+mergeIncrementalImpl nt i = Event $ \t ->+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t in if DMap.null results then Nothing else Just results
src/Reflex/Query/Base.hs view
@@ -38,8 +38,7 @@ import qualified Data.Map as Map import Data.Monoid ((<>)) import qualified Data.Semigroup as S-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.These import Reflex.Class@@ -145,10 +144,10 @@ liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p liftedBs0 :: Map (Some k) [Behavior t q]- liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q]) liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $- Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty accumBehaviors :: forall m'. MonadHold t m'@@ -189,10 +188,10 @@ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose) liftedBs0 :: Map (Some k) [Behavior t q]- liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q]) liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $- Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -} sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty accumBehaviors' :: forall m'. MonadHold t m'
src/Reflex/Query/Class.hs view
@@ -6,6 +6,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+-- |+-- Module:+-- Reflex.Query.Class+-- Description:+-- A class that ties together queries to some data source and their results,+-- providing methods for requesting data from the source and accumulating+-- streamed results. module Reflex.Query.Class ( Query (..) , QueryMorphism (..)@@ -32,6 +39,10 @@ import Reflex.Class +-- | A 'Query' can be thought of as a declaration of interest in some set of data.+-- A 'QueryResult' is the set of data associated with that interest set.+-- The @crop@ function provides a way to determine what part of a given 'QueryResult'+-- is relevant to a given 'Query'. class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where type QueryResult a :: * crop :: a -> QueryResult a -> QueryResult a@@ -40,8 +51,8 @@ type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) crop q r = MonoidalMap.intersectionWith (flip crop) r q --- | NB: QueryMorphism's must be group homomorphisms when acting on the query type--- and compatible with the query relationship when acting on the query result+-- | QueryMorphism's must be group homomorphisms when acting on the query type+-- and compatible with the query relationship when acting on the query result. data QueryMorphism q q' = QueryMorphism { _queryMorphism_mapQuery :: q -> q' , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q@@ -54,13 +65,16 @@ , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm } +-- | Apply a 'QueryMorphism' to a 'Query' mapQuery :: QueryMorphism q q' -> q -> q' mapQuery = _queryMorphism_mapQuery +-- | Map a 'QueryMorphism' to a 'QueryResult' mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q mapQueryResult = _queryMorphism_mapQueryResult --- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app+-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on+-- 'combineSelectedCounts' newtype SelectedCount = SelectedCount { unSelectedCount :: Int } deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data) @@ -76,10 +90,14 @@ instance Additive SelectedCount --- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted.+-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use+-- this function which returns Nothing if the result is 0. This allows the pruning of leaves+-- of the 'Query' that are no longer wanted. combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j) +-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly+-- used interface. class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where tellQueryIncremental :: Incremental t (AdditivePatch q) -> m () askQueryResult :: m (Dynamic t (QueryResult q))@@ -90,9 +108,11 @@ askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental +-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'. tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m () tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d) +-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'. queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q)) queryDyn q = do tellQueryDyn q
src/Reflex/Requester/Base.hs view
@@ -66,8 +66,7 @@ import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Semigroup as S-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.Type.Equality import Data.Unique.Tag @@ -441,7 +440,7 @@ pack = Entry f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a) f' k (Compose (n, v)) = do- (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))+ (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'
src/Reflex/Spider/Internal.hs view
@@ -17,9 +17,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE InstanceSigs #-}+ #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@@ -49,6 +53,7 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef+import Data.Kind (Type) import Data.Maybe hiding (mapMaybe) import Data.Monoid ((<>)) import Data.Proxy@@ -74,9 +79,9 @@ import Data.FastWeakBag (FastWeakBag) import qualified Data.FastWeakBag as FastWeakBag import Data.Reflection-import Data.Some (Some)-import qualified Data.Some as Some+import Data.Some (Some(Some)) import Data.Type.Coercion+import Data.Profunctor.Unsafe ((#.), (.#)) import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children) import qualified Data.WeakBag as WeakBag import qualified Reflex.Class@@ -193,12 +198,6 @@ newNodeId :: IO Int newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)--{-# NOINLINE unsafeNodeId #-}-unsafeNodeId :: a -> Int-unsafeNodeId a = unsafePerformIO $ do- touch a- newNodeId #endif --------------------------------------------------------------------------------@@ -302,9 +301,10 @@ #else Event $ #endif- let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))- !mSubscribedRef = unsafeNewIORef e emptyFastWeak- in \sub -> {-# SCC "cacheEvent" #-} do+ unsafePerformIO $ do+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))+ <- newIORef emptyFastWeak+ pure $ \sub -> {-# SCC "cacheEvent" #-} do #ifdef DEBUG_TRACE_EVENTS unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite #endif@@ -370,7 +370,7 @@ eventNever :: Event x a eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing) -eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a) eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a@@ -422,14 +422,14 @@ , subscriberRecalculateHeight = \_ -> return () } -newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v)) newSubscriberFan subscribed = return $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a scheduleClear $ fanSubscribedOccurrence subscribed- let f _ (Pair (Identity v) subsubs) = do+ let f _ (Pair v subsubs) = do propagate v $ _fanSubscribedChildren_list subsubs return $ Constant () _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_@@ -577,12 +577,12 @@ #endif } -eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x eventSubscribedFan !subscribed = EventSubscribed { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed , eventSubscribedRetained = toAny subscribed #ifdef DEBUG_CYCLES- , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed] , eventSubscribedHasOwnHeightRef = False , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed #endif@@ -595,7 +595,7 @@ #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do s <- readIORef $ switchSubscribedCurrentParent subscribed- return [Some.This $ _eventSubscription_subscribed s]+ return [Some $ _eventSubscription_subscribed s] , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed #endif@@ -608,8 +608,8 @@ #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed- let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed- innerParents = maybeToList $ fmap Some.This innerSubscription+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed+ innerParents = maybeToList $ fmap Some innerSubscription return $ outerParent : innerParents , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed@@ -625,13 +625,13 @@ walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)] walkInvalidHeightParents s0 = do- subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do+ subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do h <- liftIO $ readIORef $ eventSubscribedHeightRef s when (h == invalidHeight) $ do when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed- modify (Some.This s :)+ modify (Some s :) mapM_ loop =<< liftIO (eventSubscribedGetParents s)- forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight+ forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight return subscribers #endif @@ -659,7 +659,7 @@ val <- liftIO $ readIORef $ pullValue p case val of Just subscribed -> do- askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :)) askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) liftIO $ touch $ pullSubscribedOwnInvalidator subscribed return $ pullSubscribedValue subscribed@@ -678,7 +678,7 @@ , pullSubscribedParents = parents } liftIO $ writeIORef (pullValue p) $ Just subscribed- askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :)) return a behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)@@ -689,7 +689,7 @@ readHoldTracked h = do result <- liftIO $ readIORef $ holdValue h askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))- askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))+ 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 @@ -705,7 +705,7 @@ data Dynamic x p = Dynamic { dynamicCurrent :: !(Behavior x (PatchTarget p))- , dynamicUpdated :: !(Event x p)+ , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`? } dynamicHold :: Hold x p -> Dynamic x p@@ -782,9 +782,9 @@ , eventEnvDynInits :: !(IORef [SomeDynInit x]) , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x]) , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe- , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe- , eventEnvIntClears :: !(IORef [SomeIntClear])- , eventEnvRootClears :: !(IORef [SomeRootClear])+ , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe+ , eventEnvIntClears :: !(IORef [Some IntClear])+ , eventEnvRootClears :: !(IORef [Some RootClear]) , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))@@ -856,29 +856,29 @@ heightRef <- asksEventEnv eventEnvCurrentHeight liftIO $ writeIORef heightRef $! h -instance HasSpiderTimeline x => Defer SomeClear (EventM x) where+instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvClears {-# INLINE scheduleClear #-}-scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()-scheduleClear r = defer $ SomeClear r+scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()+scheduleClear r = defer $ Some $ Clear r -instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where+instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvIntClears {-# INLINE scheduleIntClear #-}-scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()-scheduleIntClear r = defer $ SomeIntClear r+scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()+scheduleIntClear r = defer $ Some $ IntClear r -instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where+instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvRootClears {-# INLINE scheduleRootClear #-}-scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()-scheduleRootClear r = defer $ SomeRootClear r+scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()+scheduleRootClear r = defer $ Some $ RootClear r instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where {-# INLINE getDeferralQueue #-}@@ -951,7 +951,7 @@ = forall p. BehaviorSubscribedHold (Hold x p) | BehaviorSubscribedPull (PullSubscribed x a) -data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)+newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x)) --type role PullSubscribed representational data PullSubscribed x a@@ -986,7 +986,7 @@ #endif } -data Root x (k :: * -> *)+data Root x k = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event , rootSubscribed :: !(IORef (DMap k (RootSubscribed x))) , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))@@ -1056,25 +1056,25 @@ heightBagVerify = id #endif -data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren- { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))- , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)- , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))+data FanSubscribedChildren x k v a = FanSubscribedChildren+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v))) } -data FanSubscribed (x :: *) k- = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))- , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))- , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty+data FanSubscribed x k v+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty , fanSubscribedParent :: !(EventSubscription x) #ifdef DEBUG_NODEIDS , fanSubscribedNodeId :: Int #endif } -data Fan x k- = Fan { fanParent :: !(Event x (DMap k Identity))- , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))+data Fan x k v+ = Fan { fanParent :: !(Event x (DMap k v))+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v))) } data SwitchSubscribed x a@@ -1133,13 +1133,17 @@ instance HasSpiderTimeline x => Align (Event x) where nil = eventNever- align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]+#if MIN_VERSION_these(0, 8, 0)+instance HasSpiderTimeline x => Semialign (Event x) where+#endif+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) | HoldDyn !(Hold x p) -newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) } newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)@@ -1168,18 +1172,12 @@ return d unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p-unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x- where x = (readV0, v')+unsafeBuildDynamic readV0 v' =+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v') -- ResultM can read behaviors and events type ResultM = EventM -{-# NOINLINE unsafeNewIORef #-}-unsafeNewIORef :: a -> b -> IORef b-unsafeNewIORef a b = unsafePerformIO $ do- touch a- newIORef b- instance HasSpiderTimeline x => Functor (Event x) where fmap f = push $ return . Just . f @@ -1192,26 +1190,35 @@ {-# INLINABLE pull #-} pull :: BehaviorM x a -> Behavior x a-pull a = behaviorPull $ Pull- { pullCompute = a- , pullValue = unsafeNewIORef a Nothing+pull a = unsafePerformIO $ do+ ref <- newIORef Nothing #ifdef DEBUG_NODEIDS- , pullNodeId = unsafeNodeId a+ nid <- newNodeId #endif- }+ pure $ behaviorPull $ Pull+ { pullCompute = a+ , pullValue = ref+#ifdef DEBUG_NODEIDS+ , pullNodeId = nid+#endif+ } {-# INLINABLE switch #-} switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a-switch a = eventSwitch $ Switch- { switchParent = a- , switchSubscribed = unsafeNewIORef a Nothing- }+switch a = unsafePerformIO $ do+ ref <- newIORef Nothing+ pure $ eventSwitch $ Switch+ { switchParent = a+ , switchSubscribed = ref+ } coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a-coincidence a = eventCoincidence $ Coincidence- { coincidenceParent = a- , coincidenceSubscribed = unsafeNewIORef a Nothing- }+coincidence a = unsafePerformIO $ do+ ref <- newIORef Nothing+ pure $ eventCoincidence $ Coincidence+ { coincidenceParent = a+ , coincidenceSubscribed = ref+ } -- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b@@ -1256,11 +1263,11 @@ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?) EQ -> a -data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))+newtype Clear a = Clear (IORef (Maybe a)) -data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))+newtype IntClear a = IntClear (IORef (IntMap a)) -data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))+newtype RootClear k = RootClear (IORef (DMap k Identity)) data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a @@ -1415,6 +1422,9 @@ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit" uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) writeIORef uninitRef $! uninit+#ifdef DEBUG_NODEIDS+ nid <- newNodeId+#endif let !subscribed = RootSubscribed { rootSubscribedKey = k , rootSubscribedCachedSubscribed = cached@@ -1423,7 +1433,7 @@ , rootSubscribedUninit = uninit , rootSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS- , rootSubscribedNodeId = unsafeNodeId (k, r, subs)+ , rootSubscribedNodeId = nid #endif } -- If we die at the same moment that all our children die, they will@@ -1472,16 +1482,10 @@ , _fanInt_occRef = occRef } -{-# NOINLINE unsafeNewFanInt #-}-unsafeNewFanInt :: b -> FanInt x a-unsafeNewFanInt b = unsafePerformIO $ do- touch b- newFanInt- fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a-fanInt p =- let self = unsafeNewFanInt p- in EventSelectorInt $ \k -> Event $ \sub -> do+fanInt p = unsafePerformIO $ do+ self <- newFanInt+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self) when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input (subscription, parentOcc) <- subscribeAndRead p $ Subscriber@@ -1517,7 +1521,7 @@ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) {-# INLINABLE getFanSubscribed #-}-getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a)) getFanSubscribed k f sub = do mSubscribed <- liftIO $ readIORef $ fanSubscribed f case mSubscribed of@@ -1535,13 +1539,16 @@ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized" occRef <- liftIO $ newIORef parentOcc when (isJust parentOcc) $ scheduleClear occRef+#ifdef DEBUG_NODEIDS+ nid <- liftIO newNodeId+#endif let subscribed = FanSubscribed { fanSubscribedCachedSubscribed = fanSubscribed f , fanSubscribedOccurrence = occRef , fanSubscribedParent = subscription , fanSubscribedSubscribers = subscribersRef #ifdef DEBUG_NODEIDS- , fanSubscribedNodeId = unsafeNodeId f+ , fanSubscribedNodeId = nid #endif } let !self = (k, subscribed)@@ -1551,7 +1558,7 @@ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc) -cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO () cleanupFanSubscribed (k, subscribed) = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed let reducedSubscribers = DMap.delete k subscribers@@ -1563,7 +1570,7 @@ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers {-# INLINE subscribeFanSubscribed #-}-subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket subscribeFanSubscribed k subscribed sub = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed case DMap.lookup k subscribers of@@ -1601,6 +1608,9 @@ when (isJust parentOcc) $ scheduleClear occRef weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed+#ifdef DEBUG_NODEIDS+ nid <- liftIO newNodeId+#endif let !subscribed = SwitchSubscribed { switchSubscribedCachedSubscribed = switchSubscribed s , switchSubscribedOccurrence = occRef@@ -1613,7 +1623,7 @@ , switchSubscribedCurrentParent = subscriptionRef , switchSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS- , switchSubscribedNodeId = unsafeNodeId s+ , switchSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"@@ -1658,6 +1668,9 @@ scheduleClear innerSubdRef weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed+#ifdef DEBUG_NODEIDS+ nid <- liftIO newNodeId+#endif let subscribed = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c , coincidenceSubscribedOccurrence = occRef@@ -1668,7 +1681,7 @@ , coincidenceSubscribedInnerParent = innerSubdRef , coincidenceSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS- , coincidenceSubscribedNodeId = unsafeNodeId c+ , coincidenceSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"@@ -1685,26 +1698,34 @@ subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed -{-# INLINE merge #-}-merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)-merge d = cacheEvent (mergeCheap d)+{-# INLINE mergeG #-}+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)+ => (forall a. q a -> Event x (v a))+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)+mergeG nt d = cacheEvent (mergeCheap nt d) {-# INLINE mergeWithMove #-}-mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)-mergeWithMove d = cacheEvent (mergeCheapWithMove d)+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)+ => (forall a. q a -> Event x (v a))+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d) {-# INLINE [1] mergeCheap #-}-mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)-mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy+mergeCheap+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)+ => (forall a. q a -> Event x (v a))+ -> Dynamic x (PatchDMap k q)+ -> Event x (DMap k v)+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy where- updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x) updateMe subscriber heightBagRef oldParents (PatchDMap p) = do let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do (mOldSubd, newPs) <- case me of Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps Just e -> do let s = subscriber $ return k- subscription@(EventSubscription _ subd) <- subscribe e s+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s newParentHeight <- liftIO $ getEventSubscribedHeight subd let newParent = MergeSubscribedParent subscription liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight@@ -1714,28 +1735,33 @@ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs) foldM f ([], oldParents) $ DMap.toList p- getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)++ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do let s = subscriber $ return k- (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd- return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers )+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub {-# INLINE [1] mergeCheapWithMove #-}-mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)-mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)+ => (forall a. q a -> Event x (v a))+ -> Dynamic x (PatchDMapWithMove k q)+ -> Event x (DMap k v)+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy where- updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k) updateMe subscriber heightBagRef oldParents p = do -- Prepare new parents for insertion- let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a) subscribeParent k e = do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef@@ -1744,9 +1770,9 @@ newParentHeight <- getEventSubscribedHeight subd modifyIORef' heightBagRef $ heightBagAdd newParentHeight return $ MergeSubscribedParentWithMove subscription keyRef- p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p -- Collect old parents for deletion and update the keys of moved parents- let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of Nothing -> do oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent@@ -1757,46 +1783,47 @@ return Nothing toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents return (toDelete, applyAlways p' oldParents)- getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef- (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd- return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers )+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub -type MergeUpdateFunc k x p s- = (forall a. EventM x (k a) -> Subscriber x a)+type MergeUpdateFunc k v x p s+ = (forall a. EventM x (k a) -> Subscriber x (v a)) -> IORef HeightBag -> DMap k s -> p -> EventM x ([EventSubscription x], DMap k s) -type MergeInitFunc k x s- = DMap k (Event x)- -> (forall a. EventM x (k a) -> Subscriber x a)- -> EventM x (DMap k Identity, [Height], DMap k s)+type MergeInitFunc k v q x s+ = DMap k q+ -> (forall a. EventM x (k a) -> Subscriber x (v a))+ -> EventM x (DMap k v, [Height], DMap k s) type MergeDestroyFunc k s = DMap k s -> IO () -data Merge x k s = Merge+data Merge x k v s = Merge { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s)) , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag) , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)- , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))- , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v)) } -invalidateMergeHeight :: Merge x k s -> IO ()+invalidateMergeHeight :: Merge x k v s -> IO () invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m) invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()@@ -1806,8 +1833,7 @@ writeIORef heightRef $! invalidHeight subscriberInvalidateHeight sub oldHeight --revalidateMergeHeight :: Merge x k s -> IO ()+revalidateMergeHeight :: Merge x k v s -> IO () revalidateMergeHeight m = do currentHeight <- readIORef $ _merge_heightRef m when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check@@ -1823,19 +1849,19 @@ subscriberRecalculateHeight (_merge_sub m) height GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge" -scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x () scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do vals <- liftIO $ readIORef $ _merge_accumRef m liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a) mergeSubscriber m getKey = Subscriber { subscriberPropagate = \a -> do oldM <- liftIO $ readIORef $ _merge_accumRef m k <- getKey- let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM) liftIO $ writeIORef (_merge_accumRef m) $! newM when (DMap.null oldM) $ do -- Only schedule the firing once@@ -1850,7 +1876,7 @@ else liftIO $ do #ifdef DEBUG_CYCLES nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed- stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es let cycleInfo = ":\n" <> drawForest (listsToForest stacks) #else let cycleInfo = ""@@ -1866,7 +1892,7 @@ } --TODO: Be able to run as much of this as possible promptly-updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) where updateMe = do oldParents <- liftIO $ readIORef $ _merge_parentsRef m@@ -1874,9 +1900,10 @@ liftIO $ writeIORef (_merge_parentsRef m) $! newParents return subscriptionsToKill -{-# INLINE mergeCheap' #-}-mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)-mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do+{-# INLINE mergeGCheap' #-}+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"@@ -2025,14 +2052,16 @@ ) newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } -fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k-fan e =+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v+fanG e = unsafePerformIO $ do+ ref <- newIORef Nothing let f = Fan { fanParent = e- , fanSubscribed = unsafeNewIORef e Nothing+ , fanSubscribed = ref }- in EventSelector $ \k -> eventFan k f+ pure $ EventSelectorG $ \k -> eventFan k f runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () runHoldInits holdInitRef dynInitRef mergeInitRef = do@@ -2093,11 +2122,11 @@ return result result <- runEventM go toClear <- readIORef $ eventEnvClears env- forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing toClearInt <- readIORef $ eventEnvIntClears env- forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty toClearRoot <- readIORef $ eventEnvRootClears env- forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty toAssign <- readIORef $ eventEnvAssignments env toReconnectRef <- newIORef [] coincidenceInfos <- readIORef $ eventEnvResetCoincidences env@@ -2457,9 +2486,9 @@ -- | Create a new SpiderTimelineEnv newSpiderTimeline :: IO (Some SpiderTimelineEnv)-newSpiderTimeline = withSpiderTimeline (pure . Some.This)+newSpiderTimeline = withSpiderTimeline (pure . Some) -data LocalSpiderTimeline x s+data LocalSpiderTimeline (x :: Type) s instance Reifies s (SpiderTimelineEnv x) => HasSpiderTimeline (LocalSpiderTimeline x s) where@@ -2477,11 +2506,11 @@ env <- unsafeNewSpiderTimelineEnv reify env $ \s -> k $ localSpiderTimeline s env -newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) type ComputeM = EventM -newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}@@ -2501,10 +2530,15 @@ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent {-# INLINABLE pull #-} pull = SpiderBehavior . pull . coerce- {-# INLINABLE merge #-}- merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))- {-# INLINABLE fan #-}- fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))+ {-# INLINABLE fanG #-}+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))+ {-# INLINABLE mergeG #-}+ mergeG+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))+ -> DMap k q+ -> R.Event (SpiderTimeline x) (DMap k v)+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst {-# INLINABLE switch #-} switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior {-# INLINABLE coincidence #-}@@ -2517,10 +2551,10 @@ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' {-# INLINABLE unsafeBuildIncremental #-} unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv- {-# INLINABLE mergeIncremental #-}- mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental- {-# INLINABLE mergeIncrementalWithMove #-}- mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental+ {-# INLINABLE mergeIncrementalG #-}+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental+ {-# INLINABLE mergeIncrementalWithMoveG #-}+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental {-# INLINABLE currentIncremental #-} currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental {-# INLINABLE updatedIncremental #-}@@ -2558,7 +2592,7 @@ atomicModifyRef r f = liftIO $ atomicModifyRef r f -- | The monad for actions that manipulate a Spider timeline identified by @x@-newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHost x) where {-# INLINABLE (>>=) #-}@@ -2580,7 +2614,7 @@ runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a runSpiderHostForTimeline (SpiderHost a) _ = a -newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHostFrame x) where
src/Reflex/Workflow.hs view
@@ -41,7 +41,7 @@ eReplace <- fmap switch $ hold never $ fmap snd eResult return $ fmap fst eResult --- | Map a function over a 'Workflow', possibly changing the resturn type.+-- | Map a function over a 'Workflow', possibly changing the return type. mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
test/GC.hs view
@@ -27,6 +27,7 @@ import System.Exit import System.Mem+import Data.Coerce main :: IO () main = do@@ -46,7 +47,7 @@ eventToPerform <- Host.runHostFrame $ do (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) <- S.SpiderHostFrame- $ fmap ( S.merge+ $ fmap ( S.mergeG coerce . S.dynamicHold) $ S.hold DMap.empty -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained@@ -55,8 +56,8 @@ { S.subscriberPropagate = S.subscriberPropagate sub } return (s, o))- $ runIdentity <$> S.select- (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)+ $ runIdentity . runIdentity <$> S.selectG+ (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) (WrapArg Request) return $ alignWith (mergeThese (<>)) (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do