git.iko.soy/reflex
on develop help sign in
Use NonEmptyDeferred and direct sconcat (which uses mergeInt under the hood) for EventWriterT
ead9cd5Ryan Trinkle
src/Reflex/EventWriter/Base.hs+6−51
compare with develop
unifiedsplit
@@ -47,6 +47,8 @@ import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
47import Data.IntMap.Strict (IntMap)
47import Data.IntMap.Strict (IntMap)
48import qualified Data.IntMap.Strict as IntMap
48import qualified Data.IntMap.Strict as IntMap
49import Data.List.NonEmpty (NonEmpty (..))
49import Data.List.NonEmpty (NonEmpty (..))
50+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
51+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
50import Data.Map (Map)
52import Data.Map (Map)
51import qualified Data.Map as Map
53import qualified Data.Map as Map
52import Data.Semigroup
54import Data.Semigroup
@@ -54,45 +56,7 @@ import Data.Some (Some)
54import Data.Tuple
56import Data.Tuple
55import Data.Type.Equality
57import Data.Type.Equality
56
58
57−import Unsafe.Coerce
58−
59−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
60−newtype TellId w x
61− = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead
62− deriving (Show, Eq, Ord, Enum)
63−
64−tellId :: Int -> TellId w w
65−tellId = TellId
66−{-# INLINE tellId #-}
67−
68−tellIdRefl :: TellId w x -> w :~: x
69−tellIdRefl _ = unsafeCoerce Refl
70−
71−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
72−withTellIdRefl tid r = case tellIdRefl tid of
73− Refl -> r
74−
75−instance GEq (TellId w) where
76− a `geq` b =
77− withTellIdRefl a $
78− withTellIdRefl b $
79− if a == b
80− then Just Refl
81− else Nothing
82−
83−instance GCompare (TellId w) where
84− a `gcompare` b =
85− withTellIdRefl a $
86− withTellIdRefl b $
87− case a `compare` b of
88− LT -> GLT
89− EQ -> GEQ
90− GT -> GGT
91−
92−data EventWriterState t w = EventWriterState
59+type EventWriterState t w = Maybe (NonEmptyDeferred (Event t w))
93− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
94− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
95− }
96
60
97-- | A basic implementation of 'EventWriter'.
61-- | A basic implementation of 'EventWriter'.
98newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
62newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
@@ -101,20 +65,11 @@ newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWri
101-- | Run a 'EventWriterT' action.
65-- | Run a 'EventWriterT' action.
102runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
66runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
103runEventWriterT (EventWriterT a) = do
67runEventWriterT (EventWriterT a) = do
104− (result, requests) <- runStateT a $ EventWriterState (-1) []
68+ (result, requests) <- runStateT a Nothing
105− let combineResults :: DMap (TellId w) Identity -> w
69+ return (result, maybe never (sconcat . NonEmptyDeferred.toNonEmpty) requests)
106− combineResults = sconcat
107− . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
108− . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order
109− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help
110
70
111instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
71instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
112− tellEvent w = EventWriterT $ modify $ \old ->
72+ tellEvent w = EventWriterT $ modify (<> Just (NonEmptyDeferred.singleton w))
113− let myId = _eventWriterState_nextId old
114− in EventWriterState
115− { _eventWriterState_nextId = pred myId
116− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
117− }
118
73
119instance MonadTrans (EventWriterT t w) where
74instance MonadTrans (EventWriterT t w) where
120 lift = EventWriterT . lift
75 lift = EventWriterT . lift