git.iko.soy/reflex
on develop help sign in
Add exception type for cycles
1d1c2d1Oliver Batchelor
src/Reflex/Spider/Internal.hs+21−7
compare with develop
unifiedsplit
@@ -101,8 +101,6 @@ 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−
106#ifdef DEBUG_TRACE_EVENTS
104#ifdef DEBUG_TRACE_EVENTS
107import qualified Data.ByteString.Char8 as BS8
105import qualified Data.ByteString.Char8 as BS8
108import System.IO (stderr)
106import System.IO (stderr)
@@ -1322,12 +1320,17 @@ traceM _ _ = return ()
1322#endif
1320#endif
1323
1321
1324
1322
1325−
1326−
1327whoCreatedIORef :: IORef a -> IO [String]
1323whoCreatedIORef :: IORef a -> IO [String]
1328whoCreatedIORef (IORef a) = whoCreated $! a
1324whoCreatedIORef (IORef a) = whoCreated $! a
1329
1325
1330#ifdef DEBUG_CYCLES
1326#ifdef DEBUG_CYCLES
1327+
1328+data EventLoopException = EventLoopException (Forest String)
1329+instance Exception EventLoopException
1330+
1331+instance Show EventLoopException where
1332+ show (EventLoopException stacks) = "Causality loop detected:\n" <> drawForest stacks
1333+
1331groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1334groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1332groupByHead = \case
1335groupByHead = \case
1333 [] -> []
1336 [] -> []
@@ -1339,8 +1342,19 @@ groupByHead = \case
1339
1342
1340listsToForest :: Eq a => [[a]] -> Forest a
1343listsToForest :: Eq a => [[a]] -> Forest a
1341listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1344listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1345+
1346+#else
1347+
1348+data EventLoopException = EventLoopException
1349+instance Exception EventLoopException
1350+
1351+instance Show EventLoopException where
1352+ show EventLoopException = "Causality loop detected: \n" <>
1353+ "no location information, compile with --enable-profiling and reflex with flag 'debug-cycles'"
1354+
1342#endif
1355#endif
1343
1356
1357+
1344{-# INLINE propagateSubscriberHold #-}
1358{-# INLINE propagateSubscriberHold #-}
1345propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1359propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1346propagateSubscriberHold h a = do
1360propagateSubscriberHold h a = do
@@ -1871,11 +1885,11 @@ checkCycle height = do
1871#ifdef DEBUG_CYCLES
1885#ifdef DEBUG_CYCLES
1872 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1886 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1873 stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1887 stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1874− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1888+ throwIO (EventLoopException stacks)
1875#else
1889#else
1876− let cycleInfo = ""
1890+ throwIO EventLoopException
1877#endif
1891#endif
1878− error $ "Causality loop found" <> cycleInfo
1892+
1879
1893
1880mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1894mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1881mergeSubscriber m getKey = Subscriber
1895mergeSubscriber m getKey = Subscriber
test/DebugCycles.hs+10−7
@@ -18,6 +18,7 @@ import Control.Exception
18
18
19import System.Timeout
19import System.Timeout
20
20
21+import Data.Maybe (isJust)
21import Data.Functor.Misc
22import Data.Functor.Misc
22import qualified Data.Map as Map
23import qualified Data.Map as Map
23import Data.Map (Map)
24import Data.Map (Map)
@@ -29,6 +30,8 @@ import Reflex
29import Reflex.EventWriter.Base
30import Reflex.EventWriter.Base
30import Test.Run
31import Test.Run
31
32
33+import Reflex.Spider.Internal (EventLoopException)
34+
32
35
33import Data.Witherable (Filterable)
36import Data.Witherable (Filterable)
34
37
@@ -103,16 +106,16 @@ pattern RunTestCaseFlag = "--run-test"
103runTest :: (String, TestCase) -> IO ()
106runTest :: (String, TestCase) -> IO ()
104runTest (name, TestCase test) = do
107runTest (name, TestCase test) = do
105 mError <- timeout (milliseconds 5) $
108 mError <- timeout (milliseconds 5) $
106− run `catch` \(ErrorCall e) -> pure e
109+ run `catch` \(e :: EventLoopException) -> pure (show e)
107
110
108− case mError of
111+ unless (isJust mError) $
109− Nothing -> error $ name <> ": timed out (loop not detected)"
112+ error $ name <> ": timed out (loop not detected)"
110− Just msg -> unless (msg == "Causality loop found") $
113+
111− error $ "loop not detected: " <> msg
112−
113 where
114 where
114
115
115− run = runApp' (test . splitThese) (Just <$> occs) >> pure "unexpected success"
116+ run = runApp' (test . splitThese) (Just <$> occs)
117+ >> error (name <> ": unexpected success")
118+
116 occs = [ This 1, This 2, That (), This 3 ]
119 occs = [ This 1, This 2, That (), This 3 ]
117
120
118 milliseconds = (*1000)
121 milliseconds = (*1000)