@@ -34,7 +34,7 @@ import Control.Monad.Identity
34import Control.Monad.Reader
34import Control.Monad.Reader
35import Control.Monad.Ref
35import Control.Monad.Ref
36import Control.Monad.State.Strict
36import Control.Monad.State.Strict
37−import Data.Dependent.Map (DMap)
37+import Data.Dependent.Map (DMap, DSum (..))
38import qualified Data.Dependent.Map as DMap
38import qualified Data.Dependent.Map as DMap
39import Data.Foldable
39import Data.Foldable
40import Data.Functor.Compose
40import Data.Functor.Compose
@@ -42,7 +42,6 @@ import Data.Functor.Misc
42import Data.List.NonEmpty (NonEmpty (..))
42import Data.List.NonEmpty (NonEmpty (..))
43import Data.Map (Map)
43import Data.Map (Map)
44import Data.Semigroup
44import Data.Semigroup
46import Data.Some (Some)
45import Data.Some (Some)
47import Data.Tuple
46import Data.Tuple
@@ -51,18 +50,32 @@ import Data.Tuple
51class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
50class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
52 tellEvent :: Event t w -> m ()
51 tellEvent :: Event t w -> m ()
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
54-- | A basic implementation of 'EventWriter'.
58-- | 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 }
56 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
60 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
58-- | Run a 'EventWriterT' action.
62-- | 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)
60runEventWriterT (EventWriterT a) = do
64runEventWriterT (EventWriterT a) = do
61− (result, requests) <- runStateT a mempty
65+ (result, requests) <- runStateT a $ EventWriterState (-1) []
62− return (result, mconcat $ toList requests)
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)
64instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
72instance (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
76+ { _eventWriterState_nextId = pred myId
77+ , _eventWriterState_told = (Const2 myId :=> w) : _eventWriterState_told old
67instance EventWriter t w m => EventWriter t w (ReaderT r m) where
80instance EventWriter t w m => EventWriter t w (ReaderT r m) where
68 tellEvent = lift . tellEvent
81 tellEvent = lift . tellEvent
@@ -99,24 +112,22 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Se
99 -> Event t (EventWriterT t w m b)
112 -> Event t (EventWriterT t w m b)
100 -> EventWriterT t w m (a, Event t b)
113 -> EventWriterT t w m (a, Event t b)
101runWithReplaceEventWriterTWith f a0 a' = do
114runWithReplaceEventWriterTWith 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'
115+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
105− request <- holdDyn (fmapCheap sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . mergeList . toList . snd) result'
116+ request <- holdDyn (snd result0) $ fmapCheap snd result'
106 -- 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.)
117 -- 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
118+ tellEvent $ coincidence $ updated request
108− EventWriterT $ modify $ flip (|>) $ switch $ current request
119+ tellEvent $ switch $ current request
109 return (fst result0, fmapCheap fst result')
120 return (fst result0, fmapCheap fst result')
111-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
122-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
112sequenceDMapWithAdjustEventWriterTWith :: 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))
123sequenceDMapWithAdjustEventWriterTWith :: 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))
114 -> DMap k v
125 -> DMap k v
115 -> Event t (p k v)
126 -> 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')))
118− -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')
129+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (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))
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))
120 -> (p' (Some k) (Event t w) -> [Event t w])
131 -> (p' (Some k) (Event t w) -> [Event t w])
121 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
132 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
122 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
133 -> (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
124 -> Event t (p k v)
135 -> Event t (p k v)
125 -> EventWriterT t w m (DMap k v', Event t (p k v'))
136 -> EventWriterT t w m (DMap k v', Event t (p k v'))
126sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
137sequenceDMapWithAdjustEventWriterTWith 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)
138+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
128− f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty
139+ f' k v = Compose . swap <$> runEventWriterT (f k v)
129 (children0, children') <- base f' dm0 dm'
140 (children0, children') <- base f' dm0 dm'
130 let result0 = DMap.map (snd . getCompose) children0
141 let result0 = DMap.map (snd . getCompose) children0
131 result' = fforCheap children' $ mapPatch $ snd . getCompose
142 result' = fforCheap children' $ mapPatch $ snd . getCompose
132 requests0 :: Map (Some k) (Event t w)
143 requests0 :: Map (Some k) (Event t w)
133− requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0
144+ requests0 = weakenDMapWith (fst . getCompose) children0
134 requests' :: Event t (p' (Some k) (Event t w))
145 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
136 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
147 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
137 -- 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.)
148 -- 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'
149+ tellEvent $ 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
150+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
140 [] -> Nothing
151 [] -> Nothing
141 h : t -> Just $ sconcat $ h :| t
152 h : t -> Just $ sconcat $ h :| t
142 return (result0, result')
153 return (result0, result')