Skip to content

Commit 051d04f

Browse files
cootcoot
committed
MonadSTM: added flushTQueue
1 parent b38f82f commit 051d04f

File tree

5 files changed

+32
-2
lines changed

5 files changed

+32
-2
lines changed

‎io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Control.Concurrent.Class.MonadSTM.TQueue
1111
, tryReadTQueue
1212
, peekTQueue
1313
, tryPeekTQueue
14+
, flushTQueue
1415
, writeTQueue
1516
, unGetTQueue
1617
, isEmptyTQueue

‎io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs

Lines changed: 23 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ import qualified Control.Concurrent.STM.TMVar as STM
6464
import qualified Control.Concurrent.STM.TQueue as STM
6565
import qualified Control.Concurrent.STM.TSem as STM
6666
import qualified Control.Concurrent.STM.TVar as STM
67-
import Control.Monad (MonadPlus (..), when)
67+
import Control.Monad (MonadPlus (..), unless, when)
6868
import qualified Control.Monad.STM as STM
6969

7070
import Control.Monad.Cont (ContT (..))
@@ -151,6 +151,7 @@ class ( Monad m
151151
tryReadTQueue :: TQueue m a -> STM m (Maybe a)
152152
peekTQueue :: TQueue m a -> STM m a
153153
tryPeekTQueue :: TQueue m a -> STM m (Maybe a)
154+
flushTQueue :: TQueue m a -> STM m [a]
154155
writeTQueue :: TQueue m a -> a -> STM m ()
155156
isEmptyTQueue :: TQueue m a -> STM m Bool
156157
unGetTQueue :: TQueue m a -> a -> STM m ()
@@ -285,6 +286,10 @@ class ( Monad m
285286
=> TQueue m a -> STM m (Maybe a)
286287
tryPeekTQueue = tryPeekTQueueDefault
287288

289+
default flushTQueue :: TQueue m ~ TQueueDefault m
290+
=> TQueue m a -> STM m [a]
291+
flushTQueue = flushTQueueDefault
292+
288293
default newTBQueue :: TBQueue m ~ TBQueueDefault m
289294
=> Natural -> STM m (TBQueue m a)
290295
newTBQueue = newTBQueueDefault
@@ -683,7 +688,7 @@ instance MonadSTM IO where
683688
tryReadTQueue = STM.tryReadTQueue
684689
peekTQueue = STM.peekTQueue
685690
tryPeekTQueue = STM.tryPeekTQueue
686-
flushTBQueue = STM.flushTBQueue
691+
flushTQueue = STM.flushTQueue
687692
writeTQueue = STM.writeTQueue
688693
isEmptyTQueue = STM.isEmptyTQueue
689694
unGetTQueue = STM.unGetTQueue
@@ -693,6 +698,7 @@ instance MonadSTM IO where
693698
peekTBQueue = STM.peekTBQueue
694699
tryPeekTBQueue = STM.tryPeekTBQueue
695700
writeTBQueue = STM.writeTBQueue
701+
flushTBQueue = STM.flushTBQueue
696702
lengthTBQueue = STM.lengthTBQueue
697703
isEmptyTBQueue = STM.isEmptyTBQueue
698704
isFullTBQueue = STM.isFullTBQueue
@@ -940,6 +946,15 @@ tryPeekTQueueDefault (TQueue read _write) = do
940946
(x:_) -> return (Just x)
941947
_ -> return Nothing
942948

949+
950+
flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]
951+
flushTQueueDefault (TQueue read write) = do
952+
xs <- readTVar read
953+
ys <- readTVar write
954+
unless (null xs) $ writeTVar read []
955+
unless (null ys) $ writeTVar write []
956+
return (xs ++ reverse ys)
957+
943958
unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
944959
unGetTQueueDefault (TQueue read _write) a = modifyTVar read (a:)
945960

@@ -1346,6 +1361,7 @@ instance MonadSTM m => MonadSTM (ContT r m) where
13461361
tryReadTQueue = WrappedSTM . tryReadTQueue
13471362
peekTQueue = WrappedSTM . peekTQueue
13481363
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1364+
flushTQueue = WrappedSTM . flushTQueue
13491365
writeTQueue v = WrappedSTM . writeTQueue v
13501366
isEmptyTQueue = WrappedSTM . isEmptyTQueue
13511367
unGetTQueue = WrappedSTM .: unGetTQueue
@@ -1420,6 +1436,7 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
14201436
tryReadTQueue = WrappedSTM . tryReadTQueue
14211437
peekTQueue = WrappedSTM . peekTQueue
14221438
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1439+
flushTQueue = WrappedSTM . flushTQueue
14231440
writeTQueue v = WrappedSTM . writeTQueue v
14241441
isEmptyTQueue = WrappedSTM . isEmptyTQueue
14251442
unGetTQueue = WrappedSTM .: unGetTQueue
@@ -1494,6 +1511,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where
14941511
tryReadTQueue = WrappedSTM . tryReadTQueue
14951512
peekTQueue = WrappedSTM . peekTQueue
14961513
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1514+
flushTQueue = WrappedSTM . flushTQueue
14971515
writeTQueue v = WrappedSTM . writeTQueue v
14981516
isEmptyTQueue = WrappedSTM . isEmptyTQueue
14991517
unGetTQueue = WrappedSTM .: unGetTQueue
@@ -1568,6 +1586,7 @@ instance MonadSTM m => MonadSTM (StateT s m) where
15681586
tryReadTQueue = WrappedSTM . tryReadTQueue
15691587
peekTQueue = WrappedSTM . peekTQueue
15701588
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1589+
flushTQueue = WrappedSTM . flushTQueue
15711590
writeTQueue v = WrappedSTM . writeTQueue v
15721591
isEmptyTQueue = WrappedSTM . isEmptyTQueue
15731592
unGetTQueue = WrappedSTM .: unGetTQueue
@@ -1642,6 +1661,7 @@ instance MonadSTM m => MonadSTM (ExceptT e m) where
16421661
tryReadTQueue = WrappedSTM . tryReadTQueue
16431662
peekTQueue = WrappedSTM . peekTQueue
16441663
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1664+
flushTQueue = WrappedSTM . flushTQueue
16451665
writeTQueue v = WrappedSTM . writeTQueue v
16461666
isEmptyTQueue = WrappedSTM . isEmptyTQueue
16471667
unGetTQueue = WrappedSTM .: unGetTQueue
@@ -1716,6 +1736,7 @@ instance (Monoid w, MonadSTM m) => MonadSTM (RWST r w s m) where
17161736
tryReadTQueue = WrappedSTM . tryReadTQueue
17171737
peekTQueue = WrappedSTM . peekTQueue
17181738
tryPeekTQueue = WrappedSTM . tryPeekTQueue
1739+
flushTQueue = WrappedSTM . flushTQueue
17191740
writeTQueue v = WrappedSTM . writeTQueue v
17201741
isEmptyTQueue = WrappedSTM . isEmptyTQueue
17211742
unGetTQueue = WrappedSTM .: unGetTQueue

‎io-sim/src/Control/Monad/IOSim/STM.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,9 @@ tryPeekTQueueDefault (TQueue queue) = do
8585
x :_ -> Just x
8686
[] -> Nothing
8787

88+
flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]
89+
flushTQueueDefault (TQueue queue) = uncurry (++) <$> readTVar queue
90+
8891
unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
8992
unGetTQueueDefault (TQueue queue) a = do
9093
(xs, ys) <- readTVar queue

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -416,6 +416,7 @@ instance MonadSTM (IOSim s) where
416416
tryReadTQueue = tryReadTQueueDefault
417417
peekTQueue = peekTQueueDefault
418418
tryPeekTQueue = tryPeekTQueueDefault
419+
flushTQueue = flushTQueueDefault
419420
writeTQueue = writeTQueueDefault
420421
isEmptyTQueue = isEmptyTQueueDefault
421422
unGetTQueue = unGetTQueueDefault

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TQueue
1818
, tryReadTQueue
1919
, peekTQueue
2020
, tryPeekTQueue
21+
, flushTQueue
2122
, writeTQueue
2223
, unGetTQueue
2324
, isEmptyTQueue
@@ -78,6 +79,9 @@ peekTQueue = Lazy.peekTQueue . toLazyTQueue
7879
tryPeekTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a)
7980
tryPeekTQueue = Lazy.tryPeekTQueue . toLazyTQueue
8081

82+
flushTQueue :: MonadSTM m => StrictTQueue m a -> STM m [a]
83+
flushTQueue = Lazy.flushTQueue . toLazyTQueue
84+
8185
writeTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m ()
8286
writeTQueue (StrictTQueue tqueue) !a = Lazy.writeTQueue tqueue a
8387

0 commit comments

Comments
 (0)