ryantrinkle/weak-refs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add failing test case with cyclic graph

Browse Source
This commit is contained in:
Ryan Trinkle 2023-04-07 18:09:31 -04:00
parent 8f2f4d7478
commit a671900c9b
1 changed files with 21 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
main.hs
View File

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