@@ -27,6 +27,7 @@ import Data.Align
2727import Reflex
2828import Reflex.EventWriter.Base
2929import Test.Run
30+import Test.Hspec
3031import Reflex.Spider.Internal (EventLoopException)
3132import Data.Witherable (Filterable)
3233
@@ -36,7 +37,7 @@ import Data.These.Lens
3637
3738type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
3839
39−connectDyn ::Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
40+connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
4041connectDyn e (d, d') = do
4142 dd <- holdDyn d (d' <$ e)
4243 return $ join dd
@@ -85,8 +86,8 @@ connectButton click e = do
8586 d <- hold never (e <$ click)
8687 return (switch d)
8788
88−switchLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
89−switchLoop (e1, e2) = do
89+switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
90+switchLoop01 (e1, e2) = do
9091 rec
9192 e' <- connectButton e2 (updated d)
9293 d <- count (align e' e1)
@@ -103,76 +104,68 @@ mergeLoop (e1, e2) = do
103104 c <- count e1
104105 tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
105106
106−switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
107−switchLoop' (e1, e2) = do
107+switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
108+switchLoop02 (e1, e2) = do
108109 rec
109110 e' <- connectButton e2 (updated d)
110111 d <- count (leftmost [e', e1])
111112 return $ updated d
112113
113−switchLoop2 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
114−switchLoop2 (e1, e2) = do
114+switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
115+switchLoop03 (e1, e2) = do
115116 rec
116117 e' <- connectButton e2 (addHeight $ updated d)
117118 d <- count (align e' e1)
118119 return $ updated d
119120
120−staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
121−staticLoop (e1, e2) = do
121+staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
122+staticLoop01 (e1, e2) = do
122123 rec
123124 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
124125 return $ updated d
125126
126−staticLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
127−staticLoop' (e1, e2) = do
127+staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
128+staticLoop02 (e1, e2) = do
128129 rec
129130 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
130131 return $ updated d
131132
132133buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
133134buildStaticLoop (e1, e2) = switchHold never buildLoop
134− where buildLoop = pushAlways (const $ staticLoop (e1, e2)) e2
135+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2
135136
136137splitThese :: Filterable f => f (These a b) -> (f a, f b)
137138splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
138139
139−pattern RunTestCaseFlag = "--run-test"
140−
141−runTest :: (String, TestCase) -> IO ()
142−runTest (name, TestCase test) = do
143− putStrLn ("Test: " <> name)
144− mError <- timeout (milliseconds 5) $
145− run `catch` \(e :: EventLoopException) -> pure (show e)
146− case mError of
147− Just err -> putStrLn err
148− Nothing -> error "timed out (loop not detected)"
149− where
150− run = do
151− r <- runApp' (test . splitThese) (Just <$> occs)
152− error (name <> ": unexpected success " <> show r)
153− occs = [ This 1, This 2, That (), This 3, That (), This 1 ]
154− milliseconds = (*1000)
155−
156−newtype TestCase = TestCase { unTest :: forall t m. (Widget t m, Adjustable t m) => (Event t Int, Event t ()) -> m (Event t Int) }
157−
158−tests :: [(String, TestCase)]
159−tests =
160− [ ("switchLoop'", TestCase switchLoop')
161− , ("switchLoop", TestCase switchLoop)
162− , ("mergeLoop", TestCase mergeLoop)
163−
164−
165− -- , ("switchLoop2", TestCase switchLoop2)
166−
167− -- , ("staticLoop'", TestCase staticLoop')
168− -- , ("staticLoop", TestCase staticLoop)
169− -- ("buildStaticLoop", TestCase buildStaticLoop)
170− -- , ("buildSwitchLoop", TestCase $ buildLoop switchLoop)
171−
172− -- ("coincidenceLoop", TestCase coincidenceLoop)
173− -- , ("dynLoop", TestCase dynLoop)
174− -- , ("buildCoincidenceLoop", TestCase $ buildLoop coincidenceLoop)
175− ]
176−
177140main :: IO ()
178−main = traverse_ runTest tests
141+main = 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)