From 2a6ba170058dc83d236d8f3259555ec9cd18eb21 Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 15:54:24 +0100
Subject: [PATCH 1/6] Ignore Vim Sessions

---
 .gitignore | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.gitignore b/.gitignore
index d5c3c640..32dbadbd 100644
--- a/.gitignore
+++ b/.gitignore
@@ -25,3 +25,4 @@ cabal.project.local~
 tags
 io-sim/tags
 README.haddock
+*.vim

From 2f0b883c3aadd732a69fbce15945c6a2af64ae83 Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 15:57:19 +0100
Subject: [PATCH 2/6] Add Chan to IOSim

---
 io-classes/io-classes.cabal                   |  3 +-
 .../src/Control/Concurrent/Class/MonadChan.hs | 47 +++++++++++++++++++
 io-sim/src/Control/Monad/IOSim/Types.hs       | 41 ++++++++++++++++
 3 files changed, 90 insertions(+), 1 deletion(-)
 create mode 100644 io-classes/src/Control/Concurrent/Class/MonadChan.hs

diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal
index 41a26940..c94ee722 100644
--- a/io-classes/io-classes.cabal
+++ b/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
diff --git a/io-classes/src/Control/Concurrent/Class/MonadChan.hs b/io-classes/src/Control/Concurrent/Class/MonadChan.hs
new file mode 100644
index 00000000..a3fec283
--- /dev/null
+++ b/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
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
index a7915964..09f105cb 100644
--- a/io-sim/src/Control/Monad/IOSim/Types.hs
+++ b/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

From 2006f03b0171923ed0d991dd03925b7786ce998e Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 16:20:38 +0100
Subject: [PATCH 3/6] Add QSem to IOSim

---
 io-classes/io-classes.cabal                   |  1 +
 .../src/Control/Concurrent/Class/MonadQSem.hs | 32 ++++++++++
 io-sim/src/Control/Monad/IOSim/Types.hs       | 59 ++++++++++++++++++-
 3 files changed, 91 insertions(+), 1 deletion(-)
 create mode 100644 io-classes/src/Control/Concurrent/Class/MonadQSem.hs

diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal
index c94ee722..6323ddeb 100644
--- a/io-classes/io-classes.cabal
+++ b/io-classes/io-classes.cabal
@@ -68,6 +68,7 @@ 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.MonadChan
+                       Control.Concurrent.Class.MonadQSem
                        Control.Concurrent.Class.MonadMVar
                        Control.Concurrent.Class.MonadSTM
                        Control.Concurrent.Class.MonadSTM.TArray
diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSem.hs b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs
new file mode 100644
index 00000000..1850596d
--- /dev/null
+++ b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs
@@ -0,0 +1,32 @@
+{-# 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
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
index 09f105cb..ba9323f8 100644
--- a/io-sim/src/Control/Monad/IOSim/Types.hs
+++ b/io-sim/src/Control/Monad/IOSim/Types.hs
@@ -84,6 +84,8 @@ import Control.Monad.Fix (MonadFix (..))
 
 import Control.Concurrent.Class.MonadChan hiding (Chan)
 import Control.Concurrent.Class.MonadChan qualified as MonadAsync
+import Control.Concurrent.Class.MonadQSem hiding (QSem)
+import Control.Concurrent.Class.MonadQSem qualified as MonadQSem
 import Control.Concurrent.Class.MonadMVar
 import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)
 import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar
@@ -120,7 +122,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
@@ -817,6 +819,61 @@ instance MonadChan (IOSim s) where
     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'
+
 -- | '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

From bbc1e1fcc6208eec47444b534a70e57d41f010d5 Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 16:50:06 +0100
Subject: [PATCH 4/6] Add QSemN to IOSim

---
 io-classes/io-classes.cabal                   |  1 +
 .../Control/Concurrent/Class/MonadQSemN.hs    | 33 ++++++++++++
 io-sim/src/Control/Monad/IOSim/Types.hs       | 53 +++++++++++++++++++
 3 files changed, 87 insertions(+)
 create mode 100644 io-classes/src/Control/Concurrent/Class/MonadQSemN.hs

diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal
index 6323ddeb..bdde95ed 100644
--- a/io-classes/io-classes.cabal
+++ b/io-classes/io-classes.cabal
@@ -69,6 +69,7 @@ library
   -- This has to be tidied up once the design becomes clear.
   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
diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs
new file mode 100644
index 00000000..2a2c64d8
--- /dev/null
+++ b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs
@@ -0,0 +1,33 @@
+{-# 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
+
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
index ba9323f8..6c688e60 100644
--- a/io-sim/src/Control/Monad/IOSim/Types.hs
+++ b/io-sim/src/Control/Monad/IOSim/Types.hs
@@ -86,6 +86,8 @@ import Control.Concurrent.Class.MonadChan hiding (Chan)
 import Control.Concurrent.Class.MonadChan qualified as MonadAsync
 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.MonadMVar
 import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)
 import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar
@@ -874,6 +876,57 @@ instance MonadQSem (IOSim s) where
       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

From 6a290fdcfc204ee253b04f0a844470177b1180b0 Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 16:52:24 +0100
Subject: [PATCH 5/6] Update CHANGELOG

---
 io-classes/CHANGELOG.md | 1 +
 io-sim/CHANGELOG.md     | 1 +
 2 files changed, 2 insertions(+)

diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md
index 03d0e27b..d22282d2 100644
--- a/io-classes/CHANGELOG.md
+++ b/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`
diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md
index e390cc6e..6b780eff 100644
--- a/io-sim/CHANGELOG.md
+++ b/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`.

From 058a632e45f93202f19d63eaf6867d12e8344294 Mon Sep 17 00:00:00 2001
From: Armando Santos <armandoifsantos@gmail.com>
Date: Tue, 6 May 2025 16:59:49 +0100
Subject: [PATCH 6/6] Stylish Haskell

---
 io-classes/src/Control/Concurrent/Class/MonadChan.hs  | 6 ++----
 io-classes/src/Control/Concurrent/Class/MonadQSem.hs  | 4 +---
 io-classes/src/Control/Concurrent/Class/MonadQSemN.hs | 4 +---
 io-sim/src/Control/Monad/IOSim/Types.hs               | 4 ++--
 4 files changed, 6 insertions(+), 12 deletions(-)

diff --git a/io-classes/src/Control/Concurrent/Class/MonadChan.hs b/io-classes/src/Control/Concurrent/Class/MonadChan.hs
index a3fec283..3d934062 100644
--- a/io-classes/src/Control/Concurrent/Class/MonadChan.hs
+++ b/io-classes/src/Control/Concurrent/Class/MonadChan.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies      #-}
 
-module Control.Concurrent.Class.MonadChan
-  ( MonadChan (..)
-  ) where
+module Control.Concurrent.Class.MonadChan (MonadChan (..)) where
 
 import Control.Concurrent.Chan qualified as IO
 
diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSem.hs b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs
index 1850596d..2c43d10b 100644
--- a/io-classes/src/Control/Concurrent/Class/MonadQSem.hs
+++ b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs
@@ -1,8 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Control.Concurrent.Class.MonadQSem
-  ( MonadQSem (..)
-  ) where
+module Control.Concurrent.Class.MonadQSem (MonadQSem (..)) where
 
 import Control.Concurrent.QSem qualified as IO
 
diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs
index 2a2c64d8..c37d8538 100644
--- a/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs
+++ b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs
@@ -1,8 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Control.Concurrent.Class.MonadQSemN
-  ( MonadQSemN (..)
-  ) where
+module Control.Concurrent.Class.MonadQSemN (MonadQSemN (..)) where
 
 import Control.Concurrent.QSemN qualified as IO
 
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
index 6c688e60..d945eeea 100644
--- a/io-sim/src/Control/Monad/IOSim/Types.hs
+++ b/io-sim/src/Control/Monad/IOSim/Types.hs
@@ -84,11 +84,11 @@ 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.MonadMVar
 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)
@@ -901,7 +901,7 @@ instance MonadQSemN (IOSim s) where
 
     case mmvar of
       NothingMV -> return ()
-      JustMV b -> wait' b
+      JustMV b  -> wait' b
     where
       wait' :: MVar (IOSim s) () -> IOSim s ()
       wait' b =