{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

-- | 'io-sim' implementation of 'TQueue', 'TBQueue' and 'MVar'.
--
-- Unlike the default implementation available in 'io-classes' the 'TQueue' and
-- 'TBQueue' are using a single 'TVar', which simplifies the implementation of
-- 'traceTQueue' and 'traceTBQueue' methods.
--
module Control.Monad.IOSim.STM where

import           Control.Exception (SomeAsyncException (..))

import           Control.Concurrent.Class.MonadSTM.TVar
import           Control.Monad.Class.MonadSTM (MonadInspectSTM (..),
                     MonadLabelledSTM, MonadSTM (..), MonadTraceSTM,
                     TraceValue (..))
import           Control.Monad.Class.MonadThrow

import           Numeric.Natural (Natural)

import           Deque.Strict (Deque)
import qualified Deque.Strict as Deque

--
-- Default TQueue implementation in terms of a 'TVar' (used by sim)
--

newtype TQueueDefault m a = TQueue (TVar m ([a], [a]))

labelTQueueDefault
  :: MonadLabelledSTM m
  => TQueueDefault m a -> String -> STM m ()
labelTQueueDefault :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
TQueueDefault m a -> String -> STM m ()
labelTQueueDefault (TQueue TVar m ([a], [a])
queue) String
label = forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> STM m ()
labelTVar TVar m ([a], [a])
queue String
label

traceTQueueDefault
  :: MonadTraceSTM m
  => proxy m
  -> TQueueDefault m a
  -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
  -> STM m ()
traceTQueueDefault :: forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTQueueDefault proxy m
p (TQueue TVar m ([a], [a])
queue) Maybe [a] -> [a] -> InspectMonad m TraceValue
f =
    forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
traceTVar proxy m
p TVar m ([a], [a])
queue
              (\Maybe ([a], [a])
mas ([a], [a])
as -> Maybe [a] -> [a] -> InspectMonad m TraceValue
f (forall {a}. ([a], [a]) -> [a]
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([a], [a])
mas) (forall {a}. ([a], [a]) -> [a]
g ([a], [a])
as))
  where
    g :: ([a], [a]) -> [a]
g ([a]
xs, [a]
ys) = [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
ys

newTQueueDefault :: MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault :: forall (m :: * -> *) a. MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault = forall (m :: * -> *) a. TVar m ([a], [a]) -> TQueueDefault m a
TQueue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar ([], [])

writeTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
writeTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
writeTQueueDefault (TQueue TVar m ([a], [a])
queue) a
a = do
    ([a]
xs, [a]
ys) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue forall a b. (a -> b) -> a -> b
$! ([a]
xs, a
a forall a. a -> [a] -> [a]
: [a]
ys)

readTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a
readTQueueDefault :: forall (m :: * -> *) a. MonadSTM m => TQueueDefault m a -> STM m a
readTQueueDefault TQueueDefault m a
queue = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSTM m => STM m a
retry forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault TQueueDefault m a
queue

tryReadTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault (TQueue TVar m ([a], [a])
queue) = do
  ([a]
xs, [a]
ys) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
  case [a]
xs of
    (a
x:[a]
xs') -> do
      forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue forall a b. (a -> b) -> a -> b
$! ([a]
xs', [a]
ys)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
    [] ->
      case forall a. [a] -> [a]
reverse [a]
ys of
        []     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (a
z:[a]
zs) -> do
          forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue forall a b. (a -> b) -> a -> b
$! ([a]
zs, [])
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
z)

isEmptyTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault (TQueue TVar m ([a], [a])
queue) = do
  ([a]
xs, [a]
ys) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [a]
xs of
    a
_:[a]
_ -> Bool
False
    []  -> case [a]
ys of
             [] -> Bool
True
             [a]
_  -> Bool
False

peekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a
peekTQueueDefault :: forall (m :: * -> *) a. MonadSTM m => TQueueDefault m a -> STM m a
peekTQueueDefault (TQueue TVar m ([a], [a])
queue) = do
    ([a]
xs, [a]
_) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    case [a]
xs of
      a
x :[a]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
      []   -> forall (m :: * -> *) a. MonadSTM m => STM m a
retry

tryPeekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a)
tryPeekTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m (Maybe a)
tryPeekTQueueDefault (TQueue TVar m ([a], [a])
queue) = do
    ([a]
xs, [a]
_) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [a]
xs of
      a
x :[a]
_ -> forall a. a -> Maybe a
Just a
x
      []   -> forall a. Maybe a
Nothing

flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]
flushTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> STM m [a]
flushTQueueDefault (TQueue TVar m ([a], [a])
queue) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue

unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
unGetTQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
unGetTQueueDefault (TQueue TVar m ([a], [a])
queue) a
a = do
    ([a]
xs, [a]
ys) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue (a
a forall a. a -> [a] -> [a]
: [a]
xs, [a]
ys)

--
-- Default TBQueue implementation in terms of 'Seq' (used by sim)
--

data TBQueueDefault m a = TBQueue
  !(TVar m ([a], Natural, [a], Natural))
  !Natural

labelTBQueueDefault
  :: MonadLabelledSTM m
  => TBQueueDefault m a -> String -> STM m ()
labelTBQueueDefault :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
TBQueueDefault m a -> String -> STM m ()
labelTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) String
label = forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> STM m ()
labelTVar TVar m ([a], Natural, [a], Natural)
queue String
label

traceTBQueueDefault
  :: MonadTraceSTM m
  => proxy m
  -> TBQueueDefault m a
  -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
  -> STM m ()
traceTBQueueDefault :: forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TBQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
-> STM m ()
traceTBQueueDefault proxy m
p (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) Maybe [a] -> [a] -> InspectMonad m TraceValue
f =
    forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
traceTVar proxy m
p TVar m ([a], Natural, [a], Natural)
queue (\Maybe ([a], Natural, [a], Natural)
mas ([a], Natural, [a], Natural)
as -> Maybe [a] -> [a] -> InspectMonad m TraceValue
f (forall {a} {b} {d}. ([a], b, [a], d) -> [a]
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([a], Natural, [a], Natural)
mas) (forall {a} {b} {d}. ([a], b, [a], d) -> [a]
g ([a], Natural, [a], Natural)
as))
  where
    g :: ([a], b, [a], d) -> [a]
g ([a]
xs, b
_, [a]
ys, d
_) = [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
ys


newTBQueueDefault :: MonadSTM m => Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault Natural
size | Natural
size forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
                       = forall a. HasCallStack => String -> a
error String
"newTBQueueDefault: size larger than Int"
newTBQueueDefault Natural
size =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
TVar m ([a], Natural, [a], Natural)
-> Natural -> TBQueueDefault m a
TBQueue Natural
size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar forall a b. (a -> b) -> a -> b
$! ([], Natural
0, [], Natural
size))

readTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a
readTBQueueDefault :: forall (m :: * -> *) a. MonadSTM m => TBQueueDefault m a -> STM m a
readTBQueueDefault TBQueueDefault m a
queue = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSTM m => STM m a
retry forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault TBQueueDefault m a
queue

tryReadTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) = do
  ([a]
xs, Natural
r, [a]
ys, Natural
w) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  let !r' :: Natural
r' = Natural
r forall a. Num a => a -> a -> a
+ Natural
1
  case [a]
xs of
    (a
x:[a]
xs') -> do
      forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue forall a b. (a -> b) -> a -> b
$! ([a]
xs', Natural
r', [a]
ys, Natural
w)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
    [] ->
      case forall a. [a] -> [a]
reverse [a]
ys of
        [] -> do
          forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue forall a b. (a -> b) -> a -> b
$! ([a]
xs, Natural
r', [a]
ys, Natural
w)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        -- NB. lazy: we want the transaction to be
        -- short, otherwise it will conflict
        (a
z:[a]
zs) -> do
           forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue forall a b. (a -> b) -> a -> b
$! ([a]
zs, Natural
r', [], Natural
w)
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
z)

peekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a
peekTBQueueDefault :: forall (m :: * -> *) a. MonadSTM m => TBQueueDefault m a -> STM m a
peekTBQueueDefault TBQueueDefault m a
queue = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSTM m => STM m a
retry forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryPeekTBQueueDefault TBQueueDefault m a
queue

tryPeekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a)
tryPeekTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m (Maybe a)
tryPeekTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) = do
    ([a]
xs, Natural
_, [a]
_, Natural
_) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [a]
xs of
      (a
x:[a]
_) -> forall a. a -> Maybe a
Just a
x
      [a]
_     -> forall a. Maybe a
Nothing

writeTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) a
a = do
  ([a]
xs, Natural
r, [a]
ys, Natural
w) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
    then do let !w' :: Natural
w' = Natural
w forall a. Num a => a -> a -> a
- Natural
1
            forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue forall a b. (a -> b) -> a -> b
$! ([a]
xs, Natural
r, a
aforall a. a -> [a] -> [a]
:[a]
ys, Natural
w')
    else do
          if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
            then let !w' :: Natural
w' = Natural
r forall a. Num a => a -> a -> a
- Natural
1 in
                 forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue ([a]
xs, Natural
0, a
aforall a. a -> [a] -> [a]
:[a]
ys, Natural
w')
            else forall (m :: * -> *) a. MonadSTM m => STM m a
retry

isEmptyTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) = do
  ([a]
xs, Natural
_, [a]
ys, Natural
_) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  case [a]
xs of
    a
_:[a]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    []  -> case [a]
ys of
             [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             [a]
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isFullTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) = do
  ([a]
_, Natural
r, [a]
_, Natural
w) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
    then Bool
False
    else if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
         then Bool
False
         else Bool
True

lengthTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
size) = do
  ([a]
_, Natural
r, [a]
_, Natural
w) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Natural
size forall a. Num a => a -> a -> a
- Natural
r forall a. Num a => a -> a -> a
- Natural
w

flushTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m [a]
flushTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m [a]
flushTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
size) = do
  ([a]
xs, Natural
_, [a]
ys, Natural
_) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
    then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue forall a b. (a -> b) -> a -> b
$! ([], Natural
0, [], Natural
size)
      forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
ys)

unGetTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m ()
unGetTBQueueDefault :: forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
unGetTBQueueDefault (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) a
a = do
  ([a]
xs, Natural
r, [a]
ys, Natural
w) <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
     then do forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (a
a forall a. a -> [a] -> [a]
: [a]
xs, Natural
r forall a. Num a => a -> a -> a
- Natural
1, [a]
ys, Natural
w)
     else do
          if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
             then forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (a
a forall a. a -> [a] -> [a]
: [a]
xs, Natural
r, [a]
ys, Natural
w forall a. Num a => a -> a -> a
- Natural
1)
             else forall (m :: * -> *) a. MonadSTM m => STM m a
retry


--
-- Default MVar implementation in terms of STM (used by sim)
--

-- | A default 'MonadMVar' implementation is based on `TVar`'s.  An @MVar@
-- guarantees fairness.
--
-- /Implementation details:/
--
-- 'STM' does not guarantee fairness, instead it provide compositionally.
-- Fairness of 'putMVarDefault' and 'takeMVarDefault' is provided by tracking
-- queue of blocked operation in the 'MVarState', e.g.  when a 'putMVarDefault'
-- is scheduled on a full 'MVar', the request is put on to the back of the queue
-- together with a wakeup var.  When 'takeMVarDefault' executes, it returns the
-- value and is using the first element of the queue to set the new value of
-- the 'MVar' and signals next `putMVarDefault` operation to unblock.  This has
-- an effect as if all the racing `putMVarDefault` calls where executed in
-- turns.
--
-- Note that 'readMVar' has interesting semantics: it is guaranteed to read
-- the next value put using 'putMVar', and all readers will wake up, not just
-- the first. To support this, the implementation uses two queues in the empty
-- MVar case: one for threads blocked on 'takeMVar', and one for threads
-- blocked on 'readMVar'. The 'putMVar' has to wake up all readers and the
-- first \"taker\" (if any).
--
newtype MVarDefault m a = MVar (TVar m (MVarState m a))

