git.iko.soy/reflex
on aa-switchable help sign in
reflex/test/RequesterT.hs
169 lines 5.4 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7module Main where
9import Control.Lens
10import Control.Monad
11import Control.Monad.Fix
12import qualified Data.Dependent.Map as DMap
13import Data.Dependent.Sum
14import Data.Functor.Misc
15import qualified Data.Map as M
16import Data.These
18import Reflex
19import Reflex.Requester.Base
20import Reflex.Requester.Class
21import Test.Run
23data RequestInt a where
24 RequestInt :: Int -> RequestInt Int
26main :: IO ()
27main = do
28 os1 <- runApp' (unwrapApp testOrdering) $
29 [ Just ()
30 ]
31 print os1
32 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
33 [ This ()
34 , That ()
35 , This ()
36 , These () ()
37 ]
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 [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
48 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],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 -- TODO re-enable this test after issue #233 has been resolved
53 return ()
55unwrapRequest :: DSum tag RequestInt -> Int
56unwrapRequest (_ :=> RequestInt i) = i
58unwrapApp :: ( Reflex t, Monad m )
59 => (a -> RequesterT t RequestInt Identity m ())
60 -> a
61 -> m (Event t [Int])
62unwrapApp x appIn = do
63 ((), e) <- runRequesterT (x appIn) never
64 return $ fmap (map unwrapRequest . requesterDataToList) e
66testOrdering :: ( Response m ~ Identity
67 , Request m ~ RequestInt
68 , Requester t m
69 , Adjustable t m)
70 => Event t ()
71 -> m ()
72testOrdering pulse = forM_ [10,9..1] $ \i ->
73 requestingIdentity (RequestInt i <$ pulse)
75testSimultaneous :: ( Response m ~ Identity
76 , Request m ~ RequestInt
77 , Requester t m
78 , Adjustable t m)
79 => Event t (These () ())
80 -> m ()
81testSimultaneous pulse = do
82 let tellE = fmapMaybe (^? here) pulse
83 switchE = fmapMaybe (^? there) pulse
84 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
85 requestingIdentity (RequestInt (i+1) <$ tellE)
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.
89testMoribundRequest
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 ()
101testMoribundRequest pulse = do
102 rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
103 (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
104 return ()
106-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
107testMoribundRequestDMap
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 ()
119testMoribundRequestDMap 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 ()
129-- | Ensures that elements which are _not_ removed can still fire requests
130-- during the same frame as other elements are updated.
131testLiveRequestDMap
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 ()
143testLiveRequestDMap 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 ()
153delayedPulse
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 ()
166delayedPulse 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'