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