{-# 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 Data.Deque.Strict (Deque)
import Data.Deque.Strict qualified 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 = TVar m ([a], [a]) -> String -> STM m ()
forall a. TVar m a -> String -> STM m ()
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 =
    proxy m
-> TVar m ([a], [a])
-> (Maybe ([a], [a]) -> ([a], [a]) -> InspectMonad m TraceValue)
-> STM m ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
forall (proxy :: (* -> *) -> *) a.
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 (([a], [a]) -> [a]
forall {a}. ([a], [a]) -> [a]
g (([a], [a]) -> [a]) -> Maybe ([a], [a]) -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([a], [a])
mas) (([a], [a]) -> [a]
forall {a}. ([a], [a]) -> [a]
g ([a], [a])
as))
  where
    g :: ([a], [a]) -> [a]
g ([a]
xs, [a]
ys) = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [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 = TVar m ([a], [a]) -> TQueueDefault m a
forall (m :: * -> *) a. TVar m ([a], [a]) -> TQueueDefault m a
TQueue (TVar m ([a], [a]) -> TQueueDefault m a)
-> STM m (TVar m ([a], [a])) -> STM m (TQueueDefault m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([a], [a]) -> STM m (TVar m ([a], [a]))
forall a. a -> STM m (TVar m a)
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) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    TVar m ([a], [a]) -> ([a], [a]) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue (([a], [a]) -> STM m ()) -> ([a], [a]) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
xs, a
a a -> [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 = STM m a -> (a -> STM m a) -> Maybe a -> STM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM m a) -> STM m (Maybe a) -> STM m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TQueueDefault m a -> STM m (Maybe a)
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) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m 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]
xs') -> do
      TVar m ([a], [a]) -> ([a], [a]) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue (([a], [a]) -> STM m ()) -> ([a], [a]) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
xs', [a]
ys)
      Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    [] ->
      case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys of
        []     -> Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        (a
z:[a]
zs) -> do
          TVar m ([a], [a]) -> ([a], [a]) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue (([a], [a]) -> STM m ()) -> ([a], [a]) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
zs, [])
          Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
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) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
  Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM m Bool) -> Bool -> STM m Bool
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]
_) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m 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]
_ -> a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
      []   -> STM m a
forall a. STM m a
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]
_) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM m (Maybe a)) -> Maybe a -> STM m (Maybe a)
forall a b. (a -> b) -> a -> b
$ case [a]
xs of
      a
x :[a]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
      []   -> Maybe a
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) = do
  ([a]
xs, [a]
ys) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
  TVar m ([a], [a]) -> ([a], [a]) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue ([], [])
  [a] -> STM m [a]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys)

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) <- TVar m ([a], [a]) -> STM m ([a], [a])
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], [a])
queue
    TVar m ([a], [a]) -> ([a], [a]) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], [a])
