git.iko.soy/patch
on develop help sign in
Add EventWriterT moribund tests to RequesterT tests
6331936Tom Smalley
test/RequesterT.hs+80−1
compare with develop
unifiedsplit
@@ -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,17 @@ 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+ 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
46 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
47+ let ![[Nothing, Just [2]]] = os3
48+ let ![[Nothing, Just [2]]] = os4
49+ let ![[Nothing, Just [1, 2]]] = os5
37 return ()
50 return ()
38
51
39unwrapRequest :: DSum tag RequestInt -> Int
52unwrapRequest :: DSum tag RequestInt -> Int
@@ -67,3 +80,69 @@ testSimultaneous pulse = do
67 switchE = fmapMaybe (^? there) pulse
80 switchE = fmapMaybe (^? there) pulse
68 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
81 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
69 requestingIdentity (RequestInt (i+1) <$ tellE)
82 requestingIdentity (RequestInt (i+1) <$ tellE)
83+
84+-- | Test that a widget requesting and event which fires at the same time it has been replaced
85+-- doesn't count along with the new widget.
86+testMoribundRequest
87+ :: forall t m
88+ . ( Reflex t
89+ , Adjustable t m
90+ , MonadHold t m
91+ , MonadFix m
92+ , Response m ~ Identity
93+ , Request m ~ RequestInt
94+ , Requester t m
95+ )
96+ => Event t ()
97+ -> m ()
98+testMoribundRequest pulse = do
99+ rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
100+ (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
101+ return ()
102+
103+-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
104+testMoribundRequestDMap
105+ :: forall t m
106+ . ( Reflex t
107+ , Adjustable t m
108+ , MonadHold t m
109+ , MonadFix m
110+ , Response m ~ Identity
111+ , Request m ~ RequestInt
112+ , Requester t m
113+ )
114+ => Event t ()
115+ -> m ()
116+testMoribundRequestDMap pulse = do
117+ rec let requestIntOnReplace :: Int -> m ()
118+ requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
119+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
120+ traverseDMapWithKeyWithAdjust
121+ (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
122+ (mapToDMap $ M.singleton () 1)
123+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
124+ return ()
125+
126+-- | Ensures that elements which are _not_ removed can still fire requests
127+-- during the same frame as other elements are updated.
128+testLiveRequestDMap
129+ :: forall t m
130+ . ( Reflex t
131+ , Adjustable t m
132+ , MonadHold t m
133+ , MonadFix m
134+ , Response m ~ Identity
135+ , Request m ~ RequestInt
136+ , Requester t m
137+ )
138+ => Event t ()
139+ -> m ()
140+testLiveRequestDMap pulse = do
141+ rec let requestIntOnReplace :: Int -> m ()
142+ requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
143+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
144+ traverseDMapWithKeyWithAdjust
145+ (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
146+ (mapToDMap $ M.singleton 1 ())
147+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
148+ return ()