git.iko.soy/patch
on develop help sign in
Merge pull request #266 from reflex-frp/ts-requestert-inconsistency
45123e1Ali Abrar
test/EventWriterT.hs+18
compare with develop
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RecursiveDo #-}
4{-# LANGUAGE RecursiveDo #-}
@@ -36,6 +37,9 @@ main = do
36 print os4
37 print os4
37 os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
38 os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
38 print os5
39 print os5
40+ os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
41+ print os6
42+ let ![[Nothing, Nothing]] = os6
39 return ()
43 return ()
40
44
41unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
45unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -112,3 +116,17 @@ testLiveTellEventDMap pulse = do
112 (mapToDMap $ M.singleton 1 ())
116 (mapToDMap $ M.singleton 1 ())
113 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
117 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
114 return ()
118 return ()
119+
120+delayedPulse
121+ :: forall t m
122+ . ( Reflex t
123+ , Adjustable t m
124+ , MonadHold t m
125+ , MonadFix m
126+ )
127+ => Event t ()
128+ -> EventWriterT t [Int] m ()
129+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
130+ -- This has the effect of delaying pulse' from pulse
131+ (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse
132+ tellEvent pulse'
test/RequesterT.hs+101−1
@@ -2,13 +2,17 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6module Main where
7module Main where
7
8
8import Control.Lens
9import Control.Lens
9import Control.Monad
10import Control.Monad
11+import Control.Monad.Fix
10import qualified Data.Dependent.Map as DMap
12import qualified Data.Dependent.Map as DMap
11import Data.Dependent.Sum
13import Data.Dependent.Sum
14+import Data.Functor.Misc
15+import qualified Data.Map as M
12import Data.These
16import Data.These
13
17
14import Reflex
18import Reflex
@@ -25,7 +29,6 @@ main = do
25 [ Just ()
29 [ Just ()
26 ]
30 ]
27 print os1
31 print os1
28− let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
29 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
32 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
30 [ This ()
33 [ This ()
31 , That ()
34 , That ()
@@ -33,7 +36,20 @@ main = do
33 , These () ()
36 , These () ()
34 ]
37 ]
35 print os2
38 print os2
39+ os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]
40+ print os3
41+ os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]
42+ print os4
43+ os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]
44+ print os5
45+ os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
46+ print os6
47+ let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
36 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
48 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
49+ let ![[Nothing, Just [2]]] = os3
50+ let ![[Nothing, Just [2]]] = os4
51+ let ![[Nothing, Just [1, 2]]] = os5
52+ let ![[Nothing, Nothing]] = os6
37 return ()
53 return ()
38
54
39unwrapRequest :: DSum tag RequestInt -> Int
55unwrapRequest :: DSum tag RequestInt -> Int
@@ -67,3 +83,87 @@ testSimultaneous pulse = do
67 switchE = fmapMaybe (^? there) pulse
83 switchE = fmapMaybe (^? there) pulse
68 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
84 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
69 requestingIdentity (RequestInt (i+1) <$ tellE)
85 requestingIdentity (RequestInt (i+1) <$ tellE)
86+
87+-- | Test that a widget requesting and event which fires at the same time it has been replaced
88+-- doesn't count along with the new widget.
89+testMoribundRequest
90+ :: forall t m
91+ . ( Reflex t
92+ , Adjustable t m
93+ , MonadHold t m
94+ , MonadFix m
95+ , Response m ~ Identity
96+ , Request m ~ RequestInt
97+ , Requester t m
98+ )
99+ => Event t ()
100+ -> m ()
101+testMoribundRequest pulse = do
102+ rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
103+ (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
104+ return ()
105+
106+-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
107+testMoribundRequestDMap
108+ :: forall t m
109+ . ( Reflex t
110+ , Adjustable t m
111+ , MonadHold t m
112+ , MonadFix m
113+ , Response m ~ Identity
114+ , Request m ~ RequestInt
115+ , Requester t m
116+ )
117+ => Event t ()
118+ -> m ()
119+testMoribundRequestDMap pulse = do
120+ rec let requestIntOnReplace :: Int -> m ()
121+ requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
122+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
123+ traverseDMapWithKeyWithAdjust
124+ (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
125+ (mapToDMap $ M.singleton () 1)
126+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
127+ return ()
128+
129+-- | Ensures that elements which are _not_ removed can still fire requests
130+-- during the same frame as other elements are updated.
131+testLiveRequestDMap
132+ :: forall t m
133+ . ( Reflex t
134+ , Adjustable t m
135+ , MonadHold t m
136+ , MonadFix m
137+ , Response m ~ Identity
138+ , Request m ~ RequestInt
139+ , Requester t m
140+ )
141+ => Event t ()
142+ -> m ()
143+testLiveRequestDMap pulse = do
144+ rec let requestIntOnReplace :: Int -> m ()
145+ requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
146+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
147+ traverseDMapWithKeyWithAdjust
148+ (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
149+ (mapToDMap $ M.singleton 1 ())
150+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
151+ return ()
152+
153+delayedPulse
154+ :: forall t m
155+ . ( Reflex t
156+ , Adjustable t m
157+ , MonadHold t m
158+ , MonadFix m
159+ , Response m ~ Identity
160+ , Request m ~ RequestInt
161+ , PerformEvent t m
162+ , Requester t m
163+ )
164+ => Event t ()
165+ -> m ()
166+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
167+ -- This has the effect of delaying pulse' from pulse
168+ (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
169+ requestingIdentity pulse'