32fc50f · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

WIP: Add Int-specialized operations

32fc50fRyan Trinkle9 years ago

reflex.cabal+4

compare with develop

unifiedsplit

@@ -49,6 +49,7 @@ library

49 MemoTrie == 0.6.*,

50 base >= 4.7 && < 4.11,

51 bifunctors >= 5.2 && < 5.5,

52+ comonad,

52 containers == 0.5.*,

53 containers == 0.5.*,

53 data-default >= 0.5 && < 0.8,

54 data-default >= 0.5 && < 0.8,

54 dependent-map >= 0.2.4 && < 0.3,

55 dependent-map >= 0.2.4 && < 0.3,

@@ -63,6 +64,7 @@ library

63 semigroupoids >= 4.0 && < 6,

64 semigroupoids >= 4.0 && < 6,

64 semigroups >= 0.16 && < 0.19,

65 semigroups >= 0.16 && < 0.19,

65 stm == 2.4.*,

66 stm == 2.4.*,

67+ structs == 0.1,

66 syb >= 0.5 && < 0.7,

68 syb >= 0.5 && < 0.7,

67 these >= 0.4 && < 0.8,

69 these >= 0.4 && < 0.8,

68 transformers >= 0.2,

70 transformers >= 0.2,

@@ -73,6 +75,7 @@ library

73 Data.Functor.Misc,

75 Data.Functor.Misc,

74 Data.WeakBag,

76 Data.WeakBag,

75 Data.FastWeakBag,

77 Data.FastWeakBag,

78+ Data.FastMutableIntMap,

76 Reflex,

79 Reflex,

77 Reflex.Class,

80 Reflex.Class,

78 Reflex.EventWriter,

81 Reflex.EventWriter,

@@ -187,6 +190,7 @@ test-suite hlint

187 , hlint == 1.9.*

190 , hlint == 1.9.*

188 if impl(ghcjs)

191 if impl(ghcjs)

189 buildable: False

192 buildable: False

193+ buildable: False

190

194

191test-suite EventWriterT

195test-suite EventWriterT

192 type: exitcode-stdio-1.0

196 type: exitcode-stdio-1.0

src/Data/FastMutableIntMap.hsnew file+100

@@ -0,0 +1,100 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveTraversable #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE TypeFamilies #-}

6+module Data.FastMutableIntMap

7+ ( FastMutableIntMap

8+ , new

9+ , newEmpty

10+ , insert

11+ , isEmpty

12+ , getFrozenAndClear

13+ , size

14+ , applyPatch

15+ , PatchIntMap (..)

16+ , traverseIntMapPatchWithKey

17+ , lookup

18+ , forIntersectionWithImmutable_

19+ , for_

20+ , patchIntMapNewElements

21+ , patchIntMapNewElementsMap

22+ , getDeletions

23+ ) where

24+

25+--TODO: Pure JS version

26+--TODO: Fast copy to FastIntMap

27+--TODO: Fast patch type

28+

29+import Prelude hiding (lookup)

30+import Data.IORef

31+import Data.IntMap.Strict (IntMap)

32+import qualified Data.IntMap.Strict as IntMap

33+import Data.Maybe

34+import Reflex.Patch.Class

35+import Data.Foldable (traverse_)

36+import Control.Monad.IO.Class

37+

38+newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))

39+

40+new :: IntMap a -> IO (FastMutableIntMap a)

41+new m = FastMutableIntMap <$> newIORef m

42+

43+newEmpty :: IO (FastMutableIntMap a)

44+newEmpty = FastMutableIntMap <$> newIORef IntMap.empty

45+

46+insert :: FastMutableIntMap a -> Int -> a -> IO ()

47+insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v

48+

49+lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)

50+lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r

51+

52+forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()

53+forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do

54+ a <- liftIO $ readIORef r

55+ traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b

56+

57+for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()

58+for_ (FastMutableIntMap r) f = do

59+ a <- liftIO $ readIORef r

60+ traverse_ f a

61+

62+isEmpty :: FastMutableIntMap a -> IO Bool

63+isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r

64+

65+size :: FastMutableIntMap a -> IO Int

66+size (FastMutableIntMap r) = IntMap.size <$> readIORef r

67+

68+-- | Make an immutable snapshot of the datastructure and clear it

69+getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)

70+getFrozenAndClear (FastMutableIntMap r) = do

71+ result <- readIORef r

72+ writeIORef r IntMap.empty

73+ return result

74+

75+applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)

76+applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do

77+ v <- readIORef r

78+ writeIORef r $! applyAlways p v

79+ return $ IntMap.intersection v m

80+

81+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

82+

83+instance Patch (PatchIntMap a) where

84+ type PatchTarget (PatchIntMap a) = IntMap a

85+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

86+ let removes = IntMap.filter isNothing p

87+ adds = IntMap.mapMaybe id p

88+ in IntMap.union adds $ v `IntMap.difference` removes

89+

90+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

91+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

92+

93+patchIntMapNewElements :: PatchIntMap a -> [a]

94+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

95+

96+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

97+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

98+

99+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

100+getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/Class.hs+17

@@ -29,6 +29,7 @@ module Reflex.Class

29 ( module Reflex.Patch

30 -- * Primitives

31 , Reflex (..)

32+ , mergeInt

32 , coerceBehavior

33 , coerceBehavior

33 , coerceEvent

34 , coerceEvent

34 , coerceDynamic

35 , coerceDynamic

@@ -36,6 +37,7 @@ module Reflex.Class

36 , MonadHold (..)

37 , MonadHold (..)

37 -- ** 'fan'-related types

38 -- ** 'fan'-related types

38 , EventSelector (..)

39 , EventSelector (..)

40+ , EventSelectorInt (..)

39 -- ** 'Incremental'-related types

41 -- ** 'Incremental'-related types

40 -- * Convenience functions

42 -- * Convenience functions

41 , constDyn

43 , constDyn

@@ -172,6 +174,8 @@ import qualified Data.Functor.Bind as Bind

172import Data.Functor.Constant

174import Data.Functor.Constant

173import Data.Functor.Misc

175import Data.Functor.Misc

174import Data.Functor.Plus

176import Data.Functor.Plus

177+import Data.IntMap.Strict (IntMap)

178+import qualified Data.IntMap.Strict as IntMap

175import Data.List.NonEmpty (NonEmpty (..))

179import Data.List.NonEmpty (NonEmpty (..))

176import Data.Map (Map)

180import Data.Map (Map)

177import Data.Maybe

181import Data.Maybe

@@ -183,6 +187,7 @@ import Data.Traversable

183import Data.Type.Coercion

187import Data.Type.Coercion

184import Reflex.FunctorMaybe

188import Reflex.FunctorMaybe

185import Reflex.Patch

189import Reflex.Patch

190+import Data.FastMutableIntMap (PatchIntMap)

186

191

187#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

192#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

188import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

193import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

@@ -298,8 +303,14 @@ class ( MonadHold t (PushM t)

298 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

303 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

299 -- occurrence type

304 -- occurrence type

300 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

305 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

306+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

307+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a

301#endif

308#endif

302

309

310+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

311+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

312+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

313+

303#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

314#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

304instance t ~ SpiderTimeline Global => Reflex t where

315instance t ~ SpiderTimeline Global => Reflex t where

305 newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

316 newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

@@ -446,6 +457,8 @@ newtype EventSelector t k = EventSelector

446 select :: forall a. k a -> Event t a

457 select :: forall a. k a -> Event t a

447 }

458 }

