add io-sim example

Author: UlfNorell

quickcheck-dynamic/quickcheck-dynamic.cabal

@@ -90,6 +90,8 @@ library
       Test.QuickCheck.DynamicLogic.QuantifySpec
       Test.QuickCheck.StateModelSpec
     build-depends:
+      , io-classes
+      , io-sim
       , stm
       , tasty
       , tasty-hunit
@@ -118,6 +120,8 @@ test-suite quickcheck-dynamic-test
   build-depends:
     , base
     , containers
+    , io-classes
+    , io-sim
     , mtl
     , QuickCheck
     , quickcheck-dynamic

quickcheck-dynamic/test/Spec/DynamicLogic/Registry.hs

@@ -2,49 +2,90 @@
 -- process registry.
 module Spec.DynamicLogic.Registry where
 
-import Control.Concurrent.STM
+import Control.Concurrent.Class.MonadSTM
 import Control.Monad
-import GHC.Conc
+import Control.Monad.Class.MonadFork
+import Control.Monad.Class.MonadThrow
+import Control.Exception.Base (pattern ErrorCall)
+import Data.List qualified as List
 
-type Registry = TVar [(String, ThreadId)]
+data Reg m = Reg { registered   :: [(String, ThreadId m)]
+                 , aliveThreads :: [ThreadId m]
+                 }
 
-isAlive :: ThreadId -> IO Bool
-isAlive tid = do
-  s <- threadStatus tid
-  return $ s /= ThreadFinished && s /= ThreadDied
+emptyReg :: Reg m
+emptyReg = Reg [] []
 
-setupRegistry :: IO Registry
-setupRegistry = atomically $ newTVar []
+modifyRegistered :: ([(String, ThreadId m)] -> [(String, ThreadId m)]) -> Reg m -> Reg m
+modifyRegistered f reg = reg{ registered = f (registered reg) }
 
-whereis :: Registry -> String -> IO (Maybe ThreadId)
+modifyAlive :: ([ThreadId m] -> [ThreadId m]) -> Reg m -> Reg m
+modifyAlive f reg = reg{ aliveThreads = f (aliveThreads reg) }
+
+newtype Registry m = Registry (TVar m (Reg m))
+
+readReg :: MonadSTM m => Registry m -> STM m (Reg m)
+readReg (Registry r) = readTVar r
+
+writeReg :: MonadSTM m => Registry m -> Reg m -> STM m ()
+writeReg (Registry r) = writeTVar r
+
+modifyReg :: MonadSTM m => Registry m -> (Reg m -> Reg m) -> STM m ()
+modifyReg (Registry r) = modifyTVar r
+
+type MonadRegistry m = (MonadSTM m, MonadFork m, MonadThrow m, MonadThrow (STM m))
+
+isAlive :: MonadRegistry m => Registry m -> ThreadId m -> m Bool
+isAlive registry tid =
+  elem tid . aliveThreads <$> atomically (readReg registry)
+
+setupRegistry :: forall m. MonadRegistry m => m (Registry m)
+setupRegistry = atomically $ Registry <$> newTVar @m emptyReg
+
+spawn :: MonadRegistry m => Registry m -> m () -> m (ThreadId m)
+spawn registry run = do
+  sync <- atomically newEmptyTMVar
+  let body = do
+        self <- myThreadId
+        atomically $ do
+          modifyReg registry $ modifyAlive (self :)
+          writeTMVar sync self
+        run
+      after _ = do
+        self <- myThreadId
+        atomically $ modifyReg registry $ modifyAlive $ List.delete self
+  forkFinally body after
+  atomically $ readTMVar sync
+
+whereis :: MonadRegistry m => Registry m -> String -> m (Maybe (ThreadId m))
 whereis registry name = do
   reg <- readRegistry registry
   return $ lookup name reg
 
-register :: Registry -> String -> ThreadId -> IO ()
+register :: MonadRegistry m => Registry m -> String -> ThreadId m -> m ()
 register registry name tid = do
-  ok <- isAlive tid
+  ok <- isAlive registry tid
   reg <- readRegistry registry
   if ok && name `notElem` map fst reg && tid `notElem` map snd reg
     then atomically $ do
-      reg' <- readTVar registry
+      reg' <- registered <$> readReg registry
       if name `notElem` map fst reg' && tid `notElem` map snd reg'
-        then writeTVar registry ((name, tid) : reg')
-        else error "badarg"
-    else error "badarg"
+        then modifyReg registry $ \ reg -> reg{ registered = (name, tid) : reg' }
+        else throwIO (ErrorCall "badarg")
+    else throwIO (ErrorCall "badarg")
 
-unregister :: Registry -> String -> IO ()
+unregister :: MonadRegistry m => Registry m -> String -> m ()
 unregister registry name = do
   reg <- readRegistry registry
   when (name `elem` map fst reg) $ do
-    atomically $ modifyTVar registry $ filter ((/= name) . fst)
+    atomically $ modifyReg registry $ modifyRegistered $ filter ((/= name) . fst)
 
-readRegistry :: Registry -> IO [(String, ThreadId)]
-readRegistry registry = garbageCollect registry *> atomically (readTVar registry)
+readRegistry :: MonadRegistry m => Registry m -> m [(String, ThreadId m)]
+readRegistry registry = garbageCollect registry *> atomically (registered <$> readReg registry)
 
-garbageCollect :: Registry -> IO ()
+garbageCollect :: forall m. MonadRegistry m => Registry m -> m ()
 garbageCollect registry = do
-  reg <- atomically $ readTVar registry
-  garbage <- filterM (fmap not . isAlive) (map snd reg)
-  atomically $ modifyTVar registry $ filter ((`notElem` garbage) . snd)
+  reg <- registered <$> atomically (readReg @m registry)
+  garbage <- filterM (fmap not . isAlive registry) (map snd reg)
+  atomically $ modifyReg registry $ modifyRegistered $ filter ((`notElem` garbage) . snd)
   return ()