{-# LANGUAGE QuantifiedConstraints #-}

-- | '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] -> InspectMonadSTM m TraceValue)
  -> STM m ()
traceTQueueDefault :: forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
-> STM m ()
traceTQueueDefault proxy m
p (TQueue TVar m ([a], [a])
queue) Maybe [a] -> [a] -> InspectMonadSTM m TraceValue
f =
    proxy m
-> TVar m ([a], [a])
-> (Maybe ([a], [a]) -> ([a], [a]) -> InspectMonadSTM m TraceValue)
-> STM m ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
-> STM m ()
forall (proxy :: (* -> *) -> *) a.
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
-> STM m ()
traceTVar proxy m
p TVar m ([a], [a])
queue
              (\Maybe ([a], [a])
mas ([a], [a])
as -> Maybe [a] -> [a] -> InspectMonadSTM 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
    (xs, 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
    writeTVar queue $! (xs, 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
  (xs, 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 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
  (xs, 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
  return $ case 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
    (xs, _) <- 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 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
    (xs, _) <- 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
    return $ case 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
  (xs, 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
  writeTVar queue ([], [])
  pure (xs <> reverse 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
    (xs, 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
    writeTVar queue (a : xs, 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] -> InspectMonadSTM m TraceValue)
  -> STM m ()
traceTBQueueDefault :: forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TBQueueDefault m a
-> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)
-> STM m ()
traceTBQueueDefault proxy m
p (TBQueue TVar m ([a], Natural, [a], Natural)
queue Natural
_size) Maybe [a] -> [a] -> InspectMonadSTM m TraceValue
f =
    proxy m
-> TVar m ([a], Natural, [a], Natural)
-> (Maybe ([a], Natural, [a], Natural)
    -> ([a], Natural, [a], Natural) -> InspectMonadSTM m TraceValue)
-> STM m ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonadSTM m TraceValue)
-> STM m ()
forall (proxy :: (* -> *) -> *) a.
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonadSTM 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] -> InspectMonadSTM 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
  (xs, r, ys, 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 -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
  case 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
        [] -> 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], 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
    (xs, _, _, _) <- 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
    return $ case 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
  (xs, r, ys, 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 (w > 0)
    then do let !w' = Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
            writeTVar queue $! (xs, r, a:ys, w')
    else do
          if (r > 0)
            then let !w' = Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 in
                 writeTVar queue (xs, 0, a:ys, w')
            else 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
  (xs, _, ys, _) <- 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 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
  (_, r, _, 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
  return $
    if (w > 0)
    then False
    else if (r > 0)
         then False
         else 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
  (_, r, _, 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
  return $! size - r - 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
  (xs, _, ys, _) <- 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 null xs && null ys
    then return []
    else do
      writeTVar queue $! ([], 0, [], size)
      return (xs ++ reverse 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
  (xs, r, ys, 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 (r > 0)
     then do writeTVar queue (a : xs, r - 1, ys, w)
     else do
          if (w > 0)
             then writeTVar queue (a : xs, r, ys, w - 1)
             else 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 provides 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)

labelMVarDefault
  :: MonadLabelledSTM m
  => MVarDefault m a -> String -> m ()
labelMVarDefault :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
MVarDefault m a -> String -> m ()
labelMVarDefault (MVar TVar m (MVarState m a)
tvar) = 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 ()) -> (String -> STM m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (MVarState m 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 (MVarState m a)
tvar

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
                  , MonadLabelledSTM m
                  , forall x tvar. tvar ~ TVar m x => Eq tvar
                  )
               => MVarDefault m a -> a -> m ()
putMVarDefault :: forall (m :: * -> *) a.
(MonadMask m, MonadLabelledSTM 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
    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
      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 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
          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
          labelTVar putvar "internal-putvar"
          writeTVar tv (MVarFull x' (Deque.snoc (x, putvar) putq))
          return (Just 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 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
            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 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
      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 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
                   , MonadLabelledSTM m
                   , forall x tvar. tvar ~ TVar m x => Eq tvar
                   )
                => MVarDefault m a
                -> m a
takeMVarDefault :: forall (m :: * -> *) a.
(MonadMask m, MonadLabelledSTM 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
    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
      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 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
          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
          labelTVar takevar "internal-takevar"
          writeTVar tv (MVarEmpty (Deque.snoc takevar takeq) readq)
          return (Left 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 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
            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 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
                takevalue <- 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
                case takevalue of
                  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' Deque (TVar m (Maybe a))
readq)
                  -- we were given a value before we could read it. Relay it to any
                  -- new reading threads and possible the next take thread.
                  Just a
x -> do
                    -- notify readers
                    (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

                    -- notify first `takeMVar` thread
                    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)

              -- 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
      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 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 :: ( MonadLabelledSTM m
                   , MonadMask m
                   , forall x tvar. tvar ~ TVar m x => Eq tvar
                   )
                => MVarDefault m a
                -> m a
readMVarDefault :: forall (m :: * -> *) a.
(MonadLabelledSTM 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
    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
      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 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
          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
          labelTVar readvar "internal-readvar"
          writeTVar tv (MVarEmpty takeq (Deque.snoc readvar readq))
          return (Left 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 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
            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 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
      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 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
      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 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