data MVarState m a = MVarEmpty   !(Deque (TVar m (Maybe a))) -- blocked on take
                                 !(Deque (TVar m (Maybe a))) -- blocked on read
                   | MVarFull  a !(Deque (a, TVar m Bool))   -- blocked on put


newEmptyMVarDefault :: MonadSTM m => m (MVarDefault m a)
newEmptyMVarDefault :: forall (m :: * -> *) a. MonadSTM m => m (MVarDefault m a)
newEmptyMVarDefault = forall (m :: * -> *) a. TVar m (MVarState m a) -> MVarDefault m a
MVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)


newMVarDefault :: MonadSTM m => a -> m (MVarDefault m a)
newMVarDefault :: forall (m :: * -> *) a. MonadSTM m => a -> m (MVarDefault m a)
newMVarDefault a
a = forall (m :: * -> *) a. TVar m (MVarState m a) -> MVarDefault m a
MVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
a forall a. Monoid a => a
mempty)


putMVarDefault :: ( MonadMask  m
                  , MonadSTM   m
                  , forall x tvar. tvar ~ TVar m x => Eq tvar
                  )
               => MVarDefault m a -> a -> m ()
putMVarDefault :: forall (m :: * -> *) a.
(MonadMask m, MonadSTM m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> a -> m ()
putMVarDefault (MVar TVar m (MVarState m a)
tv) a
x = forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar m Bool)
res <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        -- It's full, add ourselves to the end of the 'put' blocked queue.
        MVarFull a
x' Deque (a, TVar m Bool)
putq -> do
          TVar m Bool
putvar <- forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar Bool
False
          forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' (forall a. a -> Deque a -> Deque a
Deque.snoc (a
x, TVar m Bool
putvar) Deque (a, TVar m Bool)
putq))
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just TVar m Bool
putvar)

        -- The MVar is empty. Wake up any threads blocked in readMVar.
        -- If there's at least one thread blocked in takeMVar, we wake up the
        -- first, leaving the MVar empty. Otherwise the MVar becomes full.
        MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TVar m (Maybe a)
readvar -> forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe a)
readvar (forall a. a -> Maybe a
Just a
x)) Deque (TVar m (Maybe a))
readq

          case forall a. Deque a -> Maybe (a, Deque a)
Deque.uncons Deque (TVar m (Maybe a))
takeq of
            Maybe (TVar m (Maybe a), Deque (TVar m (Maybe a)))
Nothing ->
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x forall a. Monoid a => a
mempty)

            Just (TVar m (Maybe a)
takevar, Deque (TVar m (Maybe a))
takeq') -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe a)
takevar (forall a. a -> Maybe a
Just a
x)
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq' forall a. Monoid a => a
mempty)

          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    case Maybe (TVar m Bool)
res of
      -- we have to block on our own putvar until we can complete the put
      Just TVar m Bool
putvar ->
        forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
putvar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)
        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
            case MVarState m a
s of
              MVarFull a
x' Deque (a, TVar m Bool)
putq -> do
                -- async exception was thrown while we were blocked on putvar;
                -- we need to remove it from the queue, otherwise we will have
                -- a space leak.
                let putq' :: Deque (a, TVar m Bool)
putq' = forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter ((forall a. Eq a => a -> a -> Bool
/= TVar m Bool
putvar) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) Deque (a, TVar m Bool)
putq
                forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' Deque (a, TVar m Bool)
