Add Chan to IOSim

Author: bolt12

io-classes/io-classes.cabal

@@ -67,7 +67,8 @@ library
 
   -- At this experiment/prototype stage everything is exposed.
   -- This has to be tidied up once the design becomes clear.
-  exposed-modules:     Control.Concurrent.Class.MonadMVar
+  exposed-modules:     Control.Concurrent.Class.MonadChan
+                       Control.Concurrent.Class.MonadMVar
                        Control.Concurrent.Class.MonadSTM
                        Control.Concurrent.Class.MonadSTM.TArray
                        Control.Concurrent.Class.MonadSTM.TBQueue

io-classes/src/Control/Concurrent/Class/MonadChan.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Concurrent.Class.MonadChan
+  ( MonadChan (..)
+  ) where
+
+import Control.Concurrent.Chan qualified as IO
+
+import Data.Kind (Type)
+
+class Monad m => MonadChan m where
+  {-# MINIMAL newChan,
+              writeChan, readChan,
+              dupChan, getChanContents #-}
+
+  type Chan m :: Type -> Type
+
+  -- | See 'IO.newChan.
+  newChan      :: m (Chan m a)
+  -- | See 'IO.writeChan'.
+  writeChan    :: Chan m a -> a -> m ()
+  -- | See 'IO.readChan'.
+  readChan     :: Chan m a -> m a
+  -- | See 'IO.dupChan'.
+  dupChan      :: Chan m a -> m (Chan m a)
+  -- | See 'IO.getChanContents'.
+  getChanContents :: Chan m a -> m [a]
+  -- | See 'IO.writeList2Chan'
+  writeList2Chan :: Chan m a -> [a] -> m ()
+
+  default writeList2Chan :: Chan m a -> [a] -> m ()
+  writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
+  {-# INLINE writeList2Chan #-}
+
+--
+-- IO instance
+--
+
+instance MonadChan IO where
+  type Chan IO    = IO.Chan
+
+  newChan         = IO.newChan
+  writeChan       = IO.writeChan
+  readChan        = IO.readChan
+  dupChan         = IO.dupChan
+  getChanContents = IO.getChanContents

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -82,6 +82,8 @@ import Control.Exception qualified as IO
 import Control.Monad
 import Control.Monad.Fix (MonadFix (..))
 
+import Control.Concurrent.Class.MonadChan hiding (Chan)
+import Control.Concurrent.Class.MonadChan qualified as MonadAsync
 import Control.Concurrent.Class.MonadMVar
 import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)
 import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar
@@ -776,6 +778,45 @@ instance MonadEventlog (IOSim s) where
   traceEventIO = traceM . EventlogEvent
   traceMarkerIO = traceM . EventlogMarker
 
+data Chan m a
+ = Chan (MVar m (Stream m a))
+        (MVar m (Stream m a))
+
+type Stream m a = MVar m (ChanItem m a)
+
+data ChanItem m a = ChanItem a (Stream m a)
+
+instance MonadChan (IOSim s) where
+  type Chan (IOSim s) = Chan (IOSim s)
+
+  newChan = do
+    hole  <- newEmptyMVar
+    readVar  <- newMVar hole
+    writeVar <- newMVar hole
+    return (Chan readVar writeVar)
+
+  writeChan (Chan _ writeVar) val = do
+    new_hole <- newEmptyMVar
+    mask_ $ do
+      old_hole <- takeMVar writeVar
+      putMVar old_hole (ChanItem val new_hole)
+      putMVar writeVar new_hole
+
+  readChan (Chan readVar _) =
+    modifyMVar readVar $ \read_end -> do
+      (ChanItem val new_read_end) <- readMVar read_end
+      return (new_read_end, val)
+
+  dupChan (Chan _ writeVar) = do
+    hole       <- readMVar writeVar
+    newReadVar <- newMVar hole
+    return (Chan newReadVar writeVar)
+
+  getChanContents ch = do
+    x  <- readChan ch
+    xs <- getChanContents ch
+    return (x:xs)
+
 -- | 'Trace' is a recursive data type, it is the trace of a 'IOSim'
 -- computation.  The trace will contain information about thread scheduling,
 -- blocking on 'TVar's, and other internal state changes of 'IOSim'.  More