9afdfce · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Merge pull request #320 from treeowl/canhazmerge

9afdfceOliver Batchelor7 years ago

ChangeLog.md+10

compare with develop

unifiedsplit

@@ -1,7 +1,17 @@

1# Revision history for reflex

3+## Unreleased

5+* Generalize merging functions:

6+ `merge` to `mergeG`,

7+ `mergeIncremental` to `mergeIncrementalG`,

8+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

9+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

10+

3## 0.6.2.0

11## 0.6.2.0

13+* Fix `holdDyn` so that it is lazy in its event argument

14+ These produce `DMap`s whose values needn't be `Identity`.

5* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).

15* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).

6* Fix `holdDyn` so that it is lazy in its event argument.

16* Fix `holdDyn` so that it is lazy in its event argument.

reflex.cabal+1

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

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

50 dependent-map >= 0.3 && < 0.4,

51 exception-transformers == 0.4.*,

52+ profunctors,

52 lens >= 4.7 && < 5,

53 lens >= 4.7 && < 5,

53 monad-control >= 1.0.1 && < 1.1,

54 monad-control >= 1.0.1 && < 1.1,

54 monoidal-containers == 0.4.*,

55 monoidal-containers == 0.4.*,

src/Reflex/Class.hs+45−7

@@ -17,6 +17,7 @@

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

20+{-# LANGUAGE Trustworthy #-}

20#ifdef USE_REFLEX_OPTIMIZER

21#ifdef USE_REFLEX_OPTIMIZER

21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

22#endif

23#endif

@@ -46,6 +47,9 @@ module Reflex.Class

46 , pushAlways

47 , pushAlways

47 -- ** Combining 'Event's

48 -- ** Combining 'Event's

48 , leftmost

49 , leftmost

50+ , merge

51+ , mergeIncremental

52+ , mergeIncrementalWithMove

49 , mergeMap

53 , mergeMap

50 , mergeIntMap

54 , mergeIntMap

51 , mergeMapIncremental

55 , mergeMapIncremental

@@ -84,6 +88,7 @@ module Reflex.Class

84 , gate

88 , gate

85 -- ** Combining 'Dynamic's

89 -- ** Combining 'Dynamic's

86 , distributeDMapOverDynPure

90 , distributeDMapOverDynPure

91+ , distributeDMapOverDynPureG

87 , distributeListOverDyn

92 , distributeListOverDyn

88 , distributeListOverDynWith

93 , distributeListOverDynWith

89 , zipDyn

94 , zipDyn

@@ -255,7 +260,9 @@ class ( MonadHold t (PushM t)

255 -- | Merge a collection of events; the resulting 'Event' will only occur if at

260 -- | Merge a collection of events; the resulting 'Event' will only occur if at

256 -- least one input event is occurring, and will contain all of the input keys

261 -- least one input event is occurring, and will contain all of the input keys

257 -- that are occurring simultaneously

262 -- that are occurring simultaneously

263+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))

264+ -> DMap k q -> Event t (DMap k v)

258− 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

265+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

259 -- | Efficiently fan-out an event to many destinations. You should save the

266 -- | Efficiently fan-out an event to many destinations. You should save the

260 -- result in a @let@-binding, and then repeatedly 'select' on the result to

267 -- result in a @let@-binding, and then repeatedly 'select' on the result to

261 -- create child events

268 -- create child events

@@ -277,9 +284,14 @@ class ( MonadHold t (PushM t)

277 -- that value.

284 -- that value.

278 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

285 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

279 -- | Create a merge whose parents can change over time

286 -- | Create a merge whose parents can change over time

287+ mergeIncrementalG :: GCompare k

288+ => (forall a. q a -> Event t (v a))

280− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

289+ -> Incremental t (PatchDMap k q)

290+ -> Event t (DMap k v)

281 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

291 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

292+ mergeIncrementalWithMoveG :: GCompare k

293+ => (forall a. q a -> Event t (v a))

282− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

294+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)

283 -- | Extract the 'Behavior' component of an 'Incremental'

295 -- | Extract the 'Behavior' component of an 'Incremental'

284 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)

296 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)

285 -- | Extract the 'Event' component of an 'Incremental'

297 -- | Extract the 'Event' component of an 'Incremental'

@@ -1079,12 +1091,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1079-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1091-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1080-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1092-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1081distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1093distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1082−distributeDMapOverDynPure dm = case DMap.toList dm of