putq')

              -- This case is unlikely but possible if another thread ran
              -- first and modified the mvar. This situation is fine as far as
              -- space leaks are concerned because it means our wait var is no
              -- longer in the wait queue.
              MVarEmpty {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeAsyncException
e

      -- we managed to do the put synchronously
      Maybe (TVar m Bool)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()


tryPutMVarDefault :: MonadSTM m
                  => MVarDefault m a -> a -> m Bool
tryPutMVarDefault :: forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> a -> m Bool
tryPutMVarDefault (MVar TVar m (MVarState m a)
tv) a
x =
    forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        MVarFull {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        -- The MVar is empty. Wake up any threads blocked in readMVar.
        -- If there's at least one thread blocked in takeMVar, we wake up the
        -- first, leaving the MVar empty. Otherwise the MVar becomes full.
        MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TVar m (Maybe a)
readvar -> forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe a)
readvar (forall a. a -> Maybe a
Just a
x)) Deque (TVar m (Maybe a))
readq

          case forall a. Deque a -> Maybe (a, Deque a)
Deque.uncons Deque (TVar m (Maybe a))
takeq of
            Maybe (TVar m (Maybe a), Deque (TVar m (Maybe a)))
Nothing ->
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x forall a. Monoid a => a
mempty)

            Just (TVar m (Maybe a)
takevar, Deque (TVar m (Maybe a))
takeq') -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe a)
takevar (forall a. a -> Maybe a
Just a
x)
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq' forall a. Monoid a => a
mempty)

          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


takeMVarDefault :: ( MonadMask m
                   , MonadSTM  m
                   , forall x tvar. tvar ~ TVar m x => Eq tvar
                   )
                => MVarDefault m a
                -> m a
takeMVarDefault :: forall (m :: * -> *) a.
(MonadMask m, MonadSTM m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> m a
takeMVarDefault (MVar TVar m (MVarState m a)
tv) = forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
    Either (TVar m (Maybe a)) a
res <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        -- It's empty, add ourselves to the end of the 'take' blocked queue.
        MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do
          TVar m (Maybe a)
takevar <- forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar forall a. Maybe a
Nothing
          forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty (forall a. a -> Deque a -> Deque a
Deque.snoc TVar m (Maybe a)
takevar Deque (TVar m (Maybe a))
takeq) Deque (TVar m (Maybe a))
readq)
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left TVar m (Maybe a)
takevar)

        -- It's full. If there's at least one thread blocked in putMVar, wake
        -- up the first one leaving the MVar full with the new put value.
        -- Otherwise the MVar becomes empty.
        MVarFull a
x Deque (a, TVar m Bool)
putq ->
          case forall a. Deque a -> Maybe (a, Deque a)
Deque.uncons Deque (a, TVar m Bool)
putq of
            Maybe ((a, TVar m Bool), Deque (a, TVar m Bool))
Nothing -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
x)

            Just ((a
x', TVar m Bool
putvar), Deque (a, TVar m Bool)
putq') -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
putvar Bool
True
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' Deque (a, TVar m Bool)
putq')
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
x)

    case Either (TVar m (Maybe a)) a
res of
      -- we have to block on our own takevar until we can complete the read
      Left TVar m (Maybe a)
takevar ->
        forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Maybe a)
takevar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSTM m => STM m a
retry forall (m :: * -> *) a. Monad m => a -> m a
return)
        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
            case MVarState m a
s of
              MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do
                -- async exception was thrown while were were blocked on
                -- takevar; we need to remove it from 'takeq', otherwise we
                -- will have a space leak.
                let takeq' :: Deque (TVar m (Maybe a))
takeq' = forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter (forall a. Eq a => a -> a -> Bool
/= TVar m (Maybe a)
takevar) Deque (TVar m (Maybe a))
takeq
                forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq' Deque (TVar m (Maybe a))
