git.iko.soy/reflex
on test-ci help sign in
reflex/test/RequesterT.hs
174 lines 5.6 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8module Main where
10import Control.Lens
11import Control.Monad
12import Control.Monad.Fix
13import qualified Data.Dependent.Map as DMap
14import Data.Dependent.Sum
15import Data.Functor.Misc
16import qualified Data.Map as M
17import Data.These
19#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
20import Data.These.Lens
21#endif
23import Reflex
24import Reflex.Requester.Base
25import Reflex.Requester.Class
26import Test.Run
28data RequestInt a where
29 RequestInt :: Int -> RequestInt Int
31main :: IO ()
32main = do
33 os1 <- runApp' (unwrapApp testOrdering) $
34 [ Just ()
35 ]
36 print os1
37 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
38 [ This ()
39 , That ()
40 , This ()
41 , These () ()
42 ]
43 print os2
44 os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]
45 print os3
46 os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]
47 print os4
48 os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]
49 print os5
50 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
51 print os6
52 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
53 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
54 let ![[Nothing, Just [2]]] = os3
55 let ![[Nothing, Just [2]]] = os4
56 let ![[Nothing, Just [1, 2]]] = os5
57 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved
58 return ()
60unwrapRequest :: DSum tag RequestInt -> Int
61unwrapRequest (_ :=> RequestInt i) = i
63unwrapApp :: ( Reflex t, Monad m )
64 => (a -> RequesterT t RequestInt Identity m ())
65 -> a
66 -> m (Event t [Int])
67unwrapApp x appIn = do
68 ((), e) <- runRequesterT (x appIn) never
69 return $ fmap (map unwrapRequest . requesterDataToList) e
71testOrdering :: ( Response m ~ Identity
72 , Request m ~ RequestInt
73 , Requester t m
74 , Adjustable t m)
75 => Event t ()
76 -> m ()
77testOrdering pulse = forM_ [10,9..1] $ \i ->
78 requestingIdentity (RequestInt i <$ pulse)
80testSimultaneous :: ( Response m ~ Identity
81 , Request m ~ RequestInt
82 , Requester t m
83 , Adjustable t m)
84 => Event t (These () ())
85 -> m ()
86testSimultaneous pulse = do
87 let tellE = fmapMaybe (^? here) pulse
88 switchE = fmapMaybe (^? there) pulse
89 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
90 requestingIdentity (RequestInt (i+1) <$ tellE)
92-- | Test that a widget requesting and event which fires at the same time it has been replaced
93-- doesn't count along with the new widget.
94testMoribundRequest
95 :: forall t m
96 . ( Reflex t
97 , Adjustable t m
98 , MonadHold t m
99 , MonadFix m
100 , Response m ~ Identity
101 , Request m ~ RequestInt
102 , Requester t m
103 )
104 => Event t ()
105 -> m ()
106testMoribundRequest pulse = do
107 rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
108 (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
109 return ()
111-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
112testMoribundRequestDMap
113 :: forall t m
114 . ( Reflex t
115 , Adjustable t m
116 , MonadHold t m
117 , MonadFix m
118 , Response m ~ Identity
119 , Request m ~ RequestInt
120 , Requester t m
121 )
122 => Event t ()
123 -> m ()
124testMoribundRequestDMap pulse = do
125 rec let requestIntOnReplace :: Int -> m ()
126 requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
127 (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
128 traverseDMapWithKeyWithAdjust
129 (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
130 (mapToDMap $ M.singleton () 1)
131 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
132 return ()
134-- | Ensures that elements which are _not_ removed can still fire requests
135-- during the same frame as other elements are updated.
136testLiveRequestDMap
137 :: forall t m
138 . ( Reflex t
139 , Adjustable t m
140 , MonadHold t m
141 , MonadFix m
142 , Response m ~ Identity
143 , Request m ~ RequestInt
144 , Requester t m
145 )
146 => Event t ()
147 -> m ()
148testLiveRequestDMap pulse = do
149 rec let requestIntOnReplace :: Int -> m ()
150 requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
151 (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
152 traverseDMapWithKeyWithAdjust
153 (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
154 (mapToDMap $ M.singleton 1 ())
155 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
156 return ()
158delayedPulse
159 :: forall t m
160 . ( Reflex t
161 , Adjustable t m
162 , MonadHold t m
163 , MonadFix m
164 , Response m ~ Identity
165 , Request m ~ RequestInt
166 , PerformEvent t m
167 , Requester t m
168 )
169 => Event t ()
170 -> m ()
171delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
172 -- This has the effect of delaying pulse' from pulse
173 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
174 requestingIdentity pulse'