queue (a
a a -> [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 = TVar m ([a], Natural, [a], Natural) -> String -> STM m ()
forall a. TVar m a -> String -> STM m ()
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 =
    proxy m
-> TVar m ([a], Natural, [a], Natural)
-> (Maybe ([a], Natural, [a], Natural)
    -> ([a], Natural, [a], Natural) -> InspectMonad m TraceValue)
-> STM m ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
forall (proxy :: (* -> *) -> *) a.
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 (([a], Natural, [a], Natural) -> [a]
forall {a} {b} {d}. ([a], b, [a], d) -> [a]
g (([a], Natural, [a], Natural) -> [a])
-> Maybe ([a], Natural, [a], Natural) -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([a], Natural, [a], Natural)
mas) (([a], Natural, [a], Natural) -> [a]
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 [a] -> [a] -> [a]
forall a. [a] -> [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 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)
                       = String -> STM m (TBQueueDefault m a)
forall a. HasCallStack => String -> a
error String
"newTBQueueDefault: size larger than Int"
newTBQueueDefault Natural
size =
  (TVar m ([a], Natural, [a], Natural)
 -> Natural -> TBQueueDefault m a)
-> Natural
-> TVar m ([a], Natural, [a], Natural)
-> TBQueueDefault m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip TVar m ([a], Natural, [a], Natural)
-> Natural -> TBQueueDefault m a
forall (m :: * -> *) a.
TVar m ([a], Natural, [a], Natural)
-> Natural -> TBQueueDefault m a
TBQueue Natural
size (TVar m ([a], Natural, [a], Natural) -> TBQueueDefault m a)
-> STM m (TVar m ([a], Natural, [a], Natural))
-> STM m (TBQueueDefault m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([a], Natural, [a], Natural)
-> STM m (TVar m ([a], Natural, [a], Natural))
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar (([a], Natural, [a], Natural)
 -> STM m (TVar m ([a], Natural, [a], Natural)))
-> ([a], Natural, [a], Natural)
-> STM m (TVar m ([a], Natural, [a], Natural))
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 = STM m a -> (a -> STM m a) -> Maybe a -> STM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM m a) -> STM m (Maybe a) -> STM m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TBQueueDefault m a -> STM m (Maybe a)
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) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
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 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
  case [a]
xs of
    (a
x:[a]
xs') -> do
      TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (([a], Natural, [a], Natural) -> STM m ())
-> ([a], Natural, [a], Natural) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
xs', Natural
r', [a]
ys, Natural
w)
      Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    [] ->
      case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys of
        [] -> do
          TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (([a], Natural, [a], Natural) -> STM m ())
-> ([a], Natural, [a], Natural) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
xs, Natural
r', [a]
ys, Natural
w)
          Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

        -- NB. lazy: we want the transaction to be
        -- short, otherwise it will conflict
        (a
z:[a]
zs) -> do
           TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (([a], Natural, [a], Natural) -> STM m ())
-> ([a], Natural, [a], Natural) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
zs, Natural
r', [], Natural
w)
           Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
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 = STM m a -> (a -> STM m a) -> Maybe a -> STM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM m a) -> STM m (Maybe a) -> STM m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TBQueueDefault m a -> STM m (Maybe a)
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
_) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
    Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> STM m (Maybe a)) -> Maybe a -> STM m (Maybe a)
forall a b. (a -> b) -> a -> b
$ case [a]
xs of
      (a
x:[a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
      [a]
_     -> Maybe 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) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if (Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
    then do let !w' :: Natural
w' = Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
            TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (([a], Natural, [a], Natural) -> STM m ())
-> ([a], Natural, [a], Natural) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([a]
xs, Natural
r, a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, Natural
w')
    else do
          if (Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
            then let !w' :: Natural
w' = Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 in
                 TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue ([a]
xs, Natural
0, a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, Natural
w')
            else STM m ()
forall a. STM m a
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
_) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
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]
_ -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    []  -> case [a]
ys of
             [] -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             [a]
_  -> Bool -> STM m Bool
forall a. a -> STM m 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) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM m Bool) -> Bool -> STM m Bool
forall a b. (a -> b) -> a -> b
$
    if (Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
    then Bool
False
    else if (Natural
r Natural -> Natural -> Bool
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) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  Natural -> STM m Natural
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> STM m Natural) -> Natural -> STM m Natural
forall a b. (a -> b) -> a -> b
$! Natural
size Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
r Natural -> Natural -> Natural
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
_) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
    then [a] -> STM m [a]
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (([a], Natural, [a], Natural) -> STM m ())
-> ([a], Natural, [a], Natural) -> STM m ()
forall a b. (a -> b) -> a -> b
$! ([], Natural
0, [], Natural
size)
      [a] -> STM m [a]
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [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) <- TVar m ([a], Natural, [a], Natural)
-> STM m ([a], Natural, [a], Natural)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m ([a], Natural, [a], Natural)
queue
  if (Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
     then do TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1, [a]
ys, Natural
w)
     else do
          if (Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
             then TVar m ([a], Natural, [a], Natural)
-> ([a], Natural, [a], Natural) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m ([a], Natural, [a], Natural)
queue (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, Natural
r, [a]
ys, Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1)
             else STM m ()
forall a. STM m a
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 = TVar m (MVarState m a) -> MVarDefault m a
forall (m :: * -> *) a. TVar m (MVarState m a) -> MVarDefault m a
MVar (TVar m (MVarState m a) -> MVarDefault m a)
-> m (TVar m (MVarState m a)) -> m (MVarDefault m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVarState m a -> m (TVar m (MVarState m a))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
forall a. Monoid a => a
mempty Deque (TVar m (Maybe a))
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 = TVar m (MVarState m a) -> MVarDefault m a
forall (m :: * -> *) a. TVar m (MVarState m a) -> MVarDefault m a
MVar (TVar m (MVarState m a) -> MVarDefault m a)
-> m (TVar m (MVarState m a)) -> m (MVarDefault m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVarState m a -> m (TVar m (MVarState m a))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
a Deque (a, TVar m Bool)
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 = m () -> m ()
forall a. m a -> m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar m Bool)
res <- STM m (Maybe (TVar m Bool)) -> m (Maybe (TVar m Bool))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (TVar m Bool)) -> m (Maybe (TVar m Bool)))
-> STM m (Maybe (TVar m Bool)) -> m (Maybe (TVar m Bool))
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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 <- Bool -> STM m (TVar m Bool)
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar Bool
False
          TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' ((a, TVar m Bool)