1094+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

1095+

1096+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

1097+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1098+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1099+distributeDMapOverDynPureG

1100+ :: forall t k q v. (Reflex t, GCompare k)

1101+ => (forall a. q a -> Dynamic t (v a))

1102+ -> DMap k q -> Dynamic t (DMap k v)

1103+distributeDMapOverDynPureG nt dm = case DMap.toList dm of

1083 [] -> constDyn DMap.empty

1104 [] -> constDyn DMap.empty

1084− [k :=> v] -> fmap (DMap.singleton k . Identity) v

1105+ [k :=> v] -> DMap.singleton k <$> nt v

1085 _ ->

1106 _ ->

1086− let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm

1107+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm

1087− edmPre = merge $ DMap.map updated dm

1108+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm

1088 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do

1109 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do

1089 olds <- sample $ current result

1110 olds <- sample $ current result

1090 return $ DMap.unionWithKey (\_ _ new -> new) olds news

1111 return $ DMap.unionWithKey (\_ _ new -> new) olds news

@@ -1557,6 +1578,23 @@ fmapCheap f = pushCheap $ return . Just . f

1557tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1578tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1558tagCheap b = pushAlwaysCheap $ \_ -> sample b

1579tagCheap b = pushAlwaysCheap $ \_ -> sample b

1559

1580

1581+-- | Merge a collection of events; the resulting 'Event' will only occur if at

1582+-- least one input event is occurring, and will contain all of the input keys

1583+-- that are occurring simultaneously

1584+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

1585+merge = mergeG coerceEvent

1586+{-# INLINE merge #-}

1587+

1588+-- | Create a merge whose parents can change over time

1589+mergeIncremental :: (Reflex t, GCompare k)

1590+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

1591+mergeIncremental = mergeIncrementalG coerceEvent

1592+

1593+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

1594+mergeIncrementalWithMove :: (Reflex t, GCompare k)

1595+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

1596+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent

1597+

1560-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

1598-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

1561{-# INLINE mergeWithCheap #-}

1599{-# INLINE mergeWithCheap #-}

1562mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

1600mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

src/Reflex/Profiled.hs+9−5

@@ -8,6 +8,8 @@

8{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE RankNTypes #-}

11-- |

13-- |

12-- Module:

14-- Module:

13-- Reflex.Profiled

15-- Reflex.Profiled

@@ -16,7 +18,6 @@

16-- profiling/cost-center information.

18-- profiling/cost-center information.

17module Reflex.Profiled where

19module Reflex.Profiled where

19−import Control.Lens hiding (children)

20import Control.Monad

21import Control.Monad

21import Control.Monad.Exception

22import Control.Monad.Exception

22import Control.Monad.Fix

23import Control.Monad.Fix

@@ -33,6 +34,7 @@ import Data.Map (Map)

33import qualified Data.Map.Strict as Map

34import qualified Data.Map.Strict as Map

34import Data.Monoid ((<>))

35import Data.Monoid ((<>))

35import Data.Ord

36import Data.Ord

37+import Data.Profunctor.Unsafe ((#.))

36import qualified Data.Semigroup as S

38import qualified Data.Semigroup as S

37import Data.Type.Coercion

39import Data.Type.Coercion

38import Foreign.Ptr

40import Foreign.Ptr

@@ -133,8 +135,10 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

135 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

134 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

136 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

135 pull = Behavior_Profiled . pull . coerce

137 pull = Behavior_Profiled . pull . coerce

138+ mergeG :: forall (k :: z -> *) q v. GCompare k

139+ => (forall a. q a -> Event (ProfiledTimeline t) (v a))

136− merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)

140+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

137− merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))

141+ mergeG nt = Event_Profiled #. mergeG (coerce nt)

138 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)

142 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)

139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

143 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

144 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

@@ -142,8 +146,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

146 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

147 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

144 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

148 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

145− mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))

149+ mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt

146− mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))

150+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt

147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

src/Reflex/Pure.hs+16−10

@@ -5,6 +5,8 @@

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE PolyKinds #-}

8#ifdef USE_REFLEX_OPTIMIZER

10#ifdef USE_REFLEX_OPTIMIZER

9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

10#endif

12#endif

@@ -43,10 +45,11 @@ import Data.MemoTrie

43import Data.Monoid

45import Data.Monoid

44import Data.Type.Coercion

46import Data.Type.Coercion

