git.iko.soy/reflex
on ghc810 help sign in
reflex/test/RequesterT.hs
235 lines 7.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
13module Main where
15import Control.Lens hiding (has)
16import Control.Monad
17import Control.Monad.Fix
18import Control.Monad.IO.Class (MonadIO)
19import Data.Constraint.Extras
20import Data.Constraint.Extras.TH
21import Data.Constraint.Forall
22import qualified Data.Dependent.Map as DMap
23import Data.Dependent.Sum
24import Data.Functor.Misc
25import Data.List (words)
26import Data.Map (Map)
27import qualified Data.Map as M
28#if !MIN_VERSION_these(4,11,0)
29import Data.Semigroup ((<>))
30#endif
31import Data.Text (Text)
32import Data.These
33import Text.Read (readMaybe)
35#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
36import Data.These.Lens
37#endif
39import Reflex
40import Reflex.Requester.Base
41import Reflex.Requester.Class
42import Test.Run
44data RequestInt a where
45 RequestInt :: Int -> RequestInt Int
47main :: IO ()
48main = do
49 os1 <- runApp' (unwrapApp testOrdering) $
50 [ Just ()
51 ]
52 print os1
53 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
54 [ This ()
55 , That ()
56 , This ()
57 , These () ()
58 ]
59 print os2
60 os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]
61 print os3
62 os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]
63 print os4
64 os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]
65 print os5
66 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
67 print os6
68 os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]
69 print os7
70 os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]
71 print os8
72 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
73 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
74 let ![[Nothing, Just [2]]] = os3
75 let ![[Nothing, Just [2]]] = os4
76 let ![[Nothing, Just [1, 2]]] = os5
77 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved
78 let !(Just [(1,"2")]) = M.toList <$> head (head os7)
79 let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)
81 return ()
83unwrapRequest :: DSum tag RequestInt -> Int
84unwrapRequest (_ :=> RequestInt i) = i
86unwrapApp :: ( Reflex t, Monad m )
87 => (a -> RequesterT t RequestInt Identity m ())
88 -> a
89 -> m (Event t [Int])
90unwrapApp x appIn = do
91 ((), e) <- runRequesterT (x appIn) never
92 return $ fmap (map unwrapRequest . requesterDataToList) e
94testOrdering :: ( Response m ~ Identity
95 , Request m ~ RequestInt
96 , Requester t m
97 , Adjustable t m)
98 => Event t ()
99 -> m ()
100testOrdering pulse = forM_ [10,9..1] $ \i ->
101 requestingIdentity (RequestInt i <$ pulse)
103testSimultaneous :: ( Response m ~ Identity
104 , Request m ~ RequestInt
105 , Requester t m
106 , Adjustable t m)
107 => Event t (These () ())
108 -> m ()
109testSimultaneous pulse = do
110 let tellE = fmapMaybe (^? here) pulse
111 switchE = fmapMaybe (^? there) pulse
112 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
113 requestingIdentity (RequestInt (i+1) <$ tellE)
115-- | Test that a widget requesting and event which fires at the same time it has been replaced
116-- doesn't count along with the new widget.
117testMoribundRequest
118 :: forall t m
119 . ( Reflex t
120 , Adjustable t m
121 , MonadHold t m
122 , MonadFix m
123 , Response m ~ Identity
124 , Request m ~ RequestInt
125 , Requester t m
126 )
127 => Event t ()
128 -> m ()
129testMoribundRequest pulse = do
130 rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
131 (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
132 return ()
134-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
135testMoribundRequestDMap
136 :: forall t m
137 . ( Reflex t
138 , Adjustable t m
139 , MonadHold t m
140 , MonadFix m
141 , Response m ~ Identity
142 , Request m ~ RequestInt
143 , Requester t m
144 )
145 => Event t ()
146 -> m ()
147testMoribundRequestDMap pulse = do
148 rec let requestIntOnReplace :: Int -> m ()
149 requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
150 (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
151 traverseDMapWithKeyWithAdjust
152 (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
153 (mapToDMap $ M.singleton () 1)
154 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
155 return ()
157-- | Ensures that elements which are _not_ removed can still fire requests
158-- during the same frame as other elements are updated.
159testLiveRequestDMap
160 :: forall t m
161 . ( Reflex t
162 , Adjustable t m
163 , MonadHold t m
164 , MonadFix m
165 , Response m ~ Identity
166 , Request m ~ RequestInt
167 , Requester t m
168 )
169 => Event t ()
170 -> m ()
171testLiveRequestDMap pulse = do
172 rec let requestIntOnReplace :: Int -> m ()
173 requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
174 (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
175 traverseDMapWithKeyWithAdjust
176 (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
177 (mapToDMap $ M.singleton 1 ())
178 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
179 return ()
181delayedPulse
182 :: forall t m
183 . ( Reflex t
184 , Adjustable t m
185 , MonadHold t m
186 , MonadFix m
187 , Response m ~ Identity
188 , Request m ~ RequestInt
189 , PerformEvent t m
190 , Requester t m
191 )
192 => Event t ()
193 -> m ()
194delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
195 -- This has the effect of delaying pulse' from pulse
196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
197 requestingIdentity pulse'
199data TestRequest a where
200 TestRequest_Reverse :: String -> TestRequest String
201 TestRequest_Increment :: Int -> TestRequest Int
203testMatchRequestsWithResponses
204 :: forall m t req a
205 . ( MonadFix m
206 , MonadHold t m
207 , Reflex t
208 , PerformEvent t m
209 , MonadIO (Performable m)
210 , ForallF Show req
211 , Has Read req
212 )
213 => Event t (req a) -> m (Event t (Map Int String))
214testMatchRequestsWithResponses pulse = mdo
215 (_, requests) <- runRequesterT (requesting pulse) responses
216 let rawResponses = M.map (\v ->
217 case words v of
218 ["reverse", str] -> reverse str
219 ["increment", i] -> show $ succ $ (read i :: Int)
220 ) <$> rawRequestMap
221 (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)
222 pure rawResponses
223 where
224 reqEncoder :: forall a. req a -> (String, String -> Maybe a)
225 reqEncoder r =
226 ( whichever @Show @req @a $ show r
227 , \x -> has @Read r $ readMaybe x
228 )
230deriveArgDict ''TestRequest
232instance Show (TestRequest a) where
233 show = \case
234 TestRequest_Reverse str -> "reverse " <> str
235 TestRequest_Increment i -> "increment " <> show i