448

459

460+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }

461+

449--------------------------------------------------------------------------------

462--------------------------------------------------------------------------------

450-- Instances

463-- Instances

451--------------------------------------------------------------------------------

464--------------------------------------------------------------------------------

@@ -1031,6 +1044,7 @@ infixl 4 <@

1031-- to determine what the best meaning for this class is in such cases.

1044-- to determine what the best meaning for this class is in such cases.

1032class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

1045class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

1033 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1046 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1047+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))

1034 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

1048 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

1035 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

1049 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

1036

1050

@@ -1038,6 +1052,9 @@ instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where

1038 runWithReplace a0 a' = do

1052 runWithReplace a0 a' = do

1039 r <- ask

1053 r <- ask

1040 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1054 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1055+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do

1056+ r <- ask

1057+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

1041 traverseDMapWithKeyWithAdjust f dm0 dm' = do

1058 traverseDMapWithKeyWithAdjust f dm0 dm' = do

1042 r <- ask

1059 r <- ask

1043 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

1060 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

src/Reflex/EventWriter.hs+36−1

@@ -37,10 +37,13 @@ import Control.Monad.Ref

37import Control.Monad.State.Strict

38import Data.Dependent.Map (DMap, DSum (..))

39import qualified Data.Dependent.Map as DMap

40−import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))

40+import Data.FastMutableIntMap

41import Data.Foldable

42import Data.Functor.Compose

43import Data.Functor.Misc

44+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))

45+import Data.IntMap.Strict (IntMap)

46+import qualified Data.IntMap.Strict as IntMap

44import Data.List.NonEmpty (NonEmpty (..))

47import Data.List.NonEmpty (NonEmpty (..))

45import Data.Map (Map)

48import Data.Map (Map)

46import Data.Semigroup

49import Data.Semigroup

@@ -131,6 +134,7 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where

131

134

132instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

135instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

133 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

136 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

137+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental

134 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

138 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

135 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

139 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

136

140

@@ -157,6 +161,37 @@ runWithReplaceEventWriterTWith f a0 a' = do

157 tellEvent $ switch $ current request

161 tellEvent $ switch $ current request

158 return (fst result0, fmapCheap fst result')

162 return (fst result0, fmapCheap fst result')

159

163

164+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

165+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))

166+ => ( (IntMap.Key -> v -> m (Event t w, v'))

167+ -> IntMap v

168+ -> Event t (p v)

169+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

170+ )

171+ -> (p (Event t w) -> [Event t w])

172+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))

173+ -> (IntMap.Key -> v -> EventWriterT t w m v')

174+ -> IntMap v

175+ -> Event t (p v)

176+ -> EventWriterT t w m (IntMap v', Event t (p v'))

177+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

178+ let f' :: IntMap.Key -> v -> m (Event t w, v')

179+ f' k v = swap <$> runEventWriterT (f k v)

