git.iko.soy/reflex
on aa-switchable help sign in
reflex/test/EventWriterT.hs
132 lines 4.4 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6module Main where
8import Control.Lens
9import Control.Monad
10import Control.Monad.Fix
11import qualified Data.Dependent.Map as DMap
12import Data.Functor.Misc
13import qualified Data.Map as M
14import Data.These
16import Reflex
17import Reflex.EventWriter.Base
18import Test.Run
20main :: IO ()
21main = do
22 os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
23 [ Just ()
24 ]
25 print os1
26 os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
27 <- runApp' (unwrapApp testSimultaneous) $ map Just $
28 [ This ()
29 , That ()
30 , This ()
31 , These () ()
32 ]
33 print os2
34 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
35 print os3
36 os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]
37 print os4
38 os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
39 print os5
40 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
41 print os6
42 let ![[Nothing, Nothing]] = os6
43 return ()
45unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
46unwrapApp x appIn = do
47 ((), e) <- runEventWriterT $ x appIn
48 return e
50testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
51testOrdering pulse = do
52 forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
53 return ()
55testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
56testSimultaneous pulse = do
57 let e0 = fmapMaybe (^? here) pulse
58 e1 = fmapMaybe (^? there) pulse
59 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
60 return ()
62-- | Test that a widget telling and event which fires at the same time it has been replaced
63-- doesn't count along with the new widget.
64testMoribundTellEvent
65 :: forall t m
66 . ( Reflex t
67 , Adjustable t m
68 , MonadHold t m
69 , MonadFix m
70 )
71 => Event t ()
72 -> EventWriterT t [Int] m ()
73testMoribundTellEvent pulse = do
74 rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
75 tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
76 (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse
77 return ()
79-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.
80testMoribundTellEventDMap
81 :: forall t m
82 . ( Reflex t
83 , Adjustable t m
84 , MonadHold t m
85 , MonadFix m
86 )
87 => Event t ()
88 -> EventWriterT t [Int] m ()
89testMoribundTellEventDMap pulse = do
90 rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
91 tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
92 (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
93 traverseDMapWithKeyWithAdjust
94 (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)
95 (mapToDMap $ M.singleton () 1)
96 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
97 return ()
99-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's
100-- during the same frame as other elements are updated.
101testLiveTellEventDMap
102 :: forall t m
103 . ( Reflex t
104 , Adjustable t m
105 , MonadHold t m
106 , MonadFix m
107 )
108 => Event t ()
109 -> EventWriterT t [Int] m ()
110testLiveTellEventDMap pulse = do
111 rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
112 tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
113 (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
114 traverseDMapWithKeyWithAdjust
115 (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)
116 (mapToDMap $ M.singleton 1 ())
117 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
118 return ()
120delayedPulse
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 ()
129delayedPulse 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'