From a671900c9bb1688f3452c8d4486b3c27c191e76f Mon Sep 17 00:00:00 2001
From: Ryan Trinkle <ryan@trinkle.org>
Date: Fri, 7 Apr 2023 18:09:31 -0400
Subject: [PATCH] Add failing test case with cyclic graph

---
 main.hs | 24 +++++++++++++++++++++---
 1 file changed, 21 insertions(+), 3 deletions(-)

diff --git a/main.hs b/main.hs
index 2b188ff..4107984 100644
--- a/main.hs
+++ b/main.hs
@@ -13,9 +13,12 @@ import GHC.Prim
 import Control.Monad.Primitive
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IntMap
+import Data.Set (Set)
+import qualified Data.Set as Set
 import System.IO.Unsafe
 import Control.Monad
 import Control.Concurrent
+import Data.Foldable
 
 main :: IO ()
 main = do
@@ -89,6 +92,18 @@ testGraphX = do
   print =<< findForward nai
   print =<< findForward nbi
 
+testGraphO :: IO ()
+testGraphO = do
+  (nai, nao) <- newNode "a"
+  (nbi, nbo) <- newNode "b"
+  (nci, nco) <- newNode "c"
+  link nao nbi
+  link nbo nci
+  link nco nai
+  performGCUntilFinalizersQuiesce
+  [] <- toList <$> findForward nai
+  pure ()
+
 data NodeContents a = NodeContents
   { _nodeContents_key :: !Int
   , _nodeContents_value :: a
@@ -151,6 +166,9 @@ link aOut bIn = do
         atomicModifyIORef' (_nodeContents_forwardLinks a) $ \m -> (IntMap.insert (_nodeContents_key b) bIn m, ())
         atomicModifyIORef' (_nodeContents_backLinks b) $ \m -> (IntMap.insert (_nodeContents_key a) aOut m, ())
 
+findForwardVals :: Ord a => NodeInput a -> IO (Set a)
+findForwardVals i = Set.fromList . IntMap.elems <$> findForward i
+
 findForward :: forall a. NodeInput a -> IO (IntMap a)
 findForward i = go mempty (IntMap.singleton (_nodeInput_key i) i)
   where
@@ -162,10 +180,10 @@ findForward i = go mempty (IntMap.singleton (_nodeInput_key i) i)
           Nothing -> go found restToSearch
           Just this -> do
             newLinks <- readIORef (_nodeContents_forwardLinks this)
-            go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch newLinks)
+            go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch (newLinks `IntMap.difference` found))
 
 findBackward :: forall a. NodeOutput a -> IO (IntMap a)
-findBackward i = go mempty (IntMap.singleton (_nodeOutput_key i) i)
+findBackward o = go mempty (IntMap.singleton (_nodeOutput_key o) o)
   where
     go :: IntMap a -> IntMap (NodeOutput a) -> IO (IntMap a)
     go found toSearch = case IntMap.minViewWithKey toSearch of
@@ -175,7 +193,7 @@ findBackward i = go mempty (IntMap.singleton (_nodeOutput_key i) i)
           Nothing -> go found restToSearch
           Just this -> do
             newLinks <- readIORef (_nodeContents_backLinks this)
-            go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch newLinks)
+            go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch (newLinks `IntMap.difference` found))
 
 testDualWeak :: IO ()
 testDualWeak = do