-> Deque (a, TVar m Bool) -> Deque (a, TVar m Bool)
forall a. a -> Deque a -> Deque a
Deque.snoc (a
x, TVar m Bool
putvar) Deque (a, TVar m Bool)
putq))
          Maybe (TVar m Bool) -> STM m (Maybe (TVar m Bool))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar m Bool -> Maybe (TVar m Bool)
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
          (TVar m (Maybe a) -> STM m ())
-> Deque (TVar m (Maybe a)) -> STM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TVar m (Maybe a)
readvar -> TVar m (Maybe a) -> Maybe a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe a)
readvar (a -> Maybe a
forall a. a -> Maybe a
Just a
x)) Deque (TVar m (Maybe a))
readq

          case Deque (TVar m (Maybe a))
-> Maybe (TVar m (Maybe a), Deque (TVar m (Maybe a)))
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 ->
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x Deque (a, TVar m Bool)
forall a. Monoid a => a
mempty)

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

          Maybe (TVar m Bool) -> STM m (Maybe (TVar m Bool))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TVar m Bool)
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 ->
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m Bool -> STM m Bool
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
putvar STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)
        m () -> (SomeAsyncException -> m ()) -> m ()
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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' = ((a, TVar m Bool) -> Bool)
-> Deque (a, TVar m Bool) -> Deque (a, TVar m Bool)
forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter ((TVar m Bool -> TVar m Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= TVar m Bool
putvar) (TVar m Bool -> Bool)
-> ((a, TVar m Bool) -> TVar m Bool) -> (a, TVar m Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TVar m Bool) -> TVar m Bool
forall a b. (a, b) -> b
snd) Deque (a, TVar m Bool)
putq
                TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
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 {} -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          SomeAsyncException -> m ()
forall e a. Exception e => e -> m a
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 -> () -> m ()
forall a. a -> m a
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 =
    STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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 {} -> Bool -> STM m Bool
forall a. a -> STM m a
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

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

          case Deque (TVar m (Maybe a))
-> Maybe (TVar m (Maybe a), Deque (TVar m (Maybe a)))
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 ->
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x Deque (a, TVar m Bool)
forall a. Monoid a => a
mempty)

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

          Bool -> STM m Bool
forall a. a -> STM m a
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) = m a -> m a
forall a. m a -> m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
    Either (TVar m (Maybe a)) a
res <- STM m (Either (TVar m (Maybe a)) a)
-> m (Either (TVar m (Maybe a)) a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either (TVar m (Maybe a)) a)
 -> m (Either (TVar m (Maybe a)) a))
-> STM m (Either (TVar m (Maybe a)) a)
-> m (Either (TVar m (Maybe a)) a)
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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 <- Maybe a -> STM m (TVar m (Maybe a))
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar Maybe a
forall a. Maybe a
Nothing
          TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty (TVar m (Maybe a)
-> Deque (TVar m (Maybe a)) -> Deque (TVar m (Maybe a))
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)
          Either (TVar m (Maybe a)) a -> STM m (Either (TVar m (Maybe a)) a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar m (Maybe a) -> Either (TVar m (Maybe a)) a
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 Deque (a, TVar m Bool)
-> Maybe ((a, TVar m Bool), Deque (a, TVar m Bool))
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
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
forall a. Monoid a => a
mempty Deque (TVar m (Maybe a))
forall a. Monoid a => a
mempty)
              Either (TVar m (Maybe a)) a -> STM m (Either (TVar m (Maybe a)) a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (TVar m (Maybe a)) a
forall a b. b -> Either a b
Right a
x)

            Just ((a
x', TVar m Bool
putvar), Deque (a, TVar m Bool)
putq') -> do
              TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
putvar Bool
True
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' Deque (a, TVar m Bool)
putq')
              Either (TVar m (Maybe a)) a -> STM m (Either (TVar m (Maybe a)) a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (TVar m (Maybe a)) a
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 ->
        STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Maybe a) -> STM m (Maybe a)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Maybe a)
