Implement Chan, QSem and QSemN

.gitignore

@@ -25,3 +25,4 @@ cabal.project.local~
 tags
 io-sim/tags
 README.haddock
+*.vim

io-classes/CHANGELOG.md

@@ -6,6 +6,7 @@
 
 ### Breaking changes
 
+- Added `MonadChan`, `MonadQSem` and `MonadQSemN` classes.
 * Added `threadLabel` to `MonadThread`
 * Added `MonadLabelledMVar` class.
 * Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`

io-classes/io-classes.cabal

@@ -67,7 +67,10 @@ 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.MonadQSem
+                       Control.Concurrent.Class.MonadQSemN
+                       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,45 @@
+{-# 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-classes/src/Control/Concurrent/Class/MonadQSem.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Concurrent.Class.MonadQSem (MonadQSem (..)) where
+
+import Control.Concurrent.QSem qualified as IO
+
+import Data.Kind (Type)
+
+class Monad m => MonadQSem m where
+  {-# MINIMAL newQSem, waitQSem, signalQSem #-}
+
+  type QSem m :: Type
+
+  -- | See 'IO.newQSem.
+  newQSem    :: Int -> m (QSem m)
+  -- | See 'IO.waitQSem'.
+  waitQSem   :: QSem m -> m ()
+  -- | See 'IO.signalQSem'.
+  signalQSem :: QSem m -> m ()
+
+--
+-- IO instance
+--
+
+instance MonadQSem IO where
+  type QSem IO = IO.QSem
+
+  newQSem      = IO.newQSem
+  waitQSem     = IO.waitQSem
+  signalQSem   = IO.signalQSem

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

@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Concurrent.Class.MonadQSemN (MonadQSemN (..)) where
+
+import Control.Concurrent.QSemN qualified as IO
+
+import Data.Kind (Type)
+
+class Monad m => MonadQSemN m where
+  {-# MINIMAL newQSemN, waitQSemN, signalQSemN #-}
+
+  type QSemN m :: Type
+
+  -- | See 'IO.newQSemN.
+  newQSemN    :: Int -> m (QSemN m)
+  -- | See 'IO.waitQSemN'.
+  waitQSemN   :: QSemN m -> Int -> m ()
+  -- | See 'IO.signalQSemN'.
+  signalQSemN :: QSemN m -> Int -> m ()
+
+--
+-- IO instance
+--
+
+instance MonadQSemN IO where
+  type QSemN IO = IO.QSemN
+
+  newQSemN      = IO.newQSemN
+  waitQSemN     = IO.waitQSemN
+  signalQSemN   = IO.signalQSemN
+

io-sim/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## next version
 
+- Implements `MonadChan`, `MonadQSem` and `MonadQSemN` instances.
 - Support `threadLabel` (`io-classes-1.8`)
 - `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written
   `TVars`.

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

@@ -82,7 +82,13 @@ 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.MonadQSem hiding (QSem)
+import Control.Concurrent.Class.MonadQSem qualified as MonadQSem
+import Control.Concurrent.Class.MonadQSemN hiding (QSemN)
+import Control.Concurrent.Class.MonadQSemN qualified as MonadQSemN
 import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)
 import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar
 import Control.Monad.Class.MonadAsync hiding (Async)
@@ -118,7 +124,7 @@ import Data.Bifunctor (bimap)
 import Data.Dynamic (Dynamic, toDyn)
 import Data.List.Trace qualified as Trace
 import Data.Map.Strict (Map)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Monoid (Endo (..))
 import Data.Semigroup (Max (..))
 import Data.STRef.Lazy
@@ -776,6 +782,151 @@ 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)
+
+newtype QSem m = QSem (MVar m (Int, [MVar m ()], [MVar m ()]))
+
+signal
+  :: MonadMVar m
+  => (Int, [MVar m ()], [MVar m ()])
+  -> m (Int, [MVar m ()], [MVar m ()])
+signal (i,a1,a2) =
+ if i == 0
+   then loop a1 a2
+   else let !z = i+1 in return (z, a1, a2)
+ where
+   loop [] [] = return (1, [], [])
+   loop [] b2 = loop (reverse b2) []
+   loop (b:bs) b2 = do
+     r <- tryPutMVar b ()
+     if r then return (0, bs, b2)
+          else loop bs b2
+
+instance MonadQSem (IOSim s) where
+  type QSem (IOSim s) = QSem (IOSim s)
+
+  newQSem initial
+    | initial < 0 = fail "newQSem: Initial quantity must be non-negative"
+    | otherwise   = do
+        sem <- newMVar (initial, [], [])
+        return (QSem sem)
+
+  waitQSem (QSem m) =
+    mask_ $ do
+      (i,b1,b2) <- takeMVar m
+      if i == 0
+         then do
+           b <- newEmptyMVar
+           putMVar m (i, b1, b:b2)
+           uninterruptibleWait b
+         else do
+           let !z = i-1
+           putMVar m (z, b1, b2)
+           return ()
+    where
+      uninterruptibleWait b =
+        takeMVar b `onException`
+           uninterruptibleMask_ (do
+              (i,b1,b2) <- takeMVar m
+              r <- tryTakeMVar b
+              r' <- if isJust r
+                       then signal (i,b1,b2)
+                       else do putMVar b (); return (i,b1,b2)
+              putMVar m r')
+  signalQSem (QSem m) =
+    uninterruptibleMask_ $ do
+      r <- takeMVar m
+      r' <- signal r
+      putMVar m r'
+
+newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())]))
+
+data MaybeMV m a = JustMV !(MVarDefault m a)
+                 | NothingMV
+
+instance MonadQSemN (IOSim s) where
+  type QSemN (IOSim s) = QSemN (IOSim s)
+
+  newQSemN initial
+    | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
+    | otherwise   = do
+        sem <- newMVar (initial, [], [])
+        return (QSemN sem)
+
+  waitQSemN qs@(QSemN m) sz = mask_ $ do
+    mmvar <- modifyMVar m $ \ (i,b1,b2) -> do
+      let z = i-sz
+      if z < 0
+        then do
+          b <- newEmptyMVar
+          return ((i, b1, (sz,b):b2), JustMV b)
+        else return ((z, b1, b2), NothingMV)
+
+    case mmvar of
+      NothingMV -> return ()
+      JustMV b  -> wait' b
+    where
+      wait' :: MVar (IOSim s) () -> IOSim s ()
+      wait' b =
+        takeMVar b `onException` do
+          already_filled <- not <$> tryPutMVar b ()
+          when already_filled $ signalQSemN qs sz
+
+  signalQSemN (QSemN m) sz0 = do
+    unit <- modifyMVar m $ \(i,a1,a2) -> loop (sz0 + i) a1 a2
+
+    evaluate unit
+   where
+     loop 0  bs b2 = return ((0,  bs, b2), ())
+     loop sz [] [] = return ((sz, [], []), ())
+     loop sz [] b2 = loop sz (reverse b2) []
+     loop sz ((j,b):bs) b2
+       | j > sz = do
+         r <- isEmptyMVar b
+         if r then return ((sz, (j,b):bs, b2), ())
+              else loop sz bs b2
+       | otherwise = do
+         r <- tryPutMVar b ()
+         if r then loop (sz-j) bs b2
+              else loop sz bs b2
+
 -- | '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