git.iko.soy/reflex
on bump-version help sign in
reflex/test/DebugCycles.hs
171 lines 5.8 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE RankNTypes #-}
10module Main where
12import Data.Foldable
13import Control.Lens
14import Control.Applicative
15import Control.Monad
16import Control.Monad.Fix
17import Control.Exception
18import System.Timeout
19import Data.Maybe (isJust)
20import Data.Functor.Misc
21import qualified Data.Map as Map
22import Data.Map (Map)
23import qualified Data.IntMap as IntMap
24import Data.IntMap (IntMap)
25import Data.These
26import Data.Align
27import Reflex
28import Reflex.EventWriter.Base
29import Test.Run
30import Test.Hspec
31import Reflex.Spider.Internal (EventLoopException)
32import Data.Witherable (Filterable)
34#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
35import Data.These.Lens
36#endif
38type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
40connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
41connectDyn e (d, d') = do
42 dd <- holdDyn d (d' <$ e)
43 return $ join dd
45dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
46dynLoop (e1, e2) = do
47 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
48 rec
49 d <- count e1
50 d' <- connectDyn e2 (d, liftA2 (+) d d')
51 return $ updated d'
53connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)
54connectOnCoincidence click e = do
55 d <- holdDyn never (e <$ click)
56 return $ coincidence (updated d)
58coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
59coincidenceLoop (e1, e2) = do
60-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"
61-- (simpler version of dynLoop)
62 rec
63 e' <- connectOnCoincidence e2 (updated d)
64 d <- count (align e' e1)
65 return $ updated d
67addHeight :: Reflex t => Event t a -> Event t a
68addHeight e = leftmost [e4, e4] where
69 e1 = leftmost [e, e]
70 e2 = leftmost [e1, e1]
71 e3 = leftmost [e2, e2]
72 e4 = leftmost [e3, e3]
74-- Take an existing test and build it inside a
75buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)
76buildLoop test (e1, e2) = switchHold never buildLoop
77 where buildLoop = pushAlways (const $ test (e1, e2)) e2
79connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
80connectButtonPromptly click e = do
81 d <- holdDyn never (e <$ click)
82 return (switchDyn d)
84connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)
85connectButton click e = do
86 d <- hold never (e <$ click)
87 return (switch d)
89switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
90switchLoop01 (e1, e2) = do
91 rec
92 e' <- connectButton e2 (updated d)
93 d <- count (align e' e1)
94 return $ updated d
96mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)
97mergeLoop (e1, e2) = do
98 rec
99 (_, e) <- runEventWriterT $
100 runWithReplace w (leftmost [w <$ e1])
101 return (sum <$> e)
102 where
103 w = do
104 c <- count e1
105 tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
107switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
108switchLoop02 (e1, e2) = do
109 rec
110 e' <- connectButton e2 (updated d)
111 d <- count (leftmost [e', e1])
112 return $ updated d
114switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
115switchLoop03 (e1, e2) = do
116 rec
117 e' <- connectButton e2 (addHeight $ updated d)
118 d <- count (align e' e1)
119 return $ updated d
121staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
122staticLoop01 (e1, e2) = do
123 rec
124 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
125 return $ updated d
127staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
128staticLoop02 (e1, e2) = do
129 rec
130 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
131 return $ updated d
133buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
134buildStaticLoop (e1, e2) = switchHold never buildLoop
135 where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2
137splitThese :: Filterable f => f (These a b) -> (f a, f b)
138splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
140main :: IO ()
141main = hspec $ do
142 describe "DebugCycles" $ do
143 it "throws EventLoopException on switchLoop01" $ do
144 check switchLoop01
145 it "throws EventLoopException on switchLoop02" $ do
146 check switchLoop02
147 it "throws EventLoopException on switchLoop03" $ do
148 check switchLoop03
149 it "throws EventLoopException on buildSwitchLoop" $ do
150 check $ buildLoop switchLoop01
151 xit "throws EventLoopException on mergeLoop" $ do
152 check mergeLoop
153 xit "throws EventLoopException on staticLoop01" $ do
154 check staticLoop01
155 xit "throws EventLoopException on staticLoop02" $ do
156 check staticLoop02
157 xit "throws EventLoopException on buildStaticLoop" $ do
158 check buildStaticLoop
159 xit "throws EventLoopException on coincidenceLoop" $ do
160 check coincidenceLoop
161 xit "throws EventLoopException on dynLoop" $ do
162 check dynLoop
163 xit "throws EventLoopException on buildCoincidenceLoop" $ do
164 check $ buildLoop coincidenceLoop
165 where
166 milliseconds = (*1000)
167 occs = [ This 1, This 2, That (), This 3, That (), This 1 ]
168 check test = do
169 let action = timeout (milliseconds 50) $ do
170 runApp' (test . splitThese) (Just <$> occs)
171 action `shouldThrow` (const True :: Selector EventLoopException)