@@ -47,6 +47,8 @@ import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
4747import Data.IntMap.Strict (IntMap)
4848import qualified Data.IntMap.Strict as IntMap
4949import Data.List.NonEmpty (NonEmpty (..))
50+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
51+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
5052import Data.Map (Map)
5153import qualified Data.Map as Map
5254import Data.Semigroup
@@ -54,45 +56,7 @@ import Data.Some (Some)
5456import Data.Tuple
5557import Data.Type.Equality
5658
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
93− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
94− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
95− }
59+type EventWriterState t w = Maybe (NonEmptyDeferred (Event t w))
9660
9761-- | A basic implementation of 'EventWriter'.
9862newtype 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
10165-- | Run a 'EventWriterT' action.
10266runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
10367runEventWriterT (EventWriterT a) = do
104− (result, requests) <- runStateT a $ EventWriterState (-1) []
105− let combineResults :: DMap (TellId w) Identity -> w
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
68+ (result, requests) <- runStateT a Nothing
69+ return (result, maybe never (sconcat . NonEmptyDeferred.toNonEmpty) requests)
11070
11171instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
112− tellEvent w = EventWriterT $ modify $ \old ->
113− let myId = _eventWriterState_nextId old
114− in EventWriterState
115− { _eventWriterState_nextId = pred myId
116− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
117− }
72+ tellEvent w = EventWriterT $ modify (<> Just (NonEmptyDeferred.singleton w))
11873
11974instance MonadTrans (EventWriterT t w) where
12075 lift = EventWriterT . lift