git.iko.soy/reflex
on develop help sign in
Add exception type for cycles
commit1d1c2d179f20cdbf8c9542c816dbe570fd9901f1 authorOliver Batchelor <saulzar@gmail.com> dateSat 31 Aug 2019, 04:43 (7 years ago) parent9e1864f
2 files changed+31−14
compare with develop
unifiedsplit
src/Reflex/Spider/Internal.hs+21−7 test/DebugCycles.hs+10−7
src/Reflex/Spider/Internal.hs+21−7
@@ -101,8 +101,6 @@ import Reflex.NotReady.Class
101101import Reflex.Patch
102102import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
103103
104−
105−
106104#ifdef DEBUG_TRACE_EVENTS
107105import qualified Data.ByteString.Char8 as BS8
108106import System.IO (stderr)
@@ -1322,12 +1320,17 @@ traceM _ _ = return ()
13221320#endif
13231321
13241322
1325−
1326−
13271323whoCreatedIORef :: IORef a -> IO [String]
13281324whoCreatedIORef (IORef a) = whoCreated $! a
13291325
13301326#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+
13311334groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
13321335groupByHead = \case
13331336 [] -> []
@@ -1339,8 +1342,19 @@ groupByHead = \case
13391342
13401343listsToForest :: Eq a => [[a]] -> Forest a
13411344listsToForest 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+
13421355#endif
13431356
1357+
13441358{-# INLINE propagateSubscriberHold #-}
13451359propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
13461360propagateSubscriberHold h a = do
@@ -1871,11 +1885,11 @@ checkCycle height = do
18711885#ifdef DEBUG_CYCLES
18721886 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
18731887 stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1874− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1888+ throwIO (EventLoopException stacks)
18751889#else
1876− let cycleInfo = ""
1890+ throwIO EventLoopException
18771891#endif
1878− error $ "Causality loop found" <> cycleInfo
1892+
18791893
18801894mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
18811895mergeSubscriber m getKey = Subscriber
test/DebugCycles.hs+10−7
@@ -18,6 +18,7 @@ import Control.Exception
1818
1919import System.Timeout
2020
21+import Data.Maybe (isJust)
2122import Data.Functor.Misc
2223import qualified Data.Map as Map
2324import Data.Map (Map)
@@ -29,6 +30,8 @@ import Reflex
2930import Reflex.EventWriter.Base
3031import Test.Run
3132
33+import Reflex.Spider.Internal (EventLoopException)
34+
3235
3336import Data.Witherable (Filterable)
3437
@@ -103,16 +106,16 @@ pattern RunTestCaseFlag = "--run-test"
103106runTest :: (String, TestCase) -> IO ()
104107runTest (name, TestCase test) = do
105108 mError <- timeout (milliseconds 5) $
106− run `catch` \(ErrorCall e) -> pure e
109+ run `catch` \(e :: EventLoopException) -> pure (show e)
107110
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−
111+ unless (isJust mError) $
112+ error $ name <> ": timed out (loop not detected)"
113+
113114 where
114115
115− run = runApp' (test . splitThese) (Just <$> occs) >> pure "unexpected success"
116+ run = runApp' (test . splitThese) (Just <$> occs)
117+ >> error (name <> ": unexpected success")
118+
116119 occs = [ This 1, This 2, That (), This 3 ]
117120
118121 milliseconds = (*1000)