git.iko.soy/patch
on develop help sign in
Merge pull request #206 from reflex-frp/fix-eventwritert

Fix Adjustable for EventWriterT with simultaneous replace and tell events

commitf3edc58b3d51963229d11ab9e09c4095d6a275ef authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 26 Jul 2018, 10:44 (8 years ago) parent0b6ac99a4855dd
2 files changed+27−10
compare with develop
unifiedsplit
src/Reflex/EventWriter/Base.hs+6−9 test/EventWriterT.hs+21−1
src/Reflex/EventWriter/Base.hs+6−9
@@ -154,10 +154,7 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Se
154154 -> EventWriterT t w m (a, Event t b)
155155runWithReplaceEventWriterTWith f a0 a' = do
156156 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
157− request <- holdDyn (snd result0) $ fmapCheap snd result'
158− -- 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.)
159− tellEvent $ coincidence $ updated request
160− tellEvent $ switch $ current request
157+ tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')
161158 return (fst result0, fmapCheap fst result')
162159
163160-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
@@ -219,6 +216,7 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewEle
219216tellEventsPromptly
220217 :: ( Foldable f
221218 , Reflex t
219+ , MonadHold t m
222220 , EventWriter t w m
223221 )
224222 => Event t a
@@ -226,11 +224,10 @@ tellEventsPromptly
226224 -> Event t (f w)
227225 -> m ()
228226tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
229− -- 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.)
230− tellEvent $ coincidence $ fmapCheap (mconcat . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
231− tellEvent $ fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
232− [] -> Nothing
233− h : t -> Just $ sconcat $ h :| t
227+ let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
228+ [] -> Nothing
229+ h : t -> Just $ sconcat $ h :| t
230+ tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')
234231
235232instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
236233 type Performable (EventWriterT t w m) = Performable m
test/EventWriterT.hs+21−1
@@ -1,9 +1,11 @@
11{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
34module Main where
45
56import Control.Lens
67import Control.Monad
8+import Control.Monad.Fix
79import Data.These
810
911import Reflex
@@ -24,6 +26,8 @@ main = do
2426 , These () ()
2527 ]
2628 print os2
29+ os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
30+ print os3
2731 return ()
2832
2933unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -43,3 +47,19 @@ testSimultaneous pulse = do
4347 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
4448 return ()
4549
50+-- | Test that a widget telling and event which fires at the same time it has been replaced
51+-- doesn't count along with the new widget.
52+testMoribundTellEvent
53+ :: forall t m
54+ . ( Reflex t
55+ , Adjustable t m
56+ , MonadHold t m
57+ , MonadFix m
58+ )
59+ => Event t ()
60+ -> EventWriterT t [Int] m ()
61+testMoribundTellEvent pulse = do
62+ rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
63+ tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
64+ (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
65+ return ()