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