takevar STM m (Maybe a) -> (Maybe a -> STM m a) -> STM m a
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m a -> (a -> STM m a) -> Maybe a -> STM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return)
        m a -> (SomeAsyncException -> m a) -> m a
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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' = (TVar m (Maybe a) -> Bool)
-> Deque (TVar m (Maybe a)) -> Deque (TVar m (Maybe a))
forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter (TVar m (Maybe a) -> TVar m (Maybe a) -> Bool
forall a. Eq a => a -> a -> Bool
/= TVar m (Maybe a)
takevar) Deque (TVar m (Maybe a))
takeq
                TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
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 {} -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          SomeAsyncException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeAsyncException
e

      -- we managed to do the take synchronously
      Right a
x -> a -> m a
forall a. a -> m a
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
    STM m (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe a) -> m (Maybe a)) -> STM m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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))
_ -> Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 Deque (a, TVar m Bool)
-> Maybe ((a, TVar m Bool), Deque (a, TVar m Bool))
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
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
forall a. Monoid a => a
mempty Deque (TVar m (Maybe a))
forall a. Monoid a => a
mempty)
              Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)

            Just ((a
x', TVar m Bool
putvar), Deque (a, TVar m Bool)
putq') -> do
              TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
putvar Bool
True
              TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (a -> Deque (a, TVar m Bool) -> MVarState m a
forall (m :: * -> *) a.
a -> Deque (a, TVar m Bool) -> MVarState m a
MVarFull a
x' Deque (a, TVar m Bool)
putq')
              Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
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 <- STM m (Either (TVar m (Maybe a)) a)
-> m (Either (TVar m (Maybe a)) a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either (TVar m (Maybe a)) a)
 -> m (Either (TVar m (Maybe a)) a))
-> STM m (Either (TVar m (Maybe a)) a)
-> m (Either (TVar m (Maybe a)) a)
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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 <- Maybe a -> STM m (TVar m (Maybe a))
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar Maybe a
forall a. Maybe a
Nothing
          TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
forall (m :: * -> *) a.
Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
MVarEmpty Deque (TVar m (Maybe a))
takeq (TVar m (Maybe a)
-> Deque (TVar m (Maybe a)) -> Deque (TVar m (Maybe a))
forall a. a -> Deque a -> Deque a
Deque.snoc TVar m (Maybe a)
readvar Deque (TVar m (Maybe a))
readq))
          Either (TVar m (Maybe a)) a -> STM m (Either (TVar m (Maybe a)) a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar m (Maybe a) -> Either (TVar m (Maybe a)) a
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)
_ -> Either (TVar m (Maybe a)) a -> STM m (Either (TVar m (Maybe a)) a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (TVar m (Maybe a)) a
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 ->
        STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Maybe a) -> STM m (Maybe a)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Maybe a)
readvar STM m (Maybe a) -> (Maybe a -> STM m a) -> STM m a
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m a -> (a -> STM m a) -> Maybe a -> STM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return)
        m a -> (SomeAsyncException -> m a) -> m a
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: SomeAsyncException
e@SomeAsyncException {} -> do
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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' = (TVar m (Maybe a) -> Bool)
-> Deque (TVar m (Maybe a)) -> Deque (TVar m (Maybe a))
forall a. (a -> Bool) -> Deque a -> Deque a
Deque.filter (TVar m (Maybe a) -> TVar m (Maybe a) -> Bool
forall a. Eq a => a -> a -> Bool
/= TVar m (Maybe a)
readvar) Deque (TVar m (Maybe a))
readq
                TVar m (MVarState m a) -> MVarState m a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (MVarState m a)
tv (Deque (TVar m (Maybe a))
-> Deque (TVar m (Maybe a)) -> MVarState m a
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 {} -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          SomeAsyncException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeAsyncException
e

      -- we managed to do the take synchronously
      Right a
x -> a -> m a
forall a. a -> m a
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) =
    STM m (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe a) -> m (Maybe a)) -> STM m (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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)
_ -> Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
        MVarEmpty {}  -> Maybe a -> STM m (Maybe a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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) =
    STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
      MVarState m a
s <- TVar m (MVarState m a) -> STM m (MVarState m a)
forall a. TVar m a -> STM m a
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  {} -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        MVarEmpty {} -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True