180+ (children0, children') <- base f' dm0 dm'

181+ let result0 = fmap snd children0

182+ result' = fmapCheap (fmap snd) children'

183+ requests0 :: IntMap (Event t w)

184+ requests0 = fmap fst children0

185+ requests' :: Event t (p (Event t w))

186+ requests' = fmapCheap (fmap fst) children'

187+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'

188+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

189+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

190+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

191+ [] -> Nothing

192+ h : t -> Just $ sconcat $ h :| t

193+ return (result0, result')

194+

160-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

195-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

161sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

196sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

162 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

197 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

src/Reflex/Patch/Map.hs+1

@@ -16,6 +16,7 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

17instance Ord k => Patch (PatchMap k v) where

18 type PatchTarget (PatchMap k v) = Map k v

19+ {-# INLINABLE apply #-}

19 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

20 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

20 where insertions = Map.mapMaybeWithKey (const id) p

21 where insertions = Map.mapMaybeWithKey (const id) p

21 deletions = Map.mapMaybeWithKey (const nothingToJust) p

22 deletions = Map.mapMaybeWithKey (const nothingToJust) p

src/Reflex/PerformEvent/Base.hs+15

@@ -40,6 +40,9 @@ import Data.Coerce

40import Data.Dependent.Map (DMap)

41import qualified Data.Dependent.Map as DMap

42import Data.Dependent.Sum

43+import Data.FastMutableIntMap

44+import Data.IntMap.Strict (IntMap)

45+import qualified Data.IntMap.Strict as IntMap

44-- | A function that fires events for the given 'EventTrigger's and then runs

47-- | A function that fires events for the given 'EventTrigger's and then runs

45-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

48-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

@@ -76,6 +79,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT

76 result0 <- lift a0

79 result0 <- lift a0

77 result' <- requestingIdentity a'

80 result' <- requestingIdentity a'

78 return (result0, result')

81 return (result0, result')

82+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

79 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

83 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

80 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

84 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

@@ -90,6 +94,17 @@ defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

90 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

94 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

91 return (result0, result')

95 return (result0, result')

97+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

98+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))

99+ -> (IntMap.Key -> v -> HostFrame t v2)

100+ -> IntMap v

101+ -> Event t (p v)

102+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))

103+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do

104+ result0 <- lift $ IntMap.traverseWithKey f' dm0

105+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

106+ return (result0, result')

107+

93instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

108instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

94 {-# INLINABLE newEventWithTrigger #-}

109 {-# INLINABLE newEventWithTrigger #-}

95 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

110 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

src/Reflex/PostBuild/Base.hs+35

@@ -17,6 +17,9 @@

17module Reflex.PostBuild.Base

18 ( PostBuildT (..)

19 , runPostBuildT

20+ -- * Internal

21+ , mapIntMapWithAdjustImpl

22+ , mapDMapWithAdjustImpl

20 ) where

23 ) where

22import Reflex.Class

25import Reflex.Class

@@ -34,6 +37,8 @@ import Control.Monad.Trans.Control

34import Data.Dependent.Map (DMap)

37import Data.Dependent.Map (DMap)

35import qualified Data.Dependent.Map as DMap

38import qualified Data.Dependent.Map as DMap

36import Data.Functor.Compose

39import Data.Functor.Compose

40+import Data.IntMap.Strict (IntMap)

41+import qualified Data.IntMap.Strict as IntMap

38-- | Provides a basic implementation of 'PostBuild'.

43-- | Provides a basic implementation of 'PostBuild'.

39newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

44newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

@@ -112,9 +117,39 @@ instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m

112 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

117 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

113 let voidResult' = fmapCheap (\_ -> ()) result'

118 let voidResult' = fmapCheap (\_ -> ()) result'

114 return result

119 return result

120+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

121+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust

122+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

115 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

123 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

116 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

124 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

117

125

126+{-# INLINABLE mapIntMapWithAdjustImpl #-}

127+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)

128+ => ( (IntMap.Key -> ((Bool, Event t ()), v) -> m v')

129+ -> IntMap ((Bool, Event t ()), v)

130+ -> Event t (p ((Bool, Event t ()), v))

131+ -> m (IntMap v', Event t (p v'))

132+ )

133+ -> (IntMap.Key -> v -> PostBuildT t m v')

134+ -> IntMap v

135+ -> Event t (p v)

136+ -> PostBuildT t m (IntMap v', Event t (p v'))

137+mapIntMapWithAdjustImpl base f dm0 dm' = do

138+ postBuild <- getPostBuild

139+ let loweredDm0 = fmap ((,) (False, postBuild)) dm0

140+ f' :: IntMap.Key -> ((Bool, Event t ()), v) -> m v'

141+ f' k ((shouldHeadE, e), v) = do

142+ eOnce <- if shouldHeadE

143+ then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

144+ else return e

145+ runPostBuildT (f k v) eOnce

146+ lift $ do

147+ rec (result0, result') <- base f' loweredDm0 loweredDm'

148+ let voidResult' = fmapCheap (\_ -> ()) result'

149+ let loweredDm' = ffor dm' $ fmap ((,) (True, voidResult'))

150+ return (result0, result')

151+

152+{-# INLINABLE mapDMapWithAdjustImpl #-}

118mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)

153mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)

119 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))

154 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))

120 -> DMap k (Compose ((,) (Bool, Event t ())) v)

155 -> DMap k (Compose ((,) (Bool, Event t ())) v)

src/Reflex/Requester/Base.hs+101−30

@@ -22,6 +22,7 @@ module Reflex.Requester.Base

22 ( RequesterT (..)

23 , runRequesterT

24 , runWithReplaceRequesterTWith

25+ , traverseIntMapWithKeyWithAdjustRequesterTWith

25 , traverseDMapWithKeyWithAdjustRequesterTWith

26 , traverseDMapWithKeyWithAdjustRequesterTWith

26 , RequesterData

27 , RequesterData

27 , traverseRequesterData

28 , traverseRequesterData

@@ -42,52 +43,84 @@ import Control.Monad.Ref

42import Control.Monad.State.Strict

43import Control.Monad.State.Strict

43import Data.Bits

44import Data.Bits

44import Data.Coerce

45import Data.Coerce

45−import Data.Dependent.Map (DMap, DSum (..))

46+import Data.Dependent.Map (DMap)

46import qualified Data.Dependent.Map as DMap

47import qualified Data.Dependent.Map as DMap

47import qualified Data.Some as Some

48import qualified Data.Some as Some

49+import Data.FastMutableIntMap

48import Data.Functor.Compose

50import Data.Functor.Compose

49import Data.Functor.Misc

51import Data.Functor.Misc

50−import Data.Int

52+import Data.IntMap.Strict (IntMap)

53+import qualified Data.IntMap.Strict as IntMap

51import Data.Map (Map)

54import Data.Map (Map)

52−import Data.Monoid

55+import Data.Monoid ((<>))

53import Data.Unique.Tag

56import Data.Unique.Tag

54import Data.Some (Some)

57import Data.Some (Some)

55import Data.Tuple

58import Data.Tuple

56import Data.Type.Equality

59import Data.Type.Equality

60+import Data.Proxy

62+import GHC.Exts (Any)

58import Unsafe.Coerce

63import Unsafe.Coerce

60−newtype RequesterData f = RequesterData { unRequesterData :: DMap MyTag (Entry f) }

65+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

66+

67+newtype RequesterData f = RequesterData (TagMap (Entry f))

68+

69+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

70+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

71+ where

72+ g :: Int -> Any -> t Any

73+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

62-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

75-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

63traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

76traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

64−traverseRequesterData f (RequesterData m) = RequesterData <$> DMap.traverseWithKey go m --TODO: reverse

77+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

65 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

78 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

66 go k (Entry request) = Entry <$> case myKeyType k of

79 go k (Entry request) = Entry <$> case myKeyType k of

67 MyTagType_Single -> f request

80 MyTagType_Single -> f request

68 MyTagType_Multi -> traverseRequesterData f request

81 MyTagType_Multi -> traverseRequesterData f request

69 MyTagType_Multi2 -> traverse (traverseRequesterData f) request

82 MyTagType_Multi2 -> traverse (traverseRequesterData f) request

83+ MyTagType_Multi3 -> traverse (traverseRequesterData f) request

71data MyTagType :: * -> * where

85data MyTagType :: * -> * where

72 MyTagType_Single :: MyTagType (Single a)

86 MyTagType_Single :: MyTagType (Single a)

73 MyTagType_Multi :: MyTagType Multi

87 MyTagType_Multi :: MyTagType Multi

74 MyTagType_Multi2 :: MyTagType (Multi2 k)

88 MyTagType_Multi2 :: MyTagType (Multi2 k)

89+ MyTagType_Multi3 :: MyTagType Multi3

76myKeyType :: MyTag x -> MyTagType x

91myKeyType :: MyTag x -> MyTagType x

77myKeyType (MyTag k) = case k .&. 0x3 of

92myKeyType (MyTag k) = case k .&. 0x3 of

78 0x0 -> unsafeCoerce MyTagType_Single

93 0x0 -> unsafeCoerce MyTagType_Single

79 0x1 -> unsafeCoerce MyTagType_Multi

94 0x1 -> unsafeCoerce MyTagType_Multi

80 0x2 -> unsafeCoerce MyTagType_Multi2

95 0x2 -> unsafeCoerce MyTagType_Multi2

96+ 0x3 -> unsafeCoerce MyTagType_Multi3

81 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

97 t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

83data Single a

99data Single a

84data Multi

100data Multi

85data Multi2 (k :: * -> *)

101data Multi2 (k :: * -> *)

102+data Multi3

103+

104+class MyTagTypeOffset x where

105+ myTagTypeOffset :: proxy x -> Int

106+

107+instance MyTagTypeOffset (Single a) where

108+ myTagTypeOffset _ = 0x0

109+

110+instance MyTagTypeOffset Multi where

111+ myTagTypeOffset _ = 0x1

112+

113+instance MyTagTypeOffset (Multi2 k) where

114+ myTagTypeOffset _ = 0x2

115+

116+instance MyTagTypeOffset Multi3 where

117+ myTagTypeOffset _ = 0x3

118

87type family EntryContents request a where

119type family EntryContents request a where

88 EntryContents request (Single a) = request a

120 EntryContents request (Single a) = request a

89 EntryContents request Multi = RequesterData request

121 EntryContents request Multi = RequesterData request

90 EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)

122 EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)

123+ EntryContents request Multi3 = IntMap (RequesterData request)

124

92newtype Entry request x = Entry { unEntry :: EntryContents request x }

125newtype Entry request x = Entry { unEntry :: EntryContents request x }

126

@@ -101,9 +134,9 @@ multiEntry = Entry

101

134

102-- | 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

135-- | 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

103-- 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

136-- 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

104−newtype MyTag x = MyTag Int32 deriving (Show, Eq, Ord, Enum)

137+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

105

138

106−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int32 deriving (Show, Eq, Ord, Enum)

139+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

107

140

108{-# INLINE castMyTagWrap #-}

141{-# INLINE castMyTagWrap #-}

109castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

142castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

@@ -135,13 +168,13 @@ instance GCompare (MyTagWrap f) where

135 EQ -> unsafeCoerce GEQ

168 EQ -> unsafeCoerce GEQ

136 GT -> GGT

169 GT -> GGT

137

170

138−data RequesterState t request = RequesterState

171+data RequesterState t (request :: * -> *) = RequesterState

139− { _requesterState_nextMyTag :: {-# UNPACK #-} !Int32 -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

172+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

140− , _requesterState_requests :: ![DSum (MyTagWrap request) (Event t)]

173+ , _requesterState_requests :: ![(Int, Event t Any)]

141 }

174 }

142

175

143-- | A basic implementation of 'Requester'.

176-- | A basic implementation of 'Requester'.

144−newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelector t (MyTagWrap response)) m) a }

177+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

145 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

178 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

146-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

179-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

147#if MIN_VERSION_base(4,9,1)

180#if MIN_VERSION_base(4,9,1)

@@ -154,14 +187,6 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

154deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

187deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

155deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

188deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

156

189

157−{-# INLINE wrapMyTags #-}

158−wrapMyTags :: DMap MyTag (Entry f) -> DMap (MyTagWrap f) Identity

159−wrapMyTags = unsafeCoerce

160−

161−{-# INLINE unwrapMyTags #-}

162−unwrapMyTags :: DMap (MyTagWrap f) Identity -> DMap MyTag (Entry f)

163−unwrapMyTags = unsafeCoerce

164−

165-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

190-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

166-- requests are made, and responses should be provided in the input 'Event'.

191-- requests are made, and responses should be provided in the input 'Event'.

167-- The 'Tag' keys will be used to return the responses to the same place the

192-- The 'Tag' keys will be used to return the responses to the same place the

@@ -172,9 +197,9 @@ runRequesterT :: (Reflex t, Monad m)

172 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

197 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

173 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

198 -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

174runRequesterT (RequesterT a) responses = do

199runRequesterT (RequesterT a) responses = do

175− (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fan $

200+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

176− fmapCheap (wrapMyTags . unRequesterData) responses

201+ coerceEvent responses

177− return (result, fmapCheap (RequesterData . unwrapMyTags) $ merge $ DMap.fromDistinctAscList $ _requesterState_requests s)

202+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

178

203

179instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

204instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

180 type Request (RequesterT t request response m) = request

205 type Request (RequesterT t request response m) = request

@@ -183,22 +208,22 @@ instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) wh

183 requesting_ = void . tagRequest . fmapCheap singleEntry

208 requesting_ = void . tagRequest . fmapCheap singleEntry

184

209

185{-# INLINE tagRequest #-}

210{-# INLINE tagRequest #-}

186−tagRequest :: Monad m => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

211+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))

187tagRequest req = do

212tagRequest req = do

188 old <- RequesterT get

213 old <- RequesterT get

189− let n = _requesterState_nextMyTag old

214+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

190 t = MyTagWrap n

215 t = MyTagWrap n

191 RequesterT $ put $ RequesterState

216 RequesterT $ put $ RequesterState

192− { _requesterState_nextMyTag = n - 0x4

217+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

193− , _requesterState_requests = (t :=> req) : _requesterState_requests old

218+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

194 }

219 }

195 return t

220 return t

196

221

197{-# INLINE responseFromTag #-}

222{-# INLINE responseFromTag #-}

198responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

223responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

199−responseFromTag t = do

224+responseFromTag (MyTagWrap t) = do

200− responses :: EventSelector t (MyTagWrap response) <- RequesterT ask

225+ responses :: EventSelectorInt t Any <- RequesterT ask

201− return $ select responses t

226+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

202

227

203instance MonadTrans (RequesterT t request response) where

228instance MonadTrans (RequesterT t request response) where

204 lift = RequesterT . lift . lift

229 lift = RequesterT . lift . lift

@@ -225,12 +250,15 @@ instance MonadReader r m => MonadReader r (RequesterT t request response m) wher

225

250

226instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where

251instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where

227 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

252 runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

253+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

254+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

228 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

255 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

229 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

256 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

230

257

231−requesting' :: (Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

258+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

232requesting' = responseFromTag . castMyTagWrap <=< tagRequest

259requesting' = responseFromTag . castMyTagWrap <=< tagRequest

233

260

261+{-# INLINABLE runWithReplaceRequesterTWith #-}

234runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

262runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

235 , MonadFix m

263 , MonadFix m

236 )

264 )

@@ -244,6 +272,49 @@ runWithReplaceRequesterTWith f a0 a' = do

244 requests <- holdDyn requests0 $ fmapCheap snd v'

272 requests <- holdDyn requests0 $ fmapCheap snd v'

245 return (result0, fmapCheap fst v')

273 return (result0, fmapCheap fst v')

246

274

275+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

276+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

277+ ( Reflex t

278+ , MonadHold t m

279+ , PatchTarget (p (Event t (RequesterData request))) ~ IntMap (Event t (RequesterData request))

280+ , Patch (p (Event t (RequesterData request)))

281+ , Functor p

282+ , MonadFix m

283+ )

284+ => ( (IntMap.Key -> v -> m (Event t (RequesterData request), v'))

285+ -> IntMap v

286+ -> Event t (p v)

287+ -> RequesterT t request response m (IntMap (Event t (RequesterData request), v'), Event t (p (Event t (RequesterData request), v')))

288+ )

289+ -> (p (Event t (RequesterData request)) -> IntMap (Event t (RequesterData request)))

290+ -> (Incremental t (p (Event t (RequesterData request))) -> Event t (IntMap (RequesterData request)))

291+ -> (IntMap.Key -> v -> RequesterT t request response m v')

292+ -> IntMap v

293+ -> Event t (p v)

294+ -> RequesterT t request response m (IntMap v', Event t (p v'))

295+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

296+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

297+ let responses :: EventSelectorInt t (RequesterData response)

298+ responses = fanInt $ fmapCheap unpack response

299+ unpack :: Entry response Multi3 -> IntMap (RequesterData response)

300+ unpack = unEntry

301+ pack :: IntMap (RequesterData request) -> Entry request Multi3

302+ pack = Entry

303+ f' :: IntMap.Key -> v -> m (Event t (RequesterData request), v')

304+ f' k v = fmap swap $ runRequesterT (f k v) $ selectInt responses k

305+ (children0, children') <- base f' dm0 dm'

306+ let result0 = fmap snd children0

307+ result' = fforCheap children' $ fmap snd

308+ requests0 :: IntMap (Event t (RequesterData request))

309+ requests0 = fmap fst children0

310+ requests' :: Event t (p (Event t (RequesterData request)))

311+ requests' = fforCheap children' $ fmap fst

312+ promptRequests :: Event t (IntMap (RequesterData request))

313+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

314+ requests <- holdIncremental requests0 requests'

315+ return (result0, result')

316+

317+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

247traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

318traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

248 ( GCompare k

319 ( GCompare k

249 , Reflex t

320 , Reflex t

src/Reflex/Spider/Internal.hs+290−93

@@ -57,6 +57,8 @@ import Data.Proxy

57import Data.These

58import Data.Traversable

59import Data.Word

60+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

61+import qualified Data.FastMutableIntMap as FastMutableIntMap

60import GHC.Exts

62import GHC.Exts

61import GHC.IORef (IORef (..))

63import GHC.IORef (IORef (..))

62import GHC.Stack

64import GHC.Stack

@@ -246,10 +248,10 @@ pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a ->

246pushCheap !f e = Event $ \sub -> do

248pushCheap !f e = Event $ \sub -> do

247 (subscription, occ) <- subscribeAndRead e $ sub

249 (subscription, occ) <- subscribeAndRead e $ sub

248 { subscriberPropagate = \a -> do

250 { subscriberPropagate = \a -> do

249− mb <- runComputeM $ f a

251+ mb <- f a

250 mapM_ (subscriberPropagate sub) mb

252 mapM_ (subscriberPropagate sub) mb

251 }

253 }

252− occ' <- join <$> mapM (runComputeM . f) occ

254+ occ' <- join <$> mapM f occ

253 return (subscription, occ')

255 return (subscription, occ')

254

256

255data CacheSubscribed x a

257data CacheSubscribed x a

@@ -762,6 +764,7 @@ data EventEnv x

762 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

764 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

763 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

765 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

764 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

766 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

767+ , eventEnvIntClears :: !(IORef [SomeIntClear])

765 , eventEnvRootClears :: !(IORef [SomeRootClear])

768 , eventEnvRootClears :: !(IORef [SomeRootClear])

766 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

769 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

767 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

770 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

@@ -846,6 +849,14 @@ instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

846scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

849scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

847scheduleClear r = defer $ SomeClear r

850scheduleClear r = defer $ SomeClear r

848

851

852+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where

853+ {-# INLINE getDeferralQueue #-}

854+ getDeferralQueue = asksEventEnv eventEnvIntClears

855+

856+{-# INLINE scheduleIntClear #-}

857+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()

858+scheduleIntClear r = defer $ SomeIntClear r

859+

849instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

860instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

850 {-# INLINE getDeferralQueue #-}

861 {-# INLINE getDeferralQueue #-}

851 getDeferralQueue = asksEventEnv eventEnvRootClears

862 getDeferralQueue = asksEventEnv eventEnvRootClears

@@ -981,21 +992,6 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

981-- EventM can do everything BehaviorM can, plus create holds

992-- EventM can do everything BehaviorM can, plus create holds

982newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

993newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

983

994

984−newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x], IORef [SomeDynInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

985−

986−instance Defer (SomeHoldInit x) (ComputeM x) where

987− getDeferralQueue = ComputeM $ asks fst

988−

989−instance Defer (SomeDynInit x) (ComputeM x) where

990− getDeferralQueue = ComputeM $ asks snd

991−

992−{-# INLINABLE runComputeM #-}

993−runComputeM :: (Defer (SomeHoldInit x) m, Defer (SomeDynInit x) m) => ComputeM x a -> m a

994−runComputeM (ComputeM a) = do

995− holds <- getDeferralQueue

996− dyns <- getDeferralQueue

997− liftIO $ runReaderT a (holds, dyns)

998−

999newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

995newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1000

996

1001data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove

997data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove

@@ -1239,9 +1235,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1239 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1235 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1240 EQ -> a

1236 EQ -> a

1241

1237

1242−data SomeClear = forall a. SomeClear (IORef (Maybe a))

1238+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))

1239+

1240+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))

1243

1241

1244−data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1242+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))

1245

1243

1246data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1244data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1247

1245

@@ -1377,6 +1375,7 @@ type CanSubscribe x m =

1377 , HasCurrentHeight x m

1375 , HasCurrentHeight x m

1378 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1376 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1379 , Defer SomeClear m -- Wiping out event firings

1377 , Defer SomeClear m -- Wiping out event firings

1378+ , Defer SomeIntClear m

1380 , Defer (SomeAssignment x) m -- Updating state

1379 , Defer (SomeAssignment x) m -- Updating state

1381 , Defer (SomeResetCoincidence x) m

1380 , Defer (SomeResetCoincidence x) m

1382 , m ~ EventM x

1381 , m ~ EventM x

@@ -1437,6 +1436,68 @@ cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribe

1437subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1436subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1438subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1437subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1439

1438

1439+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }

1440+

1441+data FanInt x a = FanInt

1442+ { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1443+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1444+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1445+ }

1446+

1447+newFanInt :: IO (FanInt x a)

1448+newFanInt = do

1449+ subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1450+ subscriptionRef <- newIORef $ error "fanInt: no subscription"

1451+ occRef <- newIORef $ error "fanInt: no occurrence"

1452+ return $ FanInt

1453+ { _fanInt_subscribers = subscribers

1454+ , _fanInt_subscriptionRef = subscriptionRef

1455+ , _fanInt_occRef = occRef

1456+ }

1457+

1458+{-# NOINLINE unsafeNewFanInt #-}

1459+unsafeNewFanInt :: b -> FanInt x a

1460+unsafeNewFanInt _ = unsafePerformIO newFanInt

1461+

1462+{-# NOINLINE fanInt #-}

1463+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1464+fanInt p =

1465+ let self = unsafeNewFanInt p

1466+ in EventSelectorInt $ \k -> Event $ \sub -> do

1467+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1468+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1469+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1470+ { subscriberPropagate = \m -> do

1471+ liftIO $ writeIORef (_fanInt_occRef self) m

1472+ scheduleIntClear $ _fanInt_occRef self

1473+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do

1474+ FastWeakBag.traverse b $ \s -> do

1475+ subscriberPropagate s v

1476+ , subscriberInvalidateHeight = \old -> do

1477+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1478+ FastWeakBag.traverse b $ \s -> do

1479+ subscriberInvalidateHeight s old

1480+ , subscriberRecalculateHeight = \new -> do

1481+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1482+ FastWeakBag.traverse b $ \s -> do

1483+ subscriberRecalculateHeight s new

1484+ }

1485+ liftIO $ do

1486+ writeIORef (_fanInt_subscriptionRef self) subscription

1487+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc

1488+ scheduleIntClear $ _fanInt_occRef self

1489+ liftIO $ do

1490+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case

1491+ Nothing -> do

1492+ b <- FastWeakBag.empty

1493+ FastMutableIntMap.insert (_fanInt_subscribers self) k b

1494+ return b

1495+ Just b -> return b

1496+ t <- liftIO $ FastWeakBag.insert sub b

1497+ currentOcc <- readIORef (_fanInt_occRef self)

1498+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1499+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny $! _fanInt_subscriptionRef self, IntMap.lookup k currentOcc)

1500+

1440{-# INLINABLE getFanSubscribed #-}

1501{-# INLINABLE getFanSubscribed #-}

1441getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)

1502getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)

1442getFanSubscribed k f sub = do

1503getFanSubscribed k f sub = do

@@ -1616,7 +1677,7 @@ mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1616

1677

1617{-# INLINE [1] mergeCheap #-}

1678{-# INLINE [1] mergeCheap #-}

1618mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1679mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1619−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1680+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1620 where

1681 where

1621 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1682 updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1622 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1683 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1651,7 +1712,7 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1651

1712

1652{-# INLINE [1] mergeCheapWithMove #-}

1713{-# INLINE [1] mergeCheapWithMove #-}

1653mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1714mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1654−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1715+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1655 where

1716 where

1656 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1717 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1657 updateMe subscriber heightBagRef oldParents p = do

1718 updateMe subscriber heightBagRef oldParents p = do

@@ -1709,78 +1770,108 @@ type MergeDestroyFunc k s

1709 = DMap k s

1770 = DMap k s

1710 -> IO ()

1771 -> IO ()

1711

1772

1773+data Merge x k s = Merge

1774+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

1775+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

1776+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1777+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))

1778+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

1779+ }

1780+

1781+invalidateMergeHeight :: Merge x k s -> IO ()

1782+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1783+

1784+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1785+invalidateMergeHeight' heightRef sub = do

1786+ oldHeight <- readIORef heightRef

1787+ when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1788+ writeIORef heightRef $! invalidHeight

1789+ subscriberInvalidateHeight sub oldHeight

1790+

1791+

1792+revalidateMergeHeight :: Merge x k s -> IO ()

1793+revalidateMergeHeight m = do

1794+ currentHeight <- readIORef $ _merge_heightRef m

1795+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1796+ heights <- readIORef $ _merge_heightBagRef m

1797+ parents <- readIORef $ _merge_parentsRef m

1798+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1799+ case heightBagSize heights `compare` DMap.size parents of

1800+ LT -> return ()

1801+ EQ -> do

1802+ let height = succHeight $ heightBagMax heights

1803+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1804+ writeIORef (_merge_heightRef m) $! height

1805+ subscriberRecalculateHeight (_merge_sub m) height

1806+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

1807+

1808+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

1809+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1810+ vals <- liftIO $ readIORef $ _merge_accumRef m

1811+ 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

1812+ --TODO: Assert that m is not empty

1813+ subscriberPropagate (_merge_sub m) vals

1814+

1815+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a

1816+mergeSubscriber m getKey = Subscriber

1817+ { subscriberPropagate = \a -> do

1818+ oldM <- liftIO $ readIORef $ _merge_accumRef m

1819+ k <- getKey

1820+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1821+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1822+ liftIO $ writeIORef (_merge_accumRef m) $! newM

1823+ when (DMap.null oldM) $ do -- Only schedule the firing once

1824+ height <- liftIO $ readIORef $ _merge_heightRef m

1825+ --TODO: assertions about height

1826+ currentHeight <- getCurrentHeight

1827+ when (height <= currentHeight) $ do

1828+ if height /= invalidHeight

1829+ then do

1830+ myStack <- liftIO $ whoCreatedIORef undefined --TODO

1831+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1832+ else liftIO $ do

1833+#ifdef DEBUG_CYCLES

1834+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1835+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1836+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1837+#else

1838+ let cycleInfo = ""

1839+#endif

1840+ error $ "Causality loop found" <> cycleInfo

1841+ scheduleMergeSelf m height

1842+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1843+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

1844+ invalidateMergeHeight m

1845+ , subscriberRecalculateHeight = \new -> do

1846+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new

1847+ revalidateMergeHeight m

1848+ }

1849+

1850+--TODO: Be able to run as much of this as possible promptly

1851+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x

1852+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1853+ where updateMe = do

1854+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1855+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

1856+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1857+ return subscriptionsToKill

1858+

1712{-# INLINE mergeCheap' #-}

1859{-# INLINE mergeCheap' #-}

1713−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 -> (DMap k s -> Int) -> Dynamic x p -> Event x (DMap k Identity)

1860+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)

1714−mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do

1861+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1715 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1862 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1716 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1863 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1717 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1864 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1718 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1865 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1719 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1866 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1720− let scheduleSelf height = scheduleMerge' height heightRef $ do

1867+ let m = Merge

1721− m <- liftIO $ readIORef accumRef

1868+ { _merge_parentsRef = parentsRef

1722− liftIO $ writeIORef accumRef $! DMap.empty

1869+ , _merge_heightBagRef = heightBagRef

1723− --TODO: Assert that m is not empty

1870+ , _merge_heightRef = heightRef

1724− subscriberPropagate sub m

1871+ , _merge_sub = sub

1725− invalidateMyHeight = do

1872+ , _merge_accumRef = accumRef

1726− oldHeight <- readIORef heightRef

1727− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1728− writeIORef heightRef $! invalidHeight

1729− subscriberInvalidateHeight sub oldHeight

1730− revalidateMyHeight = do

1731− currentHeight <- readIORef heightRef

1732− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1733− heights <- readIORef heightBagRef

1734− parents <- readIORef parentsRef

1735− -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1736− case heightBagSize heights `compare` numParents parents of

1737− LT -> return ()

1738− EQ -> do

1739− let height = succHeight $ heightBagMax heights

1740− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1741− writeIORef heightRef $! height

1742− subscriberRecalculateHeight sub height

1743− GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (numParents parents) <> ") for Merge"

1744− subscriber :: forall a. EventM x (k a) -> Subscriber x a

1745− subscriber getKey = Subscriber

1746− { subscriberPropagate = \a -> do

1747− oldM <- liftIO $ readIORef accumRef

1748− k <- getKey

1749− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1750− tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1751− liftIO $ writeIORef accumRef $! newM

1752− when (DMap.null oldM) $ do -- Only schedule the firing once

1753− height <- liftIO $ readIORef heightRef

1754− --TODO: assertions about height

1755− currentHeight <- getCurrentHeight

1756− when (height <= currentHeight) $ do

1757− if height /= invalidHeight

1758− then do

1759− myStack <- liftIO $ whoCreatedIORef undefined --TODO

1760− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1761− else liftIO $ do

1762−#ifdef DEBUG_CYCLES

1763− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1764− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1765− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1766−#else

1767− let cycleInfo = ""

1768−#endif

1769− error $ "Causality loop found" <> cycleInfo

1770− scheduleSelf height

1771− , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1772− modifyIORef' heightBagRef $ heightBagRemove old

1773− invalidateMyHeight

1774− , subscriberRecalculateHeight = \new -> do

1775− modifyIORef' heightBagRef $ heightBagAdd new

1776− revalidateMyHeight

1777 }

1873 }

1778− let updateMe x = do

1779− oldParents <- liftIO $ readIORef parentsRef

1780− (subscriptionsToKill, newParents) <- updateFunc subscriber heightBagRef oldParents x

1781− liftIO $ writeIORef parentsRef $! newParents

1782− return subscriptionsToKill

1783− (dm, heights, initialParentState) <- getInitialSubscribers initialParents subscriber

1874+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

1784 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1875 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1785 myHeight = if invalidHeight `elem` heights

1876 myHeight = if invalidHeight `elem` heights

1786 then invalidHeight

1877 then invalidHeight

@@ -1790,9 +1881,7 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1790 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1881 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1791 else (Nothing, dm)

1882 else (Nothing, dm)

1792 unless (DMap.null accum) $ do

1883 unless (DMap.null accum) $ do

1793− scheduleSelf myHeight

1884+ scheduleMergeSelf m myHeight

1794− occRef <- liftIO $ newIORef occ

1795− when (isJust occ) $ scheduleClear occRef

1796 liftIO $ writeIORef accumRef $! accum

1885 liftIO $ writeIORef accumRef $! accum

1797 liftIO $ writeIORef heightRef $! myHeight

1886 liftIO $ writeIORef heightRef $! myHeight

1798 liftIO $ writeIORef heightBagRef $! myHeightBag

1887 liftIO $ writeIORef heightBagRef $! myHeightBag

@@ -1802,12 +1891,12 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1802 let s = Subscriber

1891 let s = Subscriber

1803 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1892 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1804 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1893 tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1805− defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1894+ defer $ updateMerge m updateFunc a

1806 , subscriberInvalidateHeight = \_ -> return ()

1895 , subscriberInvalidateHeight = \_ -> return ()

1807 , subscriberRecalculateHeight = \_ -> return ()

1896 , subscriberRecalculateHeight = \_ -> return ()

1808 }

1897 }

1809 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1898 (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1810− forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

1899+ forM_ change $ \c -> defer $ updateMerge m updateFunc c

1811 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1900 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1812 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1901 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1813 -- its subscription.

1902 -- its subscription.

@@ -1817,6 +1906,106 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1817 , occ

1906 , occ

1818 )

1907 )

1819

1908

1909+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1910+mergeInt = cacheEvent . mergeIntCheap

1911+

1912+{-# INLINABLE mergeIntCheap #-}

1913+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1914+mergeIntCheap d = Event $ \sub -> do

1915+ initialParents <- readBehaviorUntracked $ dynamicCurrent d

1916+ accum <- liftIO $ FastMutableIntMap.newEmpty

1917+ heightRef <- liftIO $ newIORef zeroHeight

1918+ heightBagRef <- liftIO $ newIORef heightBagEmpty

1919+ parents <- liftIO $ FastMutableIntMap.newEmpty

1920+ let scheduleSelf = do

1921+ height <- liftIO $ readIORef $ heightRef

1922+ scheduleMerge' height heightRef $ do

1923+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

1924+ subscriberPropagate sub vals

1925+ invalidateMyHeight = do

1926+ invalidateMergeHeight' heightRef sub

1927+ recalculateMyHeight = do

1928+ currentHeight <- readIORef heightRef

1929+ when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

1930+ heights <- readIORef heightBagRef

1931+ numParents <- FastMutableIntMap.size parents

1932+ case heightBagSize heights `compare` numParents of

1933+ LT -> return ()

1934+ EQ -> do

1935+ let height = succHeight $ heightBagMax heights

1936+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1937+ writeIORef heightRef $! height

1938+ subscriberRecalculateHeight sub height

1939+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

1940+ mySubscriber k = Subscriber

1941+ { subscriberPropagate = \a -> do

1942+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

1943+ liftIO $ FastMutableIntMap.insert accum k a

1944+ when wasEmpty scheduleSelf

1945+ , subscriberInvalidateHeight = \old -> do

1946+ modifyIORef' heightBagRef $ heightBagRemove old

1947+ invalidateMyHeight

1948+ , subscriberRecalculateHeight = \new -> do

1949+ modifyIORef' heightBagRef $ heightBagAdd new

1950+ recalculateMyHeight

1951+ }

1952+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do

1953+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k

1954+ liftIO $ do

1955+ forM_ parentOcc $ FastMutableIntMap.insert accum k

1956+ FastMutableIntMap.insert parents k subscription

1957+ height <- getEventSubscribedHeight parentSubd

1958+ if height == invalidHeight

1959+ then writeIORef heightRef invalidHeight

1960+ else do

1961+ modifyIORef' heightBagRef $ heightBagAdd height

1962+ modifyIORef' heightRef $ \oldHeight ->

1963+ if oldHeight == invalidHeight

1964+ then invalidHeight

1965+ else max (succHeight height) oldHeight

1966+ myHeight <- liftIO $ readIORef heightRef

1967+ currentHeight <- getCurrentHeight

1968+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

1969+ occ <- if currentHeight >= myHeight -- If we should have fired by now

1970+ then if isEmpty

1971+ then return Nothing

1972+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

1973+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

1974+ return Nothing

1975+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1976+ defer $ SomeMergeInit $ do

1977+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

1978+ where

1979+ u = do

1980+ let f k newParent = do

1981+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k

1982+ newParentHeight <- liftIO $ getEventSubscribedHeight subd

1983+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1984+ return subscription

1985+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a

1986+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

1987+ liftIO $ for_ oldParents $ \oldParent -> do

1988+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

1989+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

1990+ return $ IntMap.elems oldParents

1991+ let s = Subscriber

1992+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1993+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

1994+ defer $ updateMe a

1995+ , subscriberInvalidateHeight = \_ -> return ()

1996+ , subscriberRecalculateHeight = \_ -> return ()

1997+ }

1998+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1999+ forM_ change $ \c -> defer $ updateMe c

2000+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2001+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2002+ -- its subscription.

2003+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2004+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2005+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2006+ , occ

2007+ )

2008+

1820newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2009newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

1821

2010

1822fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2011fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

@@ -1856,13 +2045,14 @@ newEventEnv = do

1856 mergeInitRef <- newIORef []

2045 mergeInitRef <- newIORef []

1857 heightRef <- newIORef zeroHeight

2046 heightRef <- newIORef zeroHeight

1858 toClearRef <- newIORef []

2047 toClearRef <- newIORef []

2048+ toClearIntRef <- newIORef []

1859 toClearRootRef <- newIORef []

2049 toClearRootRef <- newIORef []

1860 coincidenceInfosRef <- newIORef []

2050 coincidenceInfosRef <- newIORef []

1861 delayedRef <- newIORef IntMap.empty

2051 delayedRef <- newIORef IntMap.empty

1862− return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

2052+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1863

2053

1864clearEventEnv :: EventEnv x -> IO ()

2054clearEventEnv :: EventEnv x -> IO ()

1865−clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

2055+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

1866 writeIORef toAssignRef []

2056 writeIORef toAssignRef []

1867 writeIORef holdInitRef []

2057 writeIORef holdInitRef []

1868 writeIORef dynInitRef []

2058 writeIORef dynInitRef []

@@ -1870,6 +2060,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

1870 writeIORef mergeInitRef []

2060 writeIORef mergeInitRef []

1871 writeIORef heightRef zeroHeight

2061 writeIORef heightRef zeroHeight

1872 writeIORef toClearRef []

2062 writeIORef toClearRef []

2063+ writeIORef toClearIntRef []

1873 writeIORef toClearRootRef []

2064 writeIORef toClearRootRef []

1874 writeIORef coincidenceInfosRef []

2065 writeIORef coincidenceInfosRef []

1875 writeIORef delayedRef IntMap.empty

2066 writeIORef delayedRef IntMap.empty

@@ -1885,6 +2076,8 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

1885 result <- runEventM go

2076 result <- runEventM go

1886 toClear <- readIORef $ eventEnvClears env

2077 toClear <- readIORef $ eventEnvClears env

1887 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

2078 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

2079+ toClearInt <- readIORef $ eventEnvIntClears env

2080+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty

1888 toClearRoot <- readIORef $ eventEnvRootClears env

2081 toClearRoot <- readIORef $ eventEnvRootClears env

1889 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2082 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1890 toAssign <- readIORef $ eventEnvAssignments env

2083 toAssign <- readIORef $ eventEnvAssignments env

@@ -2079,6 +2272,8 @@ withSpiderTimeline k = do

2079

2272

2080newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2273newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2081

2274

2275+type ComputeM = EventM

2276+

2082newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2277newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2083

2278

2084#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2279#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -2131,6 +2326,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2131 eventCoercion Coercion = Coercion

2326 eventCoercion Coercion = Coercion

2132 behaviorCoercion Coercion = Coercion

2327 behaviorCoercion Coercion = Coercion

2133 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2328 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2329+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2330+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2134#endif

2331#endif

2135

2332

2136data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2333data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

src/Reflex/Spider/SpiderTimeline.include.hs+2

@@ -30,6 +30,8 @@ instance (

30instance (

31#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32 x ~ Global

33+#else

34+ HasSpiderTimeline x

33#endif

35#endif

34 ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

36 ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

35 {-# INLINABLE sample #-}

37 {-# INLINABLE sample #-}

src/Reflex/TriggerEvent/Base.hs+2

@@ -118,6 +118,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

118instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

119 {-# INLINABLE runWithReplace #-}

120 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

121+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

122+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

121 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

123 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

122 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

124 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

123 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

125 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}