git.iko.soy/reflex
on develop help sign in
Add test set, add cycle check to mergeInt
9e1864fOliver Batchelor
reflex.cabal+3
compare with develop
unifiedsplit
@@ -271,6 +271,7 @@ test-suite DebugCycles
271 type: exitcode-stdio-1.0
271 type: exitcode-stdio-1.0
272 main-is: DebugCycles.hs
272 main-is: DebugCycles.hs
273 hs-source-dirs: test
273 hs-source-dirs: test
274+ ghc-options: -threaded
274 build-depends: base
275 build-depends: base
275 , containers
276 , containers
276 , deepseq
277 , deepseq
@@ -283,6 +284,8 @@ test-suite DebugCycles
283 , reflex
284 , reflex
284 , ref-tf
285 , ref-tf
285 , witherable
286 , witherable
287+ , proctest
288+
286
289
287 if flag(split-these)
290 if flag(split-these)
288 build-depends: these-lens, semialign
291 build-depends: these-lens, semialign
src/Reflex/Spider/Internal.hs+33−29
@@ -101,17 +101,18 @@ import Reflex.NotReady.Class
101import Reflex.Patch
101import Reflex.Patch
102import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
102import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
103
103
104+
105+
104#ifdef DEBUG_TRACE_EVENTS
106#ifdef DEBUG_TRACE_EVENTS
105import qualified Data.ByteString.Char8 as BS8
107import qualified Data.ByteString.Char8 as BS8
106import System.IO (stderr)
108import System.IO (stderr)
107−#endif
109+import Data.List (isPrefixOf)
108−
109−#ifdef DEBUG_TRACE_EVENTS
110
110
111withStackOneLine :: (BS8.ByteString -> a) -> a
111withStackOneLine :: (BS8.ByteString -> a) -> a
112withStackOneLine expr = unsafePerformIO $ do
112withStackOneLine expr = unsafePerformIO $ do
113 stack <- currentCallStack
113 stack <- currentCallStack
114− return (expr (BS8.pack (unwords (reverse stack))))
114+ return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
115+ where dropInternal = filter (not . isPrefixOf "Reflex.Spider.Internal")
115
116
116#endif
117#endif
117
118
@@ -277,13 +278,11 @@ cacheEvent e =
277 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
278 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
278 (parentSub, occ) <- subscribeAndRead e $ Subscriber
279 (parentSub, occ) <- subscribeAndRead e $ Subscriber
279 { subscriberPropagate = \a -> do
280 { subscriberPropagate = \a -> do
280− liftIO $ writeIORef occRef $ Just a
281+ liftIO $ writeIORef occRef (Just a)
281 scheduleClear occRef
282 scheduleClear occRef
282 propagateFast a subscribers
283 propagateFast a subscribers
283− , subscriberInvalidateHeight = \old -> do
284− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
284+ , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight
285− , subscriberRecalculateHeight = \new -> do
286− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
285+ , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight
287 }
286 }
288 when (isJust occ) $ do
287 when (isJust occ) $ do
289 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
288 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
@@ -466,14 +465,14 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
466recalculateSubscriberHeight = flip subscriberRecalculateHeight
465recalculateSubscriberHeight = flip subscriberRecalculateHeight
467
466
468-- | Propagate everything at the current height
467-- | Propagate everything at the current height
469−propagate :: forall a x. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
468+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
470propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
469propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
471 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
470 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
472 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
471 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
473 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
472 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
474
473
475-- | Propagate everything at the current height
474-- | Propagate everything at the current height
476−propagateFast :: forall a x. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
475+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
477propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
476propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do
478 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
477 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
479 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
478 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
@@ -1297,7 +1296,7 @@ traceM _ getMessage = do
1297#else
1296#else
1298
1297
1299{-# INLINE withIncreasedDepth #-}
1298{-# INLINE withIncreasedDepth #-}
1300−withIncreasedDepth :: forall x m proxy a. HasSpiderTimeline x => proxy x -> m a -> m a
1299+withIncreasedDepth :: proxy x -> m a -> m a
1301withIncreasedDepth _ = id
1300withIncreasedDepth _ = id
1302
1301
1303{-# INLINE tracePropagate #-}
1302{-# INLINE tracePropagate #-}
@@ -1309,7 +1308,7 @@ traceInvalidate :: String -> IO ()
1309traceInvalidate _ = return ()
1308traceInvalidate _ = return ()
1310
1309
1311{-# INLINE debugSubscriber #-}
1310{-# INLINE debugSubscriber #-}
1312−debugSubscriber :: HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1311+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1313debugSubscriber _ = return
1312debugSubscriber _ = return
1314
1313
1315{-# INLINE trace #-}
1314{-# INLINE trace #-}
@@ -1861,6 +1860,23 @@ scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1861 --TODO: Assert that m is not empty
1860 --TODO: Assert that m is not empty
1862 subscriberPropagate (_merge_sub m) vals
1861 subscriberPropagate (_merge_sub m) vals
1863
1862
1863+checkCycle :: HasSpiderTimeline x => Height -> EventM x ()
1864+checkCycle height = do
1865+ currentHeight <- getCurrentHeight
1866+ when (height <= currentHeight) $ if height /= invalidHeight
1867+ then do
1868+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1869+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1870+ else liftIO $ do
1871+#ifdef DEBUG_CYCLES
1872+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1873+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1874+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1875+#else
1876+ let cycleInfo = ""
1877+#endif
1878+ error $ "Causality loop found" <> cycleInfo
1879+
1864mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1880mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1865mergeSubscriber m getKey = Subscriber
1881mergeSubscriber m getKey = Subscriber
1866 { subscriberPropagate = \a -> do
1882 { subscriberPropagate = \a -> do
@@ -1871,22 +1887,8 @@ mergeSubscriber m getKey = Subscriber
1871 liftIO $ writeIORef (_merge_accumRef m) $! newM
1887 liftIO $ writeIORef (_merge_accumRef m) $! newM
1872 when (DMap.null oldM) $ do -- Only schedule the firing once
1888 when (DMap.null oldM) $ do -- Only schedule the firing once
1873 height <- liftIO $ readIORef $ _merge_heightRef m
1889 height <- liftIO $ readIORef $ _merge_heightRef m
1874− --TODO: assertions about height
1890+ checkCycle height --TODO: assertions about height
1875− currentHeight <- getCurrentHeight
1891+
1876− when (height <= currentHeight) $ do
1877− if height /= invalidHeight
1878− then do
1879− myStack <- liftIO $ whoCreatedIORef undefined --TODO
1880− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1881− else liftIO $ do
1882−#ifdef DEBUG_CYCLES
1883− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1884− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1885− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1886−#else
1887− let cycleInfo = ""
1888−#endif
1889− error $ "Causality loop found" <> cycleInfo
1890 scheduleMergeSelf m height
1892 scheduleMergeSelf m height
1891 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1893 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1892 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1894 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
@@ -1989,6 +1991,8 @@ mergeIntCheap d = Event $ \sub -> do
1989 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1991 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1990 mySubscriber k = Subscriber
1992 mySubscriber k = Subscriber
1991 { subscriberPropagate = \a -> do
1993 { subscriberPropagate = \a -> do
1994+ liftIO (readIORef heightRef) >>= checkCycle
1995+
1992 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1996 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1993 liftIO $ FastMutableIntMap.insert accum k a
1997 liftIO $ FastMutableIntMap.insert accum k a
1994 when wasEmpty scheduleSelf
1998 when wasEmpty scheduleSelf
test/DebugCycles.hs+76−24
@@ -1,89 +1,141 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE PatternSynonyms #-}
8+{-# LANGUAGE RankNTypes #-}
9+
7module Main where
10module Main where
8
11
12+import Data.Foldable
9import Control.Lens
13import Control.Lens
10import Control.Applicative
14import Control.Applicative
11import Control.Monad
15import Control.Monad
12import Control.Monad.Fix
16import Control.Monad.Fix
17+import Control.Exception
18+
19+import System.Timeout
20+
13import Data.Functor.Misc
21import Data.Functor.Misc
14−import qualified Data.Map as M
22+import qualified Data.Map as Map
23+import Data.Map (Map)
24+
15import Data.These
25import Data.These
16import Data.Align
26import Data.Align
17
27
18−
19import Reflex
28import Reflex
20import Reflex.EventWriter.Base
29import Reflex.EventWriter.Base
21import Test.Run
30import Test.Run
22
31
32+
23import Data.Witherable (Filterable)
33import Data.Witherable (Filterable)
24
34
25#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
35#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
26import Data.These.Lens
36import Data.These.Lens
27#endif
37#endif
28
38
39+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
29
40
30−connectDyn :: (MonadHold t m, Reflex t, MonadFix m) => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
41+connectDyn ::Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
31connectDyn e (d, d') = do
42connectDyn e (d, d') = do
32 dd <- holdDyn d (d' <$ e)
43 dd <- holdDyn d (d' <$ e)
33 return $ join dd
44 return $ join dd
34
45
35
46
36−dynLoop :: (MonadHold t m, Reflex t, MonadFix m) => (Event t Int, Event t ()) -> m (Event t Int)
47+dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
37dynLoop (e1, e2) = do
48dynLoop (e1, e2) = do
38 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
49 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
39 rec
50 rec
40 d <- count e1
51 d <- count e1
41− d' <- connectDyn e2 (d, (liftA2 (+) d d'))
52+ d' <- connectDyn e2 (d, liftA2 (+) d d')
42 return $ updated d'
53 return $ updated d'
43
54
44
55
45−connectButtonPromptly :: (MonadHold t m, Reflex t, MonadFix m) => Event t () -> Event t a -> m (Event t a)
56+connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
46connectButtonPromptly click e = do
57connectButtonPromptly click e = do
47 d <- holdDyn never (e <$ click)
58 d <- holdDyn never (e <$ click)
48 return (switchDyn d)
59 return (switchDyn d)
49
60
50−connectButton :: (MonadHold t m, Reflex t, MonadFix m) => Event t () -> Event t a -> m (Event t a)
61+connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)
51connectButton click e = do
62connectButton click e = do
52 d <- hold never (e <$ click)
63 d <- hold never (e <$ click)
53 return (switch d)
64 return (switch d)
54
65
55
66
56−switchLoop :: (MonadHold t m, Reflex t, MonadFix m) => (Event t Int, Event t ()) -> m (Event t Int)
67+switchLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
57switchLoop (e1, e2) = do
68switchLoop (e1, e2) = do
58 rec
69 rec
59 e' <- connectButton e2 (updated d)
70 e' <- connectButton e2 (updated d)
60 d <- count (align e' e1)
71 d <- count (align e' e1)
61−
62 return $ updated d
72 return $ updated d
63
73
64−staticLoop :: AppWidget t m => m ()
74+switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
65−staticLoop = do
75+switchLoop' (e1, e2) = do
66− el "p" $ do
76+ rec
67− text "Typical error: GHC stack-space overflow: current limit is 33624 bytes"
77+ e' <- connectButton e2 (updated d)
68− text "(or consumes all available memory)"
78+ d <- count (leftmost [e', e1])
79+ return $ updated d
69
80
70− e <- getPostBuild
81+staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
82+staticLoop (e1, e2) = do
71 rec
83 rec
84+ d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
85+ return $ updated d
86+
87+staticLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
88+staticLoop' (e1, e2) = do
89+ rec
72− d <- foldDyn (+) (0 :: Int) (leftmost [1 <$ e, updated d])
90+ d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
73− dynText (T.pack . show <$> d)
91+ return $ updated d
74−
75
92
76
93
94+buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
95+buildStaticLoop (e1, e2) = switchHold never buildLoop
96+ where buildLoop = pushAlways (const $ staticLoop (e1, e2)) e2
97+
77splitThese :: Filterable f => f (These a b) -> (f a, f b)
98splitThese :: Filterable f => f (These a b) -> (f a, f b)
78splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
99splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
79
100
101+pattern RunTestCaseFlag = "--run-test"
102+
103+runTest :: (String, TestCase) -> IO ()
104+runTest (name, TestCase test) = do
105+ mError <- timeout (milliseconds 5) $
106+ run `catch` \(ErrorCall e) -> pure e
107+
108+ case mError of
109+ Nothing -> error $ name <> ": timed out (loop not detected)"
110+ Just msg -> unless (msg == "Causality loop found") $
111+ error $ "loop not detected: " <> msg
112+
113+ where
114+
115+ run = runApp' (test . splitThese) (Just <$> occs) >> pure "unexpected success"
116+ occs = [ This 1, This 2, That (), This 3 ]
117+
118+ milliseconds = (*1000)
119+
120+
121+newtype TestCase = TestCase { unTest :: forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int) }
122+
123+tests :: [(String, TestCase)]
124+tests =
125+ [
126+ -- ("switchLoop'", TestCase switchLoop')
127+ -- , ("switchLoop", TestCase switchLoop)
128+ -- ("staticLoop'", TestCase staticLoop')
129+ -- ("staticLoop", TestCase staticLoop)
130+ ("buildStaticLoop", TestCase buildStaticLoop)
131+ -- , ("dynLoop", TestCase dynLoop)
132+ ]
133+
80main :: IO ()
134main :: IO ()
81−main = void $ do
135+main = traverse_ runTest tests
82
136
83− runApp' (switchLoop . splitThese) (Just <$> occs)
84− runApp' (dynLoop . splitThese) (Just <$> occs)
85
137
86− where
138+
87− occs = [ This 1, This 2, That (), This 3 ]
139+
88
140
89
141