45import Reflex.Class

47import Reflex.Class

48+import Data.Kind (Type)

47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

50-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

48-- with the type @/t/@.

51-- with the type @/t/@.

49−data Pure t

52+data Pure (t :: Type)

51-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

54-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

52-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

55-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

@@ -79,11 +82,12 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

79 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a

82 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a

80 -- warning because the GCompare instance is not used; however, removing the

83 -- warning because the GCompare instance is not used; however, removing the

81 -- GCompare instance produces a different warning, due to that constraint

84 -- GCompare instance produces a different warning, due to that constraint

82− -- being present in the original class definition

85+ -- being present in the original class definition.

84− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)

87+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))

88+ -- -> DMap k q -> Event (Pure t) (DMap k v)

85− merge events = Event $ memo $ \t ->

89+ mergeG nt events = Event $ memo $ \t ->

86− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events

90+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events

87 in if DMap.null currentOccurrences

91 in if DMap.null currentOccurrences

88 then Nothing

92 then Nothing

89 else Just currentOccurrences

93 else Just currentOccurrences

@@ -112,8 +116,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

112 --a) -> Incremental (Pure t) p a

116 --a) -> Incremental (Pure t) p a

113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

117 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

114

118

115− mergeIncremental = mergeIncrementalImpl

119+ mergeIncrementalG = mergeIncrementalImpl

116− mergeIncrementalWithMove = mergeIncrementalImpl

120+ mergeIncrementalWithMoveG = mergeIncrementalImpl

117

121

118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

122 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

119

123

@@ -133,9 +137,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

133

137

134 mergeIntIncremental = mergeIntIncrementalImpl

138 mergeIntIncremental = mergeIntIncrementalImpl

135

139

136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)

140+mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)

141+ => (forall a. q a -> Event (Pure t) (v a))

142+ -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)

137−mergeIncrementalImpl i = Event $ \t ->

143+mergeIncrementalImpl nt i = Event $ \t ->

138− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t

144+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t

139 in if DMap.null results

145 in if DMap.null results

140 then Nothing

146 then Nothing

141 else Just results

147 else Just results

src/Reflex/Spider/Internal.hs+78−53

@@ -17,9 +17,12 @@

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