readq)

              -- This case is unlikely but possible if another thread ran
              -- first and modified the mvar. This situation is fine as far as
              -- space leaks are concerned because it means our wait var is no
              -- longer in the wait queue.
              MVarFull {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeAsyncException
e

      -- we managed to do the take synchronously
      Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x


tryTakeMVarDefault :: MonadSTM m
                   => MVarDefault m a
                   -> m (Maybe a)
tryTakeMVarDefault :: forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryTakeMVarDefault (MVar TVar m (MVarState m a)
tv) = do
    forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        MVarEmpty Deque (TVar m (Maybe a))
_ Deque (TVar m (Maybe a))
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        -- It's full. If there's at least one thread blocked in putMVar, wake
        -- up the first one leaving the MVar full with the new put value.
        -- Otherwise the MVar becomes empty.
        MVarFull a
x Deque (a, TVar m Bool)
putq ->
          case forall a. Deque a -> Maybe (a, Deque a)
Deque.uncons Deque (a, TVar m Bool)
putq of
            Maybe ((a, TVar m Bool), Deque (a, TVar m Bool))
Nothing -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty)
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)

            Just ((a
x', TVar m Bool
putvar), Deque (a, TVar m Bool)
putq') -> do
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
putvar Bool
True
              forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' Deque (a, TVar m Bool)
putq')
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)


-- | 'readMVarDefault' when the 'MVar' is empty, guarantees to receive next
-- 'putMVar' value.  It will also not block if the 'MVar' is full, even if there
-- are other threads attempting to 'putMVar'.
--
readMVarDefault :: ( MonadSTM m
                   , MonadMask m
                   , forall x tvar. tvar ~ TVar m x => Eq tvar
                   )
                => MVarDefault m a
                -> m a
readMVarDefault :: forall (m :: * -> *) a.
(MonadSTM m, MonadMask m,
 forall x tvar. (tvar ~ TVar m x) => Eq tvar) =>
MVarDefault m a -> m a
readMVarDefault (MVar TVar m (MVarState m a)
tv) = do
    Either (TVar m (Maybe a)) a
res <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        -- It's empty, add ourselves to the 'read' blocked queue.
        MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do
          TVar m (Maybe a)
readvar <- forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar forall a. Maybe a
Nothing
          forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq (forall a. a -> Deque a -> Deque a
Deque.snoc TVar m (Maybe a)
readvar Deque (TVar m (Maybe a))
readq))
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left TVar m (Maybe a)
readvar)

        -- if it's full return the value
        MVarFull a
x Deque (a, TVar m Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
x)

    case Either (TVar m (Maybe a)) a
res of
      -- we have to block on our own readvar until we can complete the read
      Left TVar m (Maybe a)
readvar ->
        forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Maybe a)
readvar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSTM m => STM m a
retry forall (m :: * -> *) a. Monad m => a -> m a
return)
        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
            case MVarState m a
s of
              MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq -> do
                -- async exception was thrown while were were blocked on
                -- readvar; we need to remove it from 'readq', otherwise we
                -- will have a space leak.
                let readq' :: Deque (TVar m (Maybe a))
readq' = forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter (forall a. Eq a => a -> a -> Bool
/= TVar m (Maybe a)
readvar) Deque (TVar m (Maybe a))
readq
                forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq Deque (TVar m (Maybe a))
readq')

              -- This case is unlikely but possible if another thread ran
              -- first and modified the mvar. This situation is fine as far as
              -- space leaks are concerned because it means our wait var is no
              -- longer in the wait queue.
              MVarFull {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeAsyncException
e

      -- we managed to do the take synchronously
      Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x


tryReadMVarDefault :: MonadSTM m
                   => MVarDefault m a -> m (Maybe a)
tryReadMVarDefault :: forall (m :: * -> *) a.
MonadSTM m =>
MVarDefault m a -> m (Maybe a)
tryReadMVarDefault (MVar TVar m (MVarState m a)
tv) =
    forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        MVarFull  a
x Deque (a, TVar m Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
        MVarEmpty {}  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


isEmptyMVarDefault :: MonadSTM  m
                   => MVarDefault m a -> m Bool
isEmptyMVarDefault :: forall (m :: * -> *) a. MonadSTM m => MVarDefault m a -> m Bool
isEmptyMVarDefault (MVar TVar m (MVarState m a)
tv) =
    forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (MVarState m a)
tv
      case MVarState m a
s of
        MVarFull  {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        MVarEmpty {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True