@@ -34,7 +34,7 @@ import Control.Monad.Identity
3434import Control.Monad.Reader
3535import Control.Monad.Ref
3636import Control.Monad.State.Strict
37−import Data.Dependent.Map (DMap)
37+import Data.Dependent.Map (DMap, DSum (..))
3838import qualified Data.Dependent.Map as DMap
3939import Data.Foldable
4040import Data.Functor.Compose
@@ -42,7 +42,6 @@ import Data.Functor.Misc
4242import Data.List.NonEmpty (NonEmpty (..))
4343import Data.Map (Map)
4444import Data.Semigroup
45−import Data.Sequence
4645import Data.Some (Some)
4746import Data.Tuple
4847
@@ -51,18 +50,32 @@ import Data.Tuple
5150class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
5251 tellEvent :: Event t w -> m ()
5352
53+data EventWriterState t w = EventWriterState
54+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
55+ , _eventWriterState_told :: ![DSum (Const2 Int w) (Event t)] -- In increasing order
56+ }
57+
5458-- | A basic implementation of 'EventWriter'.
55−newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }
59+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
5660 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
5761
5862-- | Run a 'EventWriterT' action.
59−runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
63+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
6064runEventWriterT (EventWriterT a) = do
61− (result, requests) <- runStateT a mempty
62− return (result, mconcat $ toList requests)
65+ (result, requests) <- runStateT a $ EventWriterState (-1) []
66+ let combineResults :: DMap (Const2 Int w) Identity -> w
67+ combineResults = sconcat
68+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
69+ . DMap.foldlWithKey (\vs (Const2 _) (Identity v) -> v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order
70+ return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests)
6371
6472instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
65− tellEvent w = EventWriterT $ modify (|> w)
73+ tellEvent w = EventWriterT $ modify $ \old ->
74+ let myId = _eventWriterState_nextId old
75+ in EventWriterState
76+ { _eventWriterState_nextId = pred myId
77+ , _eventWriterState_told = (Const2 myId :=> w) : _eventWriterState_told old
78+ }
6679
6780instance EventWriter t w m => EventWriter t w (ReaderT r m) where
6881 tellEvent = lift . tellEvent
@@ -99,24 +112,22 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Se
99112 -> Event t (EventWriterT t w m b)
100113 -> EventWriterT t w m (a, Event t b)
101114runWithReplaceEventWriterTWith f a0 a' = do
102− let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
103− g (EventWriterT r) = runStateT r mempty
104− (result0, result') <- f (g a0) $ fmap g a'
105− request <- holdDyn (fmapCheap sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . mergeList . toList . snd) result'
115+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
116+ request <- holdDyn (snd result0) $ fmapCheap snd result'
106117 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
107− EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
108− EventWriterT $ modify $ flip (|>) $ switch $ current request
118+ tellEvent $ coincidence $ updated request
119+ tellEvent $ switch $ current request
109120 return (fst result0, fmapCheap fst result')
110121
111122-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
112123sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
113− => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))
124+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
114125 -> DMap k v
115126 -> Event t (p k v)
116− -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))
127+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
117128 )
118− -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')
119− -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> Event t w) -> p k (Compose ((,) (Seq (Event t w))) v') -> p' (Some k) (Event t w))
129+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
130+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
120131 -> (p' (Some k) (Event t w) -> [Event t w])
121132 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
122133 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
@@ -124,19 +135,19 @@ sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, M
124135 -> Event t (p k v)
125136 -> EventWriterT t w m (DMap k v', Event t (p k v'))
126137sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
127− let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)
128− f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty
138+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
139+ f' k v = Compose . swap <$> runEventWriterT (f k v)
129140 (children0, children') <- base f' dm0 dm'
130141 let result0 = DMap.map (snd . getCompose) children0
131142 result' = fforCheap children' $ mapPatch $ snd . getCompose
132143 requests0 :: Map (Some k) (Event t w)
133− requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0
144+ requests0 = weakenDMapWith (fst . getCompose) children0
134145 requests' :: Event t (p' (Some k) (Event t w))
135− requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose
146+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
136147 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
137148 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
138− EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
139− EventWriterT $ modify $ flip (|>) $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
149+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
150+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
140151 [] -> Nothing
141152 h : t -> Just $ sconcat $ h :| t
142153 return (result0, result')