9e1864f · reflex · git.iko.soy

git.iko.soy/reflex

Add test set, add cycle check to mergeInt

commit9e1864ffe465b37db71907747b6eb5c03b103b94 authorOliver Batchelor <saulzar@gmail.com> dateSat 31 Aug 2019, 04:14 (7 years ago) parent9466d90

3 files changed+112−53

compare with develop

unifiedsplit

reflex.cabal+3 src/Reflex/Spider/Internal.hs+33−29 test/DebugCycles.hs+76−24

reflex.cabal+3

@@ -271,6 +271,7 @@ test-suite DebugCycles

271271 type: exitcode-stdio-1.0

272272 main-is: DebugCycles.hs

273273 hs-source-dirs: test

274+ ghc-options: -threaded

274275 build-depends: base

275276 , containers

276277 , deepseq

@@ -283,6 +284,8 @@ test-suite DebugCycles

283284 , reflex

284285 , ref-tf

285286 , witherable

287+ , proctest

288+

286289

287290 if flag(split-these)

288291 build-depends: these-lens, semialign

src/Reflex/Spider/Internal.hs+33−29

@@ -101,17 +101,18 @@ import Reflex.NotReady.Class

101101import Reflex.Patch

102102import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

103103

104+

105+

104106#ifdef DEBUG_TRACE_EVENTS

105107import qualified Data.ByteString.Char8 as BS8

106108import System.IO (stderr)

107−#endif

108−

109−#ifdef DEBUG_TRACE_EVENTS

109+import Data.List (isPrefixOf)

110110

111111withStackOneLine :: (BS8.ByteString -> a) -> a

112112withStackOneLine expr = unsafePerformIO $ do

113113 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")

115116

116117#endif

117118

@@ -277,13 +278,11 @@ cacheEvent e =

277278 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

278279 (parentSub, occ) <- subscribeAndRead e $ Subscriber

279280 { subscriberPropagate = \a -> do

280− liftIO $ writeIORef occRef $ Just a

281+ liftIO $ writeIORef occRef (Just a)

281282 scheduleClear occRef

282283 propagateFast a subscribers

283− , subscriberInvalidateHeight = \old -> do

284− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

285− , subscriberRecalculateHeight = \new -> do

286− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

284+ , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight

285+ , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight

287286 }

288287 when (isJust occ) $ do

289288 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 ()

466465recalculateSubscriberHeight = flip subscriberRecalculateHeight

467466

468467-- | 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 ()

470469propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do

471470 -- 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

472471 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

473472 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

474473

475474-- | 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 ()

477476propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do

478477 -- 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

479478 --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

12971296#else

12981297

12991298{-# 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

13011300withIncreasedDepth _ = id

13021301

13031302{-# INLINE tracePropagate #-}

@@ -1309,7 +1308,7 @@ traceInvalidate :: String -> IO ()

13091308traceInvalidate _ = return ()

13101309

13111310{-# INLINE debugSubscriber #-}

1312−debugSubscriber :: HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1311+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

13131312debugSubscriber _ = return

13141313

13151314{-# INLINE trace #-}

@@ -1861,6 +1860,23 @@ scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

18611860 --TODO: Assert that m is not empty

18621861 subscriberPropagate (_merge_sub m) vals

18631862

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+

18641880mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

18651881mergeSubscriber m getKey = Subscriber

18661882 { subscriberPropagate = \a -> do

@@ -1871,22 +1887,8 @@ mergeSubscriber m getKey = Subscriber

18711887 liftIO $ writeIORef (_merge_accumRef m) $! newM

18721888 when (DMap.null oldM) $ do -- Only schedule the firing once

18731889 height <- liftIO $ readIORef $ _merge_heightRef m

1874− --TODO: assertions about height

1875− currentHeight <- getCurrentHeight

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+ checkCycle height --TODO: assertions about height

1891+

18901892 scheduleMergeSelf m height

18911893 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

18921894 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

@@ -1989,6 +1991,8 @@ mergeIntCheap d = Event $ \sub -> do

19891991 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

19901992 mySubscriber k = Subscriber

19911993 { subscriberPropagate = \a -> do

1994+ liftIO (readIORef heightRef) >>= checkCycle

1995+

19921996 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

19931997 liftIO $ FastMutableIntMap.insert accum k a

19941998 when wasEmpty scheduleSelf

test/DebugCycles.hs+76−24

@@ -1,89 +1,141 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE ConstraintKinds #-}

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE RecursiveDo #-}

66{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE PatternSynonyms #-}

8+{-# LANGUAGE RankNTypes #-}

710module Main where

811

12+import Data.Foldable

913import Control.Lens

1014import Control.Applicative

1115import Control.Monad

1216import Control.Monad.Fix

17+import Control.Exception

18+

19+import System.Timeout

20+

1321import Data.Functor.Misc

14−import qualified Data.Map as M

22+import qualified Data.Map as Map

23+import Data.Map (Map)

24+

1525import Data.These

1626import Data.Align

1727

18−

1928import Reflex

2029import Reflex.EventWriter.Base

2130import Test.Run

2231

32+

2333import Data.Witherable (Filterable)

2434

2535#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

2636import Data.These.Lens

2737#endif

2838

39+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

2940

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)

3142connectDyn e (d, d') = do

3243 dd <- holdDyn d (d' <$ e)

3344 return $ join dd

3445

3546

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)

3748dynLoop (e1, e2) = do

3849 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

3950 rec

4051 d <- count e1

41− d' <- connectDyn e2 (d, (liftA2 (+) d d'))

52+ d' <- connectDyn e2 (d, liftA2 (+) d d')

4253 return $ updated d'

4354

4455

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)

4657connectButtonPromptly click e = do

4758 d <- holdDyn never (e <$ click)

4859 return (switchDyn d)

4960

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)

5162connectButton click e = do

5263 d <- hold never (e <$ click)

5364 return (switch d)

5465

5566

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)

5768switchLoop (e1, e2) = do

5869 rec

5970 e' <- connectButton e2 (updated d)

6071 d <- count (align e' e1)

61−

6272 return $ updated d

6373

64−staticLoop :: AppWidget t m => m ()

65−staticLoop = do

66− el "p" $ do

67− text "Typical error: GHC stack-space overflow: current limit is 33624 bytes"

68− text "(or consumes all available memory)"

74+switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

75+switchLoop' (e1, e2) = do

76+ rec

77+ e' <- connectButton e2 (updated d)

78+ d <- count (leftmost [e', e1])

79+ return $ updated d

6980

70− e <- getPostBuild

81+staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

82+staticLoop (e1, e2) = do

7183 rec

72− d <- foldDyn (+) (0 :: Int) (leftmost [1 <$ e, updated d])

73− dynText (T.pack . show <$> d)

74−

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

90+ d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

91+ return $ updated d

7592

7693

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+

7798splitThese :: Filterable f => f (These a b) -> (f a, f b)

7899splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

79100

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+

80134main :: IO ()

81−main = void $ do

135+main = traverse_ runTest tests

82136

83− runApp' (switchLoop . splitThese) (Just <$> occs)

84− runApp' (dynLoop . splitThese) (Just <$> occs)

85137

86− where

87− occs = [ This 1, This 2, That (), This 3 ]

138+

139+

88140

89141