20+{-# LANGUAGE PolyKinds #-}

21+{-# LANGUAGE InstanceSigs #-}

20#ifdef USE_REFLEX_OPTIMIZER

22#ifdef USE_REFLEX_OPTIMIZER

21{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

23{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

22#endif

24#endif

25+{-# OPTIONS_GHC -Wunused-binds #-}

23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

26-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

27-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

28module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

@@ -49,6 +52,7 @@ import Data.GADT.Compare

49import Data.IntMap.Strict (IntMap)

52import Data.IntMap.Strict (IntMap)

50import qualified Data.IntMap.Strict as IntMap

53import qualified Data.IntMap.Strict as IntMap

51import Data.IORef

54import Data.IORef

55+import Data.Kind (Type)

52import Data.Maybe hiding (mapMaybe)

56import Data.Maybe hiding (mapMaybe)

53import Data.Monoid ((<>))

57import Data.Monoid ((<>))

54import Data.Proxy

58import Data.Proxy

@@ -76,6 +80,7 @@ import qualified Data.FastWeakBag as FastWeakBag

76import Data.Reflection

80import Data.Reflection

77import Data.Some (Some(Some))

81import Data.Some (Some(Some))

78import Data.Type.Coercion

82import Data.Type.Coercion

83+import Data.Profunctor.Unsafe ((#.), (.#))

79import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

84import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

80import qualified Data.WeakBag as WeakBag

85import qualified Data.WeakBag as WeakBag

81import qualified Reflex.Class

86import qualified Reflex.Class

@@ -1135,13 +1140,14 @@ instance HasSpiderTimeline x => Align (Event x) where

1135#if MIN_VERSION_these(0, 8, 0)

1140#if MIN_VERSION_these(0, 8, 0)

1136instance HasSpiderTimeline x => Semialign (Event x) where

1141instance HasSpiderTimeline x => Semialign (Event x) where

1137#endif

1142#endif

1143+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1138− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1144+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1139

1145

1140data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1146data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1141 | BuildDyn !(EventM x (PatchTarget p), Event x p)

1147 | BuildDyn !(EventM x (PatchTarget p), Event x p)

1142 | HoldDyn !(Hold x p)

1148 | HoldDyn !(Hold x p)

1143

1149

1144−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

1150+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1145

1151

1146newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1152newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1147newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1153newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

@@ -1687,26 +1693,34 @@ cleanupCoincidenceSubscribed subscribed = do

1687subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1693subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1688subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1694subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1689

1695

1690−{-# INLINE merge #-}

1696+{-# INLINE mergeG #-}

1691−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1697+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1698+ => (forall a. q a -> Event x (v a))

1699+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)

1692−merge d = cacheEvent (mergeCheap d)

1700+mergeG nt d = cacheEvent (mergeCheap nt d)

1693

1701

1694{-# INLINE mergeWithMove #-}

1702{-# INLINE mergeWithMove #-}

1695−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1703+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1704+ => (forall a. q a -> Event x (v a))

1705+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)

1696−mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1706+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1697

1707

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

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

1709+mergeCheap

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

1710+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1711+ => (forall a. q a -> Event x (v a))

1712+ -> Dynamic x (PatchDMap k q)

1713+ -> Event x (DMap k v)

1700−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1714+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1701 where

1715 where

1702− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1716+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1703 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1717 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1704 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1718 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1705 (mOldSubd, newPs) <- case me of

1719 (mOldSubd, newPs) <- case me of

1706 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1720 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1707 Just e -> do

1721 Just e -> do

1708 let s = subscriber $ return k

1722 let s = subscriber $ return k

1709− subscription@(EventSubscription _ subd) <- subscribe e s

1723+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s

1710 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1724 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1711 let newParent = MergeSubscribedParent subscription

1725 let newParent = MergeSubscribedParent subscription

1712 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1726 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

@@ -1716,28 +1730,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1716 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1730 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1717 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1731 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1718 foldM f ([], oldParents) $ DMap.toList p

1732 foldM f ([], oldParents) $ DMap.toList p

1733+

1719− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

1734+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

1720 getInitialSubscribers initialParents subscriber = do

1735 getInitialSubscribers initialParents subscriber = do

1721 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1736 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1722 let s = subscriber $ return k

1737 let s = subscriber $ return k

1723− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1738+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1724 height <- liftIO $ getEventSubscribedHeight parentSubd

1739 height <- liftIO $ getEventSubscribedHeight parentSubd

1725− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1740+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1726 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1741 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1727 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1742 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1728 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1743 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1729 )

1744 )

1745+

1730 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1746 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1731 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1747 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1732

1748

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

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

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

1750+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1751+ => (forall a. q a -> Event x (v a))

1752+ -> Dynamic x (PatchDMapWithMove k q)

1753+ -> Event x (DMap k v)

1735−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1754+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1736 where

1755 where

1737− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1756+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1738 updateMe subscriber heightBagRef oldParents p = do

1757 updateMe subscriber heightBagRef oldParents p = do

1739 -- Prepare new parents for insertion

1758 -- Prepare new parents for insertion

1740− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)

1759+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)

1741 subscribeParent k e = do

1760 subscribeParent k e = do

1742 keyRef <- liftIO $ newIORef k

1761 keyRef <- liftIO $ newIORef k

1743 let s = subscriber $ liftIO $ readIORef keyRef

1762 let s = subscriber $ liftIO $ readIORef keyRef

@@ -1746,9 +1765,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1746 newParentHeight <- getEventSubscribedHeight subd

1765 newParentHeight <- getEventSubscribedHeight subd

1747 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1766 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1748 return $ MergeSubscribedParentWithMove subscription keyRef

1767 return $ MergeSubscribedParentWithMove subscription keyRef

1749− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

1768+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

1750 -- Collect old parents for deletion and update the keys of moved parents

1769 -- Collect old parents for deletion and update the keys of moved parents

1751− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1770+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1752 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1771 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1753 Nothing -> do

1772 Nothing -> do

1754 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1773 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

@@ -1759,46 +1778,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1759 return Nothing

1778 return Nothing

1760 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1779 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1761 return (toDelete, applyAlways p' oldParents)

1780 return (toDelete, applyAlways p' oldParents)

1762− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1781+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1763 getInitialSubscribers initialParents subscriber = do

1782 getInitialSubscribers initialParents subscriber = do

1764 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1783 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1765 keyRef <- liftIO $ newIORef k

1784 keyRef <- liftIO $ newIORef k

1766 let s = subscriber $ liftIO $ readIORef keyRef

1785 let s = subscriber $ liftIO $ readIORef keyRef

1767− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1786+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1768 height <- liftIO $ getEventSubscribedHeight parentSubd

1787 height <- liftIO $ getEventSubscribedHeight parentSubd

1769− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1788+ return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1770 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1789 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1771 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1790 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1772 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1791 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1773 )

1792 )

1793+

1774 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1794 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1775 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1795 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1776

1796

1777−type MergeUpdateFunc k x p s

1797+type MergeUpdateFunc k v x p s

1778− = (forall a. EventM x (k a) -> Subscriber x a)

1798+ = (forall a. EventM x (k a) -> Subscriber x (v a))

1779 -> IORef HeightBag

1799 -> IORef HeightBag

1780 -> DMap k s

1800 -> DMap k s

1781 -> p

1801 -> p

1782 -> EventM x ([EventSubscription x], DMap k s)

1802 -> EventM x ([EventSubscription x], DMap k s)

1783

1803

1784−type MergeInitFunc k x s

1804+type MergeInitFunc k v q x s

1785− = DMap k (Event x)

1805+ = DMap k q

1786− -> (forall a. EventM x (k a) -> Subscriber x a)

1806+ -> (forall a. EventM x (k a) -> Subscriber x (v a))

1787− -> EventM x (DMap k Identity, [Height], DMap k s)

1807+ -> EventM x (DMap k v, [Height], DMap k s)

1788

1808

1789type MergeDestroyFunc k s

1809type MergeDestroyFunc k s

1790 = DMap k s

1810 = DMap k s

1791 -> IO ()

1811 -> IO ()

1792

1812

1793−data Merge x k s = Merge

1813+data Merge x k v s = Merge

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

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

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

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

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

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

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

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

1798− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

1818+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))

1799 }

1819 }

1800

1820

1801−invalidateMergeHeight :: Merge x k s -> IO ()

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

1802invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1822invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1803

1823

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

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

@@ -1808,8 +1828,7 @@ invalidateMergeHeight' heightRef sub = do

1808 writeIORef heightRef $! invalidHeight

1828 writeIORef heightRef $! invalidHeight

1809 subscriberInvalidateHeight sub oldHeight

1829 subscriberInvalidateHeight sub oldHeight

1810

1830

1811−

1812−revalidateMergeHeight :: Merge x k s -> IO ()

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

1813revalidateMergeHeight m = do

1832revalidateMergeHeight m = do

1814 currentHeight <- readIORef $ _merge_heightRef m

1833 currentHeight <- readIORef $ _merge_heightRef m

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

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

@@ -1825,19 +1844,19 @@ revalidateMergeHeight m = do

1825 subscriberRecalculateHeight (_merge_sub m) height

1844 subscriberRecalculateHeight (_merge_sub m) height

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

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

1827

1846

1828−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

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

1829scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1848scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1830 vals <- liftIO $ readIORef $ _merge_accumRef m

1849 vals <- liftIO $ readIORef $ _merge_accumRef m

1831 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

1850 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

1832 --TODO: Assert that m is not empty

1851 --TODO: Assert that m is not empty

1833 subscriberPropagate (_merge_sub m) vals

1852 subscriberPropagate (_merge_sub m) vals

1834

1853

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

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

1836mergeSubscriber m getKey = Subscriber

1855mergeSubscriber m getKey = Subscriber

1837 { subscriberPropagate = \a -> do

1856 { subscriberPropagate = \a -> do

1838 oldM <- liftIO $ readIORef $ _merge_accumRef m

1857 oldM <- liftIO $ readIORef $ _merge_accumRef m

1839 k <- getKey

1858 k <- getKey

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

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

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

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

1842 liftIO $ writeIORef (_merge_accumRef m) $! newM

1861 liftIO $ writeIORef (_merge_accumRef m) $! newM

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

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

@@ -1868,7 +1887,7 @@ mergeSubscriber m getKey = Subscriber

1868 }

1887 }

1869

1888

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

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

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

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

1872updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1891updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1873 where updateMe = do

1892 where updateMe = do

1874 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1893 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

@@ -1876,9 +1895,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

1876 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1895 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1877 return subscriptionsToKill

1896 return subscriptionsToKill

1878

1897

1879−{-# INLINE mergeCheap' #-}

1898+{-# INLINE mergeGCheap' #-}

1899+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1880−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)

1900+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)

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

1901+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1882 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1902 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

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

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

@@ -2461,7 +2481,7 @@ unsafeNewSpiderTimelineEnv = do

2461newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2481newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2462newSpiderTimeline = withSpiderTimeline (pure . Some)

2482newSpiderTimeline = withSpiderTimeline (pure . Some)

2463

2483

2464−data LocalSpiderTimeline x s

2484+data LocalSpiderTimeline (x :: Type) s

2465

2485

2466instance Reifies s (SpiderTimelineEnv x) =>

2486instance Reifies s (SpiderTimelineEnv x) =>

2467 HasSpiderTimeline (LocalSpiderTimeline x s) where

2487 HasSpiderTimeline (LocalSpiderTimeline x s) where

@@ -2479,11 +2499,11 @@ withSpiderTimeline k = do

2479 env <- unsafeNewSpiderTimelineEnv

2499 env <- unsafeNewSpiderTimelineEnv

2480 reify env $ \s -> k $ localSpiderTimeline s env

2500 reify env $ \s -> k $ localSpiderTimeline s env

2481

2501

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

2502+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2483

2503

2484type ComputeM = EventM

2504type ComputeM = EventM

2485

2505

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

2506+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2487

2507

2488instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2508instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2489 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2509 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

@@ -2503,8 +2523,13 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2503 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2523 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2504 {-# INLINABLE pull #-}

2524 {-# INLINABLE pull #-}

2505 pull = SpiderBehavior . pull . coerce

2525 pull = SpiderBehavior . pull . coerce

2506− {-# INLINABLE merge #-}

2526+ {-# INLINABLE mergeG #-}

2507− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2527+ mergeG

2528+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2529+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2530+ -> DMap k q

2531+ -> R.Event (SpiderTimeline x) (DMap k v)

2532+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst

2508 {-# INLINABLE fan #-}

2533 {-# INLINABLE fan #-}

2509 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2534 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2510 {-# INLINABLE switch #-}

2535 {-# INLINABLE switch #-}

@@ -2519,10 +2544,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2519 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2544 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2520 {-# INLINABLE unsafeBuildIncremental #-}

2545 {-# INLINABLE unsafeBuildIncremental #-}

2521 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2546 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2522− {-# INLINABLE mergeIncremental #-}

2547+ {-# INLINABLE mergeIncrementalG #-}

2523− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

2548+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2524− {-# INLINABLE mergeIncrementalWithMove #-}

2549+ {-# INLINABLE mergeIncrementalWithMoveG #-}

2525− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

2550+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

2526 {-# INLINABLE currentIncremental #-}

2551 {-# INLINABLE currentIncremental #-}

2527 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2552 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2528 {-# INLINABLE updatedIncremental #-}

2553 {-# INLINABLE updatedIncremental #-}

@@ -2560,7 +2585,7 @@ instance MonadAtomicRef (EventM x) where

2560 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2585 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2561

2586

2562-- | The monad for actions that manipulate a Spider timeline identified by @x@

2587-- | The monad for actions that manipulate a Spider timeline identified by @x@

2563−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2588+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2564

2589

2565instance Monad (SpiderHost x) where

2590instance Monad (SpiderHost x) where

2566 {-# INLINABLE (>>=) #-}

2591 {-# INLINABLE (>>=) #-}

@@ -2582,7 +2607,7 @@ runSpiderHost (SpiderHost a) = a

2582runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2607runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2583runSpiderHostForTimeline (SpiderHost a) _ = a

2608runSpiderHostForTimeline (SpiderHost a) _ = a

2584

2609

2585−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2610+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2586 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2611 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2587

2612

2588instance Monad (SpiderHostFrame x) where

2613instance Monad (SpiderHostFrame x) where

test/GC.hs+2−1

@@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S

28import System.Exit

29import System.Mem

30+import Data.Coerce

31main :: IO ()

32main :: IO ()

32main = do

33main = do

@@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do

46 eventToPerform <- Host.runHostFrame $ do

47 eventToPerform <- Host.runHostFrame $ do

47 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

48 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

48 <- S.SpiderHostFrame

49 <- S.SpiderHostFrame

49− $ fmap ( S.merge

50+ $ fmap ( S.mergeG coerce

50 . S.dynamicHold)

51 . S.dynamicHold)

51 $ S.hold DMap.empty

52 $ S.hold DMap.empty

52 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

53 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained