git.iko.soy/reflex
on 8064382 help sign in
90891e1
swap
7 ahead, 338 behind
ChangeLog.md+1−12
since splitsnapshots
unifiedsplit
@@ -16,23 +16,12 @@
16
16
17## 0.6.2.1
17## 0.6.2.1
18
18
19−* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`
20− functor:
21− * `fan` to `fanG`
22− * `EventSelectorG` for `fanG` result selector.
23−
24−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.
25− * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)
26− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic
27−
28* Generalize merging functions:
19* Generalize merging functions:
29 `merge` to `mergeG`,
20 `merge` to `mergeG`,
30 `mergeIncremental` to `mergeIncrementalG`,
21 `mergeIncremental` to `mergeIncrementalG`,
22+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
31 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
23 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
32
24
33−* Generalize distribute function:
34− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
35−
36## 0.6.2.0
25## 0.6.2.0
37
26
38* Fix `holdDyn` so that it is lazy in its event argument
27* Fix `holdDyn` so that it is lazy in its event argument
default.nix−1
@@ -23,7 +23,6 @@ mkDerivation {
23 base bifunctors containers deepseq dependent-map dependent-sum
23 base bifunctors containers deepseq dependent-map dependent-sum
24 mtl ref-tf split transformers data-default
24 mtl ref-tf split transformers data-default
25 random time unbounded-delays monoidal-containers witherable
25 random time unbounded-delays monoidal-containers witherable
26− profunctors
27 ] ++ (if ghc.isGhcjs or false then [
26 ] ++ (if ghc.isGhcjs or false then [
28 ghcjs-base
27 ghcjs-base
29 ] else []) ++ (if !useTemplateHaskell then [] else [
28 ] else []) ++ (if !useTemplateHaskell then [] else [
reflex.cabal+2
@@ -115,9 +115,11 @@ library
115 Reflex.Patch.Class,
115 Reflex.Patch.Class,
116 Reflex.Patch.DMap,
116 Reflex.Patch.DMap,
117 Reflex.Patch.DMapWithMove,
117 Reflex.Patch.DMapWithMove,
118+ Reflex.Patch.DMapWithReset,
118 Reflex.Patch.IntMap,
119 Reflex.Patch.IntMap,
119 Reflex.Patch.Map,
120 Reflex.Patch.Map,
120 Reflex.Patch.MapWithMove,
121 Reflex.Patch.MapWithMove,
122+ Reflex.Patch.Patchable,
121 Reflex.PerformEvent.Base,
123 Reflex.PerformEvent.Base,
122 Reflex.PerformEvent.Class,
124 Reflex.PerformEvent.Class,
123 Reflex.PostBuild.Base,
125 Reflex.PostBuild.Base,
src/Reflex/Class.hs+7−45
@@ -41,7 +41,6 @@ module Reflex.Class
41 , MonadHold (..)
41 , MonadHold (..)
42 -- ** 'fan' related types
42 -- ** 'fan' related types
43 , EventSelector (..)
43 , EventSelector (..)
44− , EventSelectorG (..)
45 , EventSelectorInt (..)
44 , EventSelectorInt (..)
46 -- * Convenience functions
45 -- * Convenience functions
47 , constDyn
46 , constDyn
@@ -65,7 +64,6 @@ module Reflex.Class
65 , alignEventWithMaybe
64 , alignEventWithMaybe
66 -- ** Breaking up 'Event's
65 -- ** Breaking up 'Event's
67 , splitE
66 , splitE
68− , fan
69 , fanEither
67 , fanEither
70 , fanThese
68 , fanThese
71 , fanMap
69 , fanMap
@@ -90,7 +88,6 @@ module Reflex.Class
90 , gate
88 , gate
91 -- ** Combining 'Dynamic's
89 -- ** Combining 'Dynamic's
92 , distributeDMapOverDynPure
90 , distributeDMapOverDynPure
93− , distributeDMapOverDynPureG
94 , distributeListOverDyn
91 , distributeListOverDyn
95 , distributeListOverDynWith
92 , distributeListOverDynWith
96 , zipDyn
93 , zipDyn
@@ -273,16 +270,13 @@ class ( MonadHold t (PushM t)
273 -- | Merge a collection of events; the resulting 'Event' will only occur if at
270 -- | Merge a collection of events; the resulting 'Event' will only occur if at
274 -- least one input event is occurring, and will contain all of the input keys
271 -- least one input event is occurring, and will contain all of the input keys
275 -- that are occurring simultaneously
272 -- that are occurring simultaneously
276−
277− --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
278 mergeG :: GCompare k => (forall a. q a -> Event t (v a))
273 mergeG :: GCompare k => (forall a. q a -> Event t (v a))
279 -> DMap k q -> Event t (DMap k v)
274 -> DMap k q -> Event t (DMap k v)
280−
275+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
281 -- | Efficiently fan-out an event to many destinations. You should save the
276 -- | Efficiently fan-out an event to many destinations. You should save the
282− -- result in a @let@-binding, and then repeatedly 'selectG' on the result to
277+ -- result in a @let@-binding, and then repeatedly 'select' on the result to
283 -- create child events
278 -- create child events
284− fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v
279+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k
285−
286 -- | Create an 'Event' that will occur whenever the currently-selected input
280 -- | Create an 'Event' that will occur whenever the currently-selected input
287 -- 'Event' occurs
281 -- 'Event' occurs
288 switch :: Behavior t (Event t a) -> Event t a
282 switch :: Behavior t (Event t a) -> Event t a
@@ -330,18 +324,6 @@ class ( MonadHold t (PushM t)
330 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
324 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
331 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
325 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
332
326
333−-- | Efficiently fan-out an event to many destinations. You should save the
334−-- result in a @let@-binding, and then repeatedly 'select' on the result to
335−-- create child events
336−fan :: forall t k. (Reflex t, GCompare k)
337− => Event t (DMap k Identity) -> EventSelector t k
338− --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
339−fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)
340− where
341− fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a
342− fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of
343− Coercion -> coerce
344−
345--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
327--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
346-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
328-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
347-- keys simultaneously.
329-- keys simultaneously.
@@ -535,17 +517,6 @@ newtype EventSelector t k = EventSelector
535 select :: forall a. k a -> Event t a
517 select :: forall a. k a -> Event t a
536 }
518 }
537
519
538−newtype EventSelectorG t k v = EventSelectorG
539− { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
540− -- determined by the type of the key, so this can be used to fan-out
541− -- 'Event's whose sub-'Event's have different types.
542− --
543− -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
544− -- (but equivalent to) using 'mapMaybe' to select only the relevant
545− -- occurrences of an 'Event'.
546− selectG :: forall a. k a -> Event t (v a)
547− }
548−
549-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
520-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
550-- filtering by key.
521-- filtering by key.
551newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
522newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
@@ -1138,21 +1109,12 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1138-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1109-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1139-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1110-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1140distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1111distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1141−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic
1112+distributeDMapOverDynPure dm = case DMap.toList dm of
1142−
1143−-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1144−-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1145−-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1146−distributeDMapOverDynPureG
1147− :: forall t k q v. (Reflex t, GCompare k)
1148− => (forall a. q a -> Dynamic t (v a))
1149− -> DMap k q -> Dynamic t (DMap k v)
1150−distributeDMapOverDynPureG nt dm = case DMap.toList dm of
1151 [] -> constDyn DMap.empty
1113 [] -> constDyn DMap.empty
1152− [k :=> v] -> DMap.singleton k <$> nt v
1114+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
1153 _ ->
1115 _ ->
1154− let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1116+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1155− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
1117+ edmPre = merge $ DMap.map updated dm
1156 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1118 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1157 olds <- sample $ current result
1119 olds <- sample $ current result
1158 return $ DMap.unionWithKey (\_ _ new -> new) olds news
1120 return $ DMap.unionWithKey (\_ _ new -> new) olds news
src/Reflex/Patch/DMapWithReset.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+{-# OPTIONS_GHC -Wall #-}
14+
15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
16+module Reflex.Patch.DMapWithReset where
17+
18+import Reflex.Patch.Class
19+
20+import Data.Dependent.Map (DMap, GCompare (..))
21+import qualified Data.Dependent.Map as DMap
22+import Data.Semigroup (Semigroup (..))
23+import Data.Constraint.Extras
24+
25+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
27+-- while deletions are represented as @'ComposeMaybe' Nothing@.
28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
29+
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
32+data By p a
33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
34+ | By_Delete -- ^ Delete the existing value, if any, from here
35+ | By_Patch (p a) -- ^ Patch the value here with the given patch
36+
37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
38+ x@(By_Insert _) <> _ = x
39+ By_Delete <> _ = By_Delete
40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
41+ By_Patch x <> By_Patch y = By_Patch (x <> y)
42+ By_Patch _ <> By_Delete = By_Delete
43+
44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
45+ mappend = (<>)
46+ mempty = By_Patch mempty
47+
48+instance
49+ ( GCompare k
50+ , Has' Semigroup k p
51+ , Has' Patch k p
52+ )
53+ => Semigroup (PatchDMapWithReset k p) where
54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
55+ (\k -> has' @Patch @p k
56+ $ has' @Semigroup @p k
57+ $ (<>)) xs ys
58+
59+instance
60+ ( GCompare k
61+ , Has' Semigroup k p
62+ , Has' Patch k p
63+ )
64+ => Monoid (PatchDMapWithReset k p) where
65+ mappend = (<>)
66+ mempty = PatchDMapWithReset DMap.empty
67+
68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69+ type Patches1LocallyTarget p :: k -> *
70+
71+data These1 f g x
72+ = This1 (f x)
73+ | That1 (g x)
74+ | These1 (f x) (g x)
75+
76+mergeWithKey
77+ :: forall k v1 v2 v.
78+ (GCompare k)
79+ => (forall x. k x -> v1 x -> Maybe (v x))
80+ -> (forall x. k x -> v2 x -> Maybe (v x))
81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
82+ -> DMap k v1 -> DMap k v2 -> DMap k v
83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
84+ where
85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys
86+ doIt _ _ _ = error "mergeWithKey misalligned keys"
87+
88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
89+ onlyThat k = \case
90+ This1 xs -> f k xs
91+ That1 ys -> g k ys
92+ These1 xs ys -> fg k xs ys
93+{-# INLINE mergeWithKey #-}
94+
95+-- | Apply the insertions or deletions to a given 'DMap'.
96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
97+
98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99+
100+ apply = go
101+ where
102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
104+ where
105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
106+ updates k ys = has @(Patches1Locally p) k $ \case
107+ By_Insert x -> Just x
108+ By_Delete -> Nothing
109+ By_Patch x -> Just $ applyAlways x ys
110+
111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
112+ inserts k = has @(Patches1Locally p) k $ \case
113+ By_Insert x -> Just x
114+ By_Delete -> Nothing
115+ By_Patch _ -> Nothing
116+
117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)
src/Reflex/Patch/Patchable.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE TypeFamilies #-}
6+
7+-- The derived instances are undecidable in the case of a pathological instance like
8+-- instance Patch x where
9+-- type PatchTarget x = Patchable x
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+module Reflex.Patch.Patchable where
13+
14+-- import Data.Aeson
15+import GHC.Generics
16+import Reflex.Patch
17+
18+-- | Like SemiMap/PartialMap but for anything patchable
19+data Patchable p
20+ = Patchable_Patch p
21+ | Patchable_Complete (PatchTarget p)
22+ deriving (Generic)
23+
24+completePatchable :: Patchable p -> Maybe (PatchTarget p)
25+completePatchable = \case
26+ Patchable_Complete t -> Just t
27+ Patchable_Patch _ -> Nothing
28+
29+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
30+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
31+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
32+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
33+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
34+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
35+
36+instance (Monoid p, Patch p) => Monoid (Patchable p) where
37+ mempty = Patchable_Patch mempty
38+ mappend = (<>)
39+
40+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
41+ (<>) = curry $ \case
42+ (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
43+ (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
44+ (Patchable_Complete a, _) -> Patchable_Complete a
src/Reflex/Profiled.hs+1−1
@@ -136,11 +136,11 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
138 pull = Behavior_Profiled . pull . coerce
138 pull = Behavior_Profiled . pull . coerce
139− fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
140 mergeG :: forall (k :: z -> *) q v. GCompare k
139 mergeG :: forall (k :: z -> *) q v. GCompare k
141 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
140 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
142 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
141 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
143 mergeG nt = Event_Profiled #. mergeG (coerce nt)
142 mergeG nt = Event_Profiled #. mergeG (coerce nt)
143+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
146 current (Dynamic_Profiled d) = coerce $ current d
146 current (Dynamic_Profiled d) = coerce $ current d
src/Reflex/Pure.hs+3−4
@@ -7,7 +7,6 @@
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
10−
11#ifdef USE_REFLEX_OPTIMIZER
10#ifdef USE_REFLEX_OPTIMIZER
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13#endif
12#endif
@@ -34,6 +33,7 @@ module Reflex.Pure
34import Control.Monad
33import Control.Monad
35import Data.Dependent.Map (DMap, GCompare)
34import Data.Dependent.Map (DMap, GCompare)
36import qualified Data.Dependent.Map as DMap
35import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
37import Data.IntMap (IntMap)
37import Data.IntMap (IntMap)
38import qualified Data.IntMap as IntMap
38import qualified Data.IntMap as IntMap
39import Data.Maybe
39import Data.Maybe
@@ -88,9 +88,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
88 then Nothing
88 then Nothing
89 else Just currentOccurrences
89 else Just currentOccurrences
90
90
91−-- The instance signature doeesn't compile, leave commented for documentation
92−-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
91+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
93− fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
92+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
94
93
95 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
94 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
95 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
src/Reflex/Spider/Internal.hs+68−75
@@ -20,7 +20,6 @@
20{-# LANGUAGE DeriveFunctor #-}
20{-# LANGUAGE DeriveFunctor #-}
21{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE StandaloneDeriving #-}
22{-# LANGUAGE InstanceSigs #-}
22{-# LANGUAGE InstanceSigs #-}
23−
24#ifdef USE_REFLEX_OPTIMIZER
23#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
24{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
26#endif
25#endif
@@ -211,6 +210,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
211
210
212newNodeId :: IO Int
211newNodeId :: IO Int
213newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
212newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
213+
214+{-# NOINLINE unsafeNodeId #-}
215+unsafeNodeId :: a -> Int
216+unsafeNodeId a = unsafePerformIO $ do
217+ touch a
218+ newNodeId
214#endif
219#endif
215
220
216--------------------------------------------------------------------------------
221--------------------------------------------------------------------------------
@@ -314,10 +319,9 @@ cacheEvent e =
314#else
319#else
315 Event $
320 Event $
316#endif
321#endif
317− unsafePerformIO $ do
318− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
322+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
319− <- newIORef emptyFastWeak
323+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
320− pure $ \sub -> {-# SCC "cacheEvent" #-} do
324+ in \sub -> {-# SCC "cacheEvent" #-} do
321#ifdef DEBUG_TRACE_EVENTS
325#ifdef DEBUG_TRACE_EVENTS
322 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
326 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
323#endif
327#endif
@@ -383,7 +387,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
383eventNever :: Event x a
387eventNever :: Event x a
384eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
388eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
385
389
386−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
390+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
387eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
391eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
388
392
389eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
393eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -435,14 +439,14 @@ newSubscriberHold h = return $ Subscriber
435 , subscriberRecalculateHeight = \_ -> return ()
439 , subscriberRecalculateHeight = \_ -> return ()
436 }
440 }
437
441
438−newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
442+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
439newSubscriberFan subscribed = return $ Subscriber
443newSubscriberFan subscribed = return $ Subscriber
440 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
444 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
441 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
445 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
442 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
446 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
443 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
447 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
444 scheduleClear $ fanSubscribedOccurrence subscribed
448 scheduleClear $ fanSubscribedOccurrence subscribed
445− let f _ (Pair v subsubs) = do
449+ let f _ (Pair (Identity v) subsubs) = do
446 propagate v $ _fanSubscribedChildren_list subsubs
450 propagate v $ _fanSubscribedChildren_list subsubs
447 return $ Constant ()
451 return $ Constant ()
448 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
452 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -595,7 +599,7 @@ eventSubscribedNever = EventSubscribed
595#endif
599#endif
596 }
600 }
597
601
598−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
602+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
599eventSubscribedFan !subscribed = EventSubscribed
603eventSubscribedFan !subscribed = EventSubscribed
600 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
604 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
601 , eventSubscribedRetained = toAny subscribed
605 , eventSubscribedRetained = toAny subscribed
@@ -1013,7 +1017,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1013#endif
1017#endif
1014 }
1018 }
1015
1019
1016−data Root x k
1020+data Root x (k :: * -> *)
1017 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1021 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1018 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1022 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1019 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1023 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1083,25 +1087,25 @@ heightBagVerify b@(HeightBag s c) = if
1083heightBagVerify = id
1087heightBagVerify = id
1084#endif
1088#endif
1085
1089
1086−data FanSubscribedChildren x k v a = FanSubscribedChildren
1090+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1087− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1091+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1088− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1092+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1089− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1093+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1090 }
1094 }
1091
1095
1092−data FanSubscribed x k v
1096+data FanSubscribed (x :: *) k
1093− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1097+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1094− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1098+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1095− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1099+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1096 , fanSubscribedParent :: !(EventSubscription x)
1100 , fanSubscribedParent :: !(EventSubscription x)
1097#ifdef DEBUG_NODEIDS
1101#ifdef DEBUG_NODEIDS
1098 , fanSubscribedNodeId :: Int
1102 , fanSubscribedNodeId :: Int
1099#endif
1103#endif
1100 }
1104 }
1101
1105
1102−data Fan x k v
1106+data Fan x k
1103− = Fan { fanParent :: !(Event x (DMap k v))
1107+ = Fan { fanParent :: !(Event x (DMap k Identity))
1104− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1108+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1105 }
1109 }
1106
1110
1107data SwitchSubscribed x a
1111data SwitchSubscribed x a
@@ -1206,12 +1210,18 @@ buildDynamic readV0 v' = do
1206 return d
1210 return d
1207
1211
1208unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1212unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1209−unsafeBuildDynamic readV0 v' =
1213+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1210− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1214+ where x = (readV0, v')
1211
1215
1212-- ResultM can read behaviors and events
1216-- ResultM can read behaviors and events
1213type ResultM = EventM
1217type ResultM = EventM
1214
1218
1219+{-# NOINLINE unsafeNewIORef #-}
1220+unsafeNewIORef :: a -> b -> IORef b
1221+unsafeNewIORef a b = unsafePerformIO $ do
1222+ touch a
1223+ newIORef b
1224+
1215instance HasSpiderTimeline x => Functor (Event x) where
1225instance HasSpiderTimeline x => Functor (Event x) where
1216 fmap f = push $ return . Just . f
1226 fmap f = push $ return . Just . f
1217
1227
@@ -1224,35 +1234,26 @@ push f e = cacheEvent (pushCheap f e)
1224
1234
1225{-# INLINABLE pull #-}
1235{-# INLINABLE pull #-}
1226pull :: BehaviorM x a -> Behavior x a
1236pull :: BehaviorM x a -> Behavior x a
1227−pull a = unsafePerformIO $ do
1228− ref <- newIORef Nothing
1229−#ifdef DEBUG_NODEIDS
1230− nid <- newNodeId
1231−#endif
1232− pure $ behaviorPull $ Pull
1237+pull a = behaviorPull $ Pull
1233− { pullCompute = a
1238+ { pullCompute = a
1234− , pullValue = ref
1239+ , pullValue = unsafeNewIORef a Nothing
1235#ifdef DEBUG_NODEIDS
1240#ifdef DEBUG_NODEIDS
1236− , pullNodeId = nid
1241+ , pullNodeId = unsafeNodeId a
1237#endif
1242#endif
1238− }
1243+ }
1239
1244
1240{-# INLINABLE switch #-}
1245{-# INLINABLE switch #-}
1241switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1246switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1242−switch a = unsafePerformIO $ do
1243− ref <- newIORef Nothing
1244− pure $ eventSwitch $ Switch
1247+switch a = eventSwitch $ Switch
1245− { switchParent = a
1248+ { switchParent = a
1246− , switchSubscribed = ref
1249+ , switchSubscribed = unsafeNewIORef a Nothing
1247− }
1250+ }
1248
1251
1249coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1252coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1250−coincidence a = unsafePerformIO $ do
1251− ref <- newIORef Nothing
1252− pure $ eventCoincidence $ Coincidence
1253+coincidence a = eventCoincidence $ Coincidence
1253− { coincidenceParent = a
1254+ { coincidenceParent = a
1254− , coincidenceSubscribed = ref
1255+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1255− }
1256+ }
1256
1257
1257-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1258-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1258run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1259run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
@@ -1456,9 +1457,6 @@ getRootSubscribed k r sub = do
1456 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1457 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1457 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1458 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1458 writeIORef uninitRef $! uninit
1459 writeIORef uninitRef $! uninit
1459−#ifdef DEBUG_NODEIDS
1460− nid <- newNodeId
1461−#endif
1462 let !subscribed = RootSubscribed
1460 let !subscribed = RootSubscribed
1463 { rootSubscribedKey = k
1461 { rootSubscribedKey = k
1464 , rootSubscribedCachedSubscribed = cached
1462 , rootSubscribedCachedSubscribed = cached
@@ -1467,7 +1465,7 @@ getRootSubscribed k r sub = do
1467 , rootSubscribedUninit = uninit
1465 , rootSubscribedUninit = uninit
1468 , rootSubscribedWeakSelf = weakSelf
1466 , rootSubscribedWeakSelf = weakSelf
1469#ifdef DEBUG_NODEIDS
1467#ifdef DEBUG_NODEIDS
1470− , rootSubscribedNodeId = nid
1468+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1471#endif
1469#endif
1472 }
1470 }
1473 -- If we die at the same moment that all our children die, they will
1471 -- If we die at the same moment that all our children die, they will
@@ -1516,10 +1514,16 @@ newFanInt = do
1516 , _fanInt_occRef = occRef
1514 , _fanInt_occRef = occRef
1517 }
1515 }
1518
1516
1517+{-# NOINLINE unsafeNewFanInt #-}
1518+unsafeNewFanInt :: b -> FanInt x a
1519+unsafeNewFanInt b = unsafePerformIO $ do
1520+ touch b
1521+ newFanInt
1522+
1519fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1523fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1520−fanInt p = unsafePerformIO $ do
1524+fanInt p =
1521− self <- newFanInt
1525+ let self = unsafeNewFanInt p
1522− pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1526+ in EventSelectorInt $ \k -> Event $ \sub -> do
1523 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1527 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1524 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1528 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1525 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1529 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1555,7 +1559,7 @@ fanInt p = unsafePerformIO $ do
1555 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1559 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1556
1560
1557{-# INLINABLE getFanSubscribed #-}
1561{-# INLINABLE getFanSubscribed #-}
1558−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1562+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1559getFanSubscribed k f sub = do
1563getFanSubscribed k f sub = do
1560 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1564 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1561 case mSubscribed of
1565 case mSubscribed of
@@ -1573,16 +1577,13 @@ getFanSubscribed k f sub = do
1573 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1577 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1574 occRef <- liftIO $ newIORef parentOcc
1578 occRef <- liftIO $ newIORef parentOcc
1575 when (isJust parentOcc) $ scheduleClear occRef
1579 when (isJust parentOcc) $ scheduleClear occRef
1576−#ifdef DEBUG_NODEIDS
1577− nid <- liftIO newNodeId
1578−#endif
1579 let subscribed = FanSubscribed
1580 let subscribed = FanSubscribed
1580 { fanSubscribedCachedSubscribed = fanSubscribed f
1581 { fanSubscribedCachedSubscribed = fanSubscribed f
1581 , fanSubscribedOccurrence = occRef
1582 , fanSubscribedOccurrence = occRef
1582 , fanSubscribedParent = subscription
1583 , fanSubscribedParent = subscription
1583 , fanSubscribedSubscribers = subscribersRef
1584 , fanSubscribedSubscribers = subscribersRef
1584#ifdef DEBUG_NODEIDS
1585#ifdef DEBUG_NODEIDS
1585− , fanSubscribedNodeId = nid
1586+ , fanSubscribedNodeId = unsafeNodeId f
1586#endif
1587#endif
1587 }
1588 }
1588 let !self = (k, subscribed)
1589 let !self = (k, subscribed)
@@ -1592,7 +1593,7 @@ getFanSubscribed k f sub = do
1592 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1593 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1593 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1594 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1594
1595
1595−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1596+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1596cleanupFanSubscribed (k, subscribed) = do
1597cleanupFanSubscribed (k, subscribed) = do
1597 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1598 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1598 let reducedSubscribers = DMap.delete k subscribers
1599 let reducedSubscribers = DMap.delete k subscribers
@@ -1604,7 +1605,7 @@ cleanupFanSubscribed (k, subscribed) = do
1604 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1605 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1605
1606
1606{-# INLINE subscribeFanSubscribed #-}
1607{-# INLINE subscribeFanSubscribed #-}
1607−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1608+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1608subscribeFanSubscribed k subscribed sub = do
1609subscribeFanSubscribed k subscribed sub = do
1609 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1610 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1610 case DMap.lookup k subscribers of
1611 case DMap.lookup k subscribers of
@@ -1642,9 +1643,6 @@ getSwitchSubscribed s sub = do
1642 when (isJust parentOcc) $ scheduleClear occRef
1643 when (isJust parentOcc) $ scheduleClear occRef
1643 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1644 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1644 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1645 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1645−#ifdef DEBUG_NODEIDS
1646− nid <- liftIO newNodeId
1647−#endif
1648 let !subscribed = SwitchSubscribed
1646 let !subscribed = SwitchSubscribed
1649 { switchSubscribedCachedSubscribed = switchSubscribed s
1647 { switchSubscribedCachedSubscribed = switchSubscribed s
1650 , switchSubscribedOccurrence = occRef
1648 , switchSubscribedOccurrence = occRef
@@ -1657,7 +1655,7 @@ getSwitchSubscribed s sub = do
1657 , switchSubscribedCurrentParent = subscriptionRef
1655 , switchSubscribedCurrentParent = subscriptionRef
1658 , switchSubscribedWeakSelf = weakSelf
1656 , switchSubscribedWeakSelf = weakSelf
1659#ifdef DEBUG_NODEIDS
1657#ifdef DEBUG_NODEIDS
1660− , switchSubscribedNodeId = nid
1658+ , switchSubscribedNodeId = unsafeNodeId s
1661#endif
1659#endif
1662 }
1660 }
1663 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1661 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1702,9 +1700,6 @@ getCoincidenceSubscribed c sub = do
1702 scheduleClear innerSubdRef
1700 scheduleClear innerSubdRef
1703 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1701 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1704 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1702 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1705−#ifdef DEBUG_NODEIDS
1706− nid <- liftIO newNodeId
1707−#endif
1708 let subscribed = CoincidenceSubscribed
1703 let subscribed = CoincidenceSubscribed
1709 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1704 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1710 , coincidenceSubscribedOccurrence = occRef
1705 , coincidenceSubscribedOccurrence = occRef
@@ -1715,7 +1710,7 @@ getCoincidenceSubscribed c sub = do
1715 , coincidenceSubscribedInnerParent = innerSubdRef
1710 , coincidenceSubscribedInnerParent = innerSubdRef
1716 , coincidenceSubscribedWeakSelf = weakSelf
1711 , coincidenceSubscribedWeakSelf = weakSelf
1717#ifdef DEBUG_NODEIDS
1712#ifdef DEBUG_NODEIDS
1718− , coincidenceSubscribedNodeId = nid
1713+ , coincidenceSubscribedNodeId = unsafeNodeId c
1719#endif
1714#endif
1720 }
1715 }
1721 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1716 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -2086,16 +2081,14 @@ mergeIntCheap d = Event $ \sub -> do
2086 )
2081 )
2087
2082
2088newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2083newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2089−newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2090
2084
2091−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2085+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2092−fanG e = unsafePerformIO $ do
2086+fan e =
2093− ref <- newIORef Nothing
2094 let f = Fan
2087 let f = Fan
2095 { fanParent = e
2088 { fanParent = e
2096− , fanSubscribed = ref
2089+ , fanSubscribed = unsafeNewIORef e Nothing
2097 }
2090 }
2098− pure $ EventSelectorG $ \k -> eventFan k f
2091+ in EventSelector $ \k -> eventFan k f
2099
2092
2100runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2093runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2101runHoldInits holdInitRef dynInitRef mergeInitRef = do
2094runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2564,8 +2557,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2564 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2557 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2565 {-# INLINABLE pull #-}
2558 {-# INLINABLE pull #-}
2566 pull = SpiderBehavior . pull . coerce
2559 pull = SpiderBehavior . pull . coerce
2567− {-# INLINABLE fanG #-}
2568− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2569 {-# INLINABLE mergeG #-}
2560 {-# INLINABLE mergeG #-}
2570 mergeG
2561 mergeG
2571 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2562 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
@@ -2573,6 +2564,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2573 -> DMap k q
2564 -> DMap k q
2574 -> R.Event (SpiderTimeline x) (DMap k v)
2565 -> R.Event (SpiderTimeline x) (DMap k v)
2575 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2566 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2567+ {-# INLINABLE fan #-}
2568+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2576 {-# INLINABLE switch #-}
2569 {-# INLINABLE switch #-}
2577 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2570 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2578 {-# INLINABLE coincidence #-}
2571 {-# INLINABLE coincidence #-}
test/GC.hs+2−2
@@ -56,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do
56 { S.subscriberPropagate = S.subscriberPropagate sub
56 { S.subscriberPropagate = S.subscriberPropagate sub
57 }
57 }
58 return (s, o))
58 return (s, o))
59− $ runIdentity . runIdentity <$> S.selectG
59+ $ runIdentity <$> S.select
60− (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
61 (WrapArg Request)
61 (WrapArg Request)
62 return $ alignWith (mergeThese (<>))
62 return $ alignWith (mergeThese (<>))
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do