{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Control.Monad.Class.MonadSTM
  ( MonadSTM (..)
  , MonadSTMTx (..)
  , LazyTVar
  , LazyTMVar
  , TVar
  , TMVar
  , TQueue
  , TBQueue

  -- * Default 'TMVar' implementation
  , TMVarDefault (..)
  , newTMVarDefault
  , newTMVarIODefault
  , newEmptyTMVarDefault
  , newEmptyTMVarIODefault
  , takeTMVarDefault
  , tryTakeTMVarDefault
  , putTMVarDefault
  , tryPutTMVarDefault
  , readTMVarDefault
  , tryReadTMVarDefault
  , swapTMVarDefault
  , isEmptyTMVarDefault

  -- * Default 'TBQueue' implementation
  , TQueueDefault (..)
  , newTQueueDefault
  , readTQueueDefault
  , tryReadTQueueDefault
  , writeTQueueDefault
  , isEmptyTQueueDefault

  -- * Default 'TBQueue' implementation
  , TBQueueDefault (..)
  , newTBQueueDefault
  , readTBQueueDefault
  , tryReadTBQueueDefault
  , writeTBQueueDefault
  , isEmptyTBQueueDefault
  , isFullTBQueueDefault
  , lengthTBQueueDefault
  , flushTBQueueDefault

  -- * MonadThrow aliases
  , throwSTM
  , catchSTM

  -- * Deprecated API
  , newTVarM
  , newTMVarM
  , newTMVarMDefault
  , newEmptyTMVarM
  , newEmptyTMVarMDefault
  ) where

import           Prelude hiding (read)

import qualified Control.Concurrent.STM.TBQueue as STM
import qualified Control.Concurrent.STM.TMVar as STM
import qualified Control.Concurrent.STM.TQueue as STM
import qualified Control.Concurrent.STM.TVar as STM
import qualified Control.Monad.STM as STM

import qualified Control.Monad.Class.MonadThrow as MonadThrow

import           Control.Applicative (Alternative (..))
import           Control.Exception
import           Control.Monad.Reader
import           Data.Kind (Type)
import           GHC.Stack
import           Numeric.Natural (Natural)


{-# DEPRECATED LazyTVar  "Renamed back to 'TVar'" #-}
{-# DEPRECATED LazyTMVar "Renamed back to 'TMVar'" #-}
type LazyTVar  m = TVar m
type LazyTMVar m = TMVar m

-- The STM primitives
class ( Monad stm
      , Alternative stm
      , MonadPlus stm
      ) => MonadSTMTx stm where
  type TVar_ stm :: Type -> Type

  newTVar      :: a -> stm (TVar_ stm a)
  readTVar     :: TVar_ stm a -> stm a
  writeTVar    :: TVar_ stm a -> a -> stm ()
  retry        :: stm a
  orElse       :: stm a -> stm a -> stm a

  modifyTVar   :: TVar_ stm a -> (a -> a) -> stm ()
  modifyTVar  TVar_ stm a
v a -> a
f = TVar_ stm a -> stm a
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar_ stm a
v stm a -> (a -> stm ()) -> stm ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar_ stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar_ stm a
v (a -> stm ()) -> (a -> a) -> a -> stm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f

  modifyTVar'  :: TVar_ stm a -> (a -> a) -> stm ()
  modifyTVar' TVar_ stm a
v a -> a
f = TVar_ stm a -> stm a
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar_ stm a
v stm a -> (a -> stm ()) -> stm ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> TVar_ stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar_ stm a
v (a -> stm ()) -> a -> stm ()
forall a b. (a -> b) -> a -> b
$! a -> a
f a
x

  -- | @since io-sim-classes-0.2.0.0
  stateTVar    :: TVar_ stm s -> (s -> (a, s)) -> stm a
  stateTVar    = TVar_ stm s -> (s -> (a, s)) -> stm a
forall (stm :: * -> *) s a.
MonadSTMTx stm =>
TVar_ stm s -> (s -> (a, s)) -> stm a
stateTVarDefault

  check        :: Bool -> stm ()
  check Bool
True = () -> stm ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check Bool
_    = stm ()
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry

  -- Additional derived STM APIs
  type TMVar_ stm :: Type -> Type
  newTMVar        :: a -> stm (TMVar_ stm a)
  newEmptyTMVar   ::      stm (TMVar_ stm a)
  takeTMVar       :: TMVar_ stm a      -> stm a
  tryTakeTMVar    :: TMVar_ stm a      -> stm (Maybe a)
  putTMVar        :: TMVar_ stm a -> a -> stm ()
  tryPutTMVar     :: TMVar_ stm a -> a -> stm Bool
  readTMVar       :: TMVar_ stm a      -> stm a
  tryReadTMVar    :: TMVar_ stm a      -> stm (Maybe a)
  swapTMVar       :: TMVar_ stm a -> a -> stm a
  isEmptyTMVar    :: TMVar_ stm a      -> stm Bool

  type TQueue_ stm :: Type -> Type
  newTQueue      :: stm (TQueue_ stm a)
  readTQueue     :: TQueue_ stm a -> stm a
  tryReadTQueue  :: TQueue_ stm a -> stm (Maybe a)
  writeTQueue    :: TQueue_ stm a -> a -> stm ()
  isEmptyTQueue  :: TQueue_ stm a -> stm Bool

  type TBQueue_ stm :: Type -> Type
  newTBQueue     :: Natural -> stm (TBQueue_ stm a)
  readTBQueue    :: TBQueue_ stm a -> stm a
  tryReadTBQueue :: TBQueue_ stm a -> stm (Maybe a)
  flushTBQueue   :: TBQueue_ stm a -> stm [a]
  writeTBQueue   :: TBQueue_ stm a -> a -> stm ()
  -- | @since 0.2.0.0
  lengthTBQueue  :: TBQueue_ stm a -> stm Natural
  isEmptyTBQueue :: TBQueue_ stm a -> stm Bool
  isFullTBQueue  :: TBQueue_ stm a -> stm Bool


stateTVarDefault :: MonadSTMTx stm => TVar_ stm s -> (s -> (a, s)) -> stm a
stateTVarDefault :: TVar_ stm s -> (s -> (a, s)) -> stm a
stateTVarDefault TVar_ stm s
var s -> (a, s)
f = do
   s
s <- TVar_ stm s -> stm s
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar_ stm s
var
   let (a
a, s
s') = s -> (a, s)
f s
s
   TVar_ stm s -> s -> stm ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar_ stm s
var s
s'
   a -> stm a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


type TVar    m = TVar_    (STM m)
type TMVar   m = TMVar_   (STM m)
type TQueue  m = TQueue_  (STM m)
type TBQueue m = TBQueue_ (STM m)

class (Monad m, MonadSTMTx (STM m)) => MonadSTM m where
  -- STM transactions
  type STM m :: Type -> Type

  atomically :: HasCallStack => STM m a -> m a

  -- Helpful derived functions with default implementations

  newTVarIO        :: a -> m (TVar  m a)
  newTMVarIO       :: a -> m (TMVar m a)
  newEmptyTMVarIO  ::      m (TMVar m a)
  newTBQueueIO     :: Natural -> m (TBQueue m a)

  newTVarIO       = STM m (TVar m a) -> m (TVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TVar m a) -> m (TVar m a))
-> (a -> STM m (TVar m a)) -> a -> m (TVar m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STM m (TVar m a)
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar
  newTMVarIO      = STM m (TMVar m a) -> m (TMVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m a) -> m (TMVar m a))
-> (a -> STM m (TMVar m a)) -> a -> m (TMVar m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STM m (TMVar m a)
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TMVar_ stm a)
newTMVar
  newEmptyTMVarIO = STM m (TMVar m a) -> m (TMVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically   STM m (TMVar m a)
forall (stm :: * -> *) a. MonadSTMTx stm => stm (TMVar_ stm a)
newEmptyTMVar
  newTBQueueIO    = STM m (TBQueue m a) -> m (TBQueue m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TBQueue m a) -> m (TBQueue m a))
-> (Natural -> STM m (TBQueue m a)) -> Natural -> m (TBQueue m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> STM m (TBQueue m a)
forall (stm :: * -> *) a.
MonadSTMTx stm =>
Natural -> stm (TBQueue_ stm a)
newTBQueue


newTVarM :: MonadSTM m => a -> m (TVar  m a)
newTVarM :: a -> m (TVar m a)
newTVarM = a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO
{-# DEPRECATED newTVarM "Use newTVarIO" #-}

newTMVarM :: MonadSTM m => a -> m (TMVar m a)
newTMVarM :: a -> m (TMVar m a)
newTMVarM = a -> m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
newTMVarIO
{-# DEPRECATED newTMVarM "Use newTMVarIO" #-}

newEmptyTMVarM  :: MonadSTM m => m (TMVar m a)
newEmptyTMVarM :: m (TMVar m a)
newEmptyTMVarM = m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
newEmptyTMVarIO
{-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-}

--
-- Instance for IO uses the existing STM library implementations
--

instance MonadSTMTx STM.STM where
  type TVar_    STM.STM = STM.TVar
  type TMVar_   STM.STM = STM.TMVar
  type TQueue_  STM.STM = STM.TQueue
  type TBQueue_ STM.STM = STM.TBQueue

  newTVar :: a -> STM (TVar_ STM a)
newTVar        = a -> STM (TVar_ STM a)
forall a. a -> STM (TVar a)
STM.newTVar
  readTVar :: TVar_ STM a -> STM a
readTVar       = TVar_ STM a -> STM a
forall a. TVar a -> STM a
STM.readTVar
  writeTVar :: TVar_ STM a -> a -> STM ()
writeTVar      = TVar_ STM a -> a -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar
  retry :: STM a
retry          = STM a
forall a. STM a
STM.retry
  orElse :: STM a -> STM a -> STM a
orElse         = STM a -> STM a -> STM a
forall a. STM a -> STM a -> STM a
STM.orElse
  modifyTVar :: TVar_ STM a -> (a -> a) -> STM ()
modifyTVar     = TVar_ STM a -> (a -> a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar
  modifyTVar' :: TVar_ STM a -> (a -> a) -> STM ()
modifyTVar'    = TVar_ STM a -> (a -> a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar'
  stateTVar :: TVar_ STM s -> (s -> (a, s)) -> STM a
stateTVar      = TVar_ STM s -> (s -> (a, s)) -> STM a
forall s a. TVar s -> (s -> (a, s)) -> STM a
STM.stateTVar
  check :: Bool -> STM ()
check          = Bool -> STM ()
STM.check
  newTMVar :: a -> STM (TMVar_ STM a)
newTMVar       = a -> STM (TMVar_ STM a)
forall a. a -> STM (TMVar a)
STM.newTMVar
  newEmptyTMVar :: STM (TMVar_ STM a)
newEmptyTMVar  = STM (TMVar_ STM a)
forall a. STM (TMVar a)
STM.newEmptyTMVar
  takeTMVar :: TMVar_ STM a -> STM a
takeTMVar      = TMVar_ STM a -> STM a
forall a. TMVar a -> STM a
STM.takeTMVar
  tryTakeTMVar :: TMVar_ STM a -> STM (Maybe a)
tryTakeTMVar   = TMVar_ STM a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
STM.tryTakeTMVar
  putTMVar :: TMVar_ STM a -> a -> STM ()
putTMVar       = TMVar_ STM a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar
  tryPutTMVar :: TMVar_ STM a -> a -> STM Bool
tryPutTMVar    = TMVar_ STM a -> a -> STM Bool
forall a. TMVar a -> a -> STM Bool
STM.tryPutTMVar
  readTMVar :: TMVar_ STM a -> STM a
readTMVar      = TMVar_ STM a -> STM a
forall a. TMVar a -> STM a
STM.readTMVar
  tryReadTMVar :: TMVar_ STM a -> STM (Maybe a)
tryReadTMVar   = TMVar_ STM a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar
  swapTMVar :: TMVar_ STM a -> a -> STM a
swapTMVar      = TMVar_ STM a -> a -> STM a
forall a. TMVar a -> a -> STM a
STM.swapTMVar
  isEmptyTMVar :: TMVar_ STM a -> STM Bool
isEmptyTMVar   = TMVar_ STM a -> STM Bool
forall a. TMVar a -> STM Bool
STM.isEmptyTMVar
  newTQueue :: STM (TQueue_ STM a)
newTQueue      = STM (TQueue_ STM a)
forall a. STM (TQueue a)
STM.newTQueue
  readTQueue :: TQueue_ STM a -> STM a
readTQueue     = TQueue_ STM a -> STM a
forall a. TQueue a -> STM a
STM.readTQueue
  tryReadTQueue :: TQueue_ STM a -> STM (Maybe a)
tryReadTQueue  = TQueue_ STM a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
STM.tryReadTQueue
  flushTBQueue :: TBQueue_ STM a -> STM [a]
flushTBQueue   = TBQueue_ STM a -> STM [a]
forall a. TBQueue a -> STM [a]
STM.flushTBQueue
  writeTQueue :: TQueue_ STM a -> a -> STM ()
writeTQueue    = TQueue_ STM a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue
  isEmptyTQueue :: TQueue_ STM a -> STM Bool
isEmptyTQueue  = TQueue_ STM a -> STM Bool
forall a. TQueue a -> STM Bool
STM.isEmptyTQueue
  newTBQueue :: Natural -> STM (TBQueue_ STM a)
newTBQueue     = Natural -> STM (TBQueue_ STM a)
forall a. Natural -> STM (TBQueue a)
STM.newTBQueue
  readTBQueue :: TBQueue_ STM a -> STM a
readTBQueue    = TBQueue_ STM a -> STM a
forall a. TBQueue a -> STM a
STM.readTBQueue
  tryReadTBQueue :: TBQueue_ STM a -> STM (Maybe a)
tryReadTBQueue = TBQueue_ STM a -> STM (Maybe a)
forall a. TBQueue a -> STM (Maybe a)
STM.tryReadTBQueue
  writeTBQueue :: TBQueue_ STM a -> a -> STM ()
writeTBQueue   = TBQueue_ STM a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
STM.writeTBQueue
  lengthTBQueue :: TBQueue_ STM a -> STM Natural
lengthTBQueue  = TBQueue_ STM a -> STM Natural
forall a. TBQueue a -> STM Natural
STM.lengthTBQueue
  isEmptyTBQueue :: TBQueue_ STM a -> STM Bool
isEmptyTBQueue = TBQueue_ STM a -> STM Bool
forall a. TBQueue a -> STM Bool
STM.isEmptyTBQueue
  isFullTBQueue :: TBQueue_ STM a -> STM Bool
isFullTBQueue  = TBQueue_ STM a -> STM Bool
forall a. TBQueue a -> STM Bool
STM.isFullTBQueue


instance MonadSTM IO where
  type STM IO = STM.STM

  atomically :: STM IO a -> IO a
atomically = IO a -> IO a
forall a. HasCallStack => IO a -> IO a
wrapBlockedIndefinitely (IO a -> IO a) -> (STM a -> IO a) -> STM a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
STM.atomically

  newTVarIO :: a -> IO (TVar IO a)
newTVarIO       = a -> IO (TVar IO a)
forall a. a -> IO (TVar a)
STM.newTVarIO
  newTMVarIO :: a -> IO (TMVar IO a)
newTMVarIO      = a -> IO (TMVar IO a)
forall a. a -> IO (TMVar a)
STM.newTMVarIO
  newEmptyTMVarIO :: IO (TMVar IO a)
newEmptyTMVarIO = IO (TMVar IO a)
forall a. IO (TMVar a)
STM.newEmptyTMVarIO

-- | Wrapper around 'BlockedIndefinitelyOnSTM' that stores a call stack
data BlockedIndefinitely = BlockedIndefinitely {
      BlockedIndefinitely -> CallStack
blockedIndefinitelyCallStack :: CallStack
    , BlockedIndefinitely -> BlockedIndefinitelyOnSTM
blockedIndefinitelyException :: BlockedIndefinitelyOnSTM
    }
  deriving (Int -> BlockedIndefinitely -> ShowS
[BlockedIndefinitely] -> ShowS
BlockedIndefinitely -> String
(Int -> BlockedIndefinitely -> ShowS)
-> (BlockedIndefinitely -> String)
-> ([BlockedIndefinitely] -> ShowS)
-> Show BlockedIndefinitely
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockedIndefinitely] -> ShowS
$cshowList :: [BlockedIndefinitely] -> ShowS
show :: BlockedIndefinitely -> String
$cshow :: BlockedIndefinitely -> String
showsPrec :: Int -> BlockedIndefinitely -> ShowS
$cshowsPrec :: Int -> BlockedIndefinitely -> ShowS
Show)

instance Exception BlockedIndefinitely where
  displayException :: BlockedIndefinitely -> String
displayException (BlockedIndefinitely CallStack
cs BlockedIndefinitelyOnSTM
e) = [String] -> String
unlines [
        BlockedIndefinitelyOnSTM -> String
forall e. Exception e => e -> String
displayException BlockedIndefinitelyOnSTM
e
      , CallStack -> String
prettyCallStack CallStack
cs
      ]

wrapBlockedIndefinitely :: HasCallStack => IO a -> IO a
wrapBlockedIndefinitely :: IO a -> IO a
wrapBlockedIndefinitely = (BlockedIndefinitelyOnSTM -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (BlockedIndefinitely -> IO a
forall e a. Exception e => e -> IO a
throwIO (BlockedIndefinitely -> IO a)
-> (BlockedIndefinitelyOnSTM -> BlockedIndefinitely)
-> BlockedIndefinitelyOnSTM
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> BlockedIndefinitelyOnSTM -> BlockedIndefinitely
BlockedIndefinitely CallStack
HasCallStack => CallStack
callStack)

--
-- Lift to monad transformers
--

instance MonadSTM m => MonadSTM (ReaderT r m) where
  type STM (ReaderT r m) = STM m
  atomically :: STM (ReaderT r m) a -> ReaderT r m a
atomically      = m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a)
-> (STM m a -> m a) -> STM m a -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically
  newTVarIO :: a -> ReaderT r m (TVar (ReaderT r m) a)
newTVarIO       = m (TVar_ (STM m) a) -> ReaderT r m (TVar_ (STM m) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TVar_ (STM m) a) -> ReaderT r m (TVar_ (STM m) a))
-> (a -> m (TVar_ (STM m) a)) -> a -> ReaderT r m (TVar_ (STM m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (TVar_ (STM m) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarM
  newTMVarIO :: a -> ReaderT r m (TMVar (ReaderT r m) a)
newTMVarIO      = m (TMVar_ (STM m) a) -> ReaderT r m (TMVar_ (STM m) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (TMVar_ (STM m) a) -> ReaderT r m (TMVar_ (STM m) a))
-> (a -> m (TMVar_ (STM m) a))
-> a
-> ReaderT r m (TMVar_ (STM m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (TMVar_ (STM m) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
newTMVarM
  newEmptyTMVarIO :: ReaderT r m (TMVar (ReaderT r m) a)
newEmptyTMVarIO = m (TMVar_ (STM m) a) -> ReaderT r m (TMVar_ (STM m) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift   m (TMVar_ (STM m) a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
newEmptyTMVarM

--
-- Default TMVar implementation in terms of TVars (used by sim)
--

newtype TMVarDefault m a = TMVar (TVar m (Maybe a))

newTMVarDefault :: MonadSTM m => a -> STM m (TMVarDefault m a)
newTMVarDefault :: a -> STM m (TMVarDefault m a)
newTMVarDefault a
a = do
  TVar_ (STM m) (Maybe a)
t <- Maybe a -> STM m (TVar_ (STM m) (Maybe a))
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  TMVarDefault m a -> STM m (TMVarDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) (Maybe a) -> TMVarDefault m a
forall (m :: * -> *) a. TVar m (Maybe a) -> TMVarDefault m a
TMVar TVar_ (STM m) (Maybe a)
t)

newTMVarIODefault :: MonadSTM m => a -> m (TMVarDefault m a)
newTMVarIODefault :: a -> m (TMVarDefault m a)
newTMVarIODefault a
a = do
  TVar_ (STM m) (Maybe a)
t <- Maybe a -> m (TVar_ (STM m) (Maybe a))
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarM (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  TMVarDefault m a -> m (TMVarDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) (Maybe a) -> TMVarDefault m a
forall (m :: * -> *) a. TVar m (Maybe a) -> TMVarDefault m a
TMVar TVar_ (STM m) (Maybe a)
t)

newTMVarMDefault :: MonadSTM m => a -> m (TMVarDefault m a)
newTMVarMDefault :: a -> m (TMVarDefault m a)
newTMVarMDefault = a -> m (TMVarDefault m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVarDefault m a)
newTMVarIODefault
{-# DEPRECATED newTMVarMDefault "Use newTMVarIODefault" #-}

newEmptyTMVarDefault :: MonadSTM m => STM m (TMVarDefault m a)
newEmptyTMVarDefault :: STM m (TMVarDefault m a)
newEmptyTMVarDefault = do
  TVar_ (STM m) (Maybe a)
t <- Maybe a -> STM m (TVar_ (STM m) (Maybe a))
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar Maybe a
forall a. Maybe a
Nothing
  TMVarDefault m a -> STM m (TMVarDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) (Maybe a) -> TMVarDefault m a
forall (m :: * -> *) a. TVar m (Maybe a) -> TMVarDefault m a
TMVar TVar_ (STM m) (Maybe a)
t)

newEmptyTMVarIODefault :: MonadSTM m => m (TMVarDefault m a)
newEmptyTMVarIODefault :: m (TMVarDefault m a)
newEmptyTMVarIODefault = do
  TVar_ (STM m) (Maybe a)
t <- Maybe a -> m (TVar_ (STM m) (Maybe a))
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarM Maybe a
forall a. Maybe a
Nothing
  TMVarDefault m a -> m (TMVarDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) (Maybe a) -> TMVarDefault m a
forall (m :: * -> *) a. TVar m (Maybe a) -> TMVarDefault m a
TMVar TVar_ (STM m) (Maybe a)
t)

newEmptyTMVarMDefault :: MonadSTM m => m (TMVarDefault m a)
newEmptyTMVarMDefault :: m (TMVarDefault m a)
newEmptyTMVarMDefault = m (TMVarDefault m a)
forall (m :: * -> *) a. MonadSTM m => m (TMVarDefault m a)
newEmptyTMVarIODefault
{-# DEPRECATED newEmptyTMVarMDefault "Use newEmptyTMVarIODefault" #-}

takeTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m a
takeTMVarDefault :: TMVarDefault m a -> STM m a
takeTMVarDefault (TMVar TVar m (Maybe a)
t) = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> STM m a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
    Just a
a  -> do TVar m (Maybe a) -> Maybe a -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m (Maybe a)
t Maybe a
forall a. Maybe a
Nothing; a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

tryTakeTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m (Maybe a)
tryTakeTMVarDefault :: TMVarDefault m a -> STM m (Maybe a)
tryTakeTMVarDefault (TMVar TVar m (Maybe a)
t) = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just a
a  -> do TVar m (Maybe a) -> Maybe a -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m (Maybe a)
t Maybe a
forall a. Maybe a
Nothing; Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

putTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m ()
putTMVarDefault :: TMVarDefault m a -> a -> STM m ()
putTMVarDefault (TMVar TVar m (Maybe a)
t) a
a = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> do TVar m (Maybe a) -> Maybe a -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
a); () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just a
_  -> STM m ()
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry

tryPutTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m Bool
tryPutTMVarDefault :: TMVarDefault m a -> a -> STM m Bool
tryPutTMVarDefault (TMVar TVar m (Maybe a)
t) a
a = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> do TVar m (Maybe a) -> Maybe a -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
a); Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just a
_  -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

readTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m a
readTMVarDefault :: TMVarDefault m a -> STM m a
readTMVarDefault (TMVar TVar m (Maybe a)
t) = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> STM m a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
    Just a
a  -> a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

tryReadTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m (Maybe a)
tryReadTMVarDefault :: TMVarDefault m a -> STM m (Maybe a)
tryReadTMVarDefault (TMVar TVar m (Maybe a)
t) = TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t

swapTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m a
swapTMVarDefault :: TMVarDefault m a -> a -> STM m a
swapTMVarDefault (TMVar TVar m (Maybe a)
t) a
new = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing  -> STM m a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
    Just a
old -> do TVar m (Maybe a) -> Maybe a -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
new); a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
old

isEmptyTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m Bool
isEmptyTMVarDefault :: TMVarDefault m a -> STM m Bool
isEmptyTMVarDefault (TMVar TVar m (Maybe a)
t) = do
  Maybe a
m <- TVar m (Maybe a) -> STM m (Maybe a)
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just a
_  -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

--
-- Default TQueue implementation in terms of TVars (used by sim)
--

data TQueueDefault m a = TQueue !(TVar m [a])
                                !(TVar m [a])

newTQueueDefault :: MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault :: STM m (TQueueDefault m a)
newTQueueDefault = do
  TVar_ (STM m) [a]
read  <- [a] -> STM m (TVar_ (STM m) [a])
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar []
  TVar_ (STM m) [a]
write <- [a] -> STM m (TVar_ (STM m) [a])
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar []
  TQueueDefault m a -> STM m (TQueueDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) [a] -> TVar_ (STM m) [a] -> TQueueDefault m a
forall (m :: * -> *) a.
TVar m [a] -> TVar m [a] -> TQueueDefault m a
TQueue TVar_ (STM m) [a]
read TVar_ (STM m) [a]
write)

writeTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
writeTQueueDefault :: TQueueDefault m a -> a -> STM m ()
writeTQueueDefault (TQueue TVar m [a]
_read TVar m [a]
write) a
a = do
  [a]
listend <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
  TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
write (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
listend)

readTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a
readTQueueDefault :: 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 (stm :: * -> *) a. MonadSTMTx stm => stm a
retry 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.
MonadSTMTx (STM m) =>
TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault TQueueDefault m a
queue

tryReadTQueueDefault :: MonadSTMTx (STM m) => TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault :: TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault (TQueue TVar m [a]
read TVar m [a]
write) = do
  [a]
xs <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
read
  case [a]
xs of
    (a
x:[a]
xs') -> do
      TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
read [a]
xs'
      Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    [] -> do
      [a]
ys <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
      case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys of
        []     -> Maybe a -> STM m (Maybe 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] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
write []
          TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
read [a]
zs
          Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
z)

isEmptyTQueueDefault :: MonadSTMTx (STM m) => TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault :: TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault (TQueue TVar m [a]
read TVar m [a]
write) = do
  [a]
xs <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
read
  case [a]
xs of
    (a
_:[a]
_) -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [] -> do [a]
ys <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
             case [a]
ys of
               [] -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               [a]
_  -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

data TBQueueDefault m a = TBQueue
  !(TVar m Natural) -- read capacity
  !(TVar m [a])     -- elements waiting for read
  !(TVar m Natural) -- write capacity
  !(TVar m [a])     -- written elements
  !Natural

newTBQueueDefault :: MonadSTM m => Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault :: Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault Natural
size = do
  TVar_ (STM m) Natural
rsize <- Natural -> STM m (TVar_ (STM m) Natural)
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar Natural
0
  TVar_ (STM m) [a]
read  <- [a] -> STM m (TVar_ (STM m) [a])
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar []
  TVar_ (STM m) Natural
wsize <- Natural -> STM m (TVar_ (STM m) Natural)
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar Natural
size
  TVar_ (STM m) [a]
write <- [a] -> STM m (TVar_ (STM m) [a])
forall (stm :: * -> *) a. MonadSTMTx stm => a -> stm (TVar_ stm a)
newTVar []
  TBQueueDefault m a -> STM m (TBQueueDefault m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar_ (STM m) Natural
-> TVar_ (STM m) [a]
-> TVar_ (STM m) Natural
-> TVar_ (STM m) [a]
-> Natural
-> TBQueueDefault m a
forall (m :: * -> *) a.
TVar m Natural
-> TVar m [a]
-> TVar m Natural
-> TVar m [a]
-> Natural
-> TBQueueDefault m a
TBQueue TVar_ (STM m) Natural
rsize TVar_ (STM m) [a]
read TVar_ (STM m) Natural
wsize TVar_ (STM m) [a]
write Natural
size)

readTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a
readTBQueueDefault :: 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 (stm :: * -> *) a. MonadSTMTx stm => stm a
retry 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.
MonadSTMTx (STM m) =>
TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault TBQueueDefault m a
queue

tryReadTBQueueDefault :: MonadSTMTx (STM m) => TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault :: TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault (TBQueue TVar m Natural
rsize TVar m [a]
read TVar m Natural
_wsize TVar m [a]
write Natural
_size) = do
  [a]
xs <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
read
  Natural
r <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
rsize
  TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
rsize (Natural -> STM m ()) -> Natural -> STM m ()
forall a b. (a -> b) -> a -> b
$! 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] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
read [a]
xs'
      Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    [] -> do
      [a]
ys <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
      case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys of
        [] -> Maybe a -> STM m (Maybe 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] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
write []
          TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
read [a]
zs
          Maybe a -> STM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
z)

writeTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault :: TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault (TBQueue TVar m Natural
rsize TVar m [a]
_read TVar m Natural
wsize TVar m [a]
write Natural
_size) a
a = do
  Natural
w <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
wsize
  if (Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
    then do TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
wsize (Natural -> STM m ()) -> Natural -> STM m ()
forall a b. (a -> b) -> a -> b
$! Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
    else do
          Natural
r <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
rsize
          if (Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
            then do TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
rsize Natural
0
                    TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
wsize (Natural -> STM m ()) -> Natural -> STM m ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
            else STM m ()
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
  [a]
listend <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
  TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
write (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
listend)

isEmptyTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault :: TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault (TBQueue TVar m Natural
_rsize TVar m [a]
read TVar m Natural
_wsize TVar m [a]
write Natural
_size) = do
  [a]
xs <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
read
  case [a]
xs of
    (a
_:[a]
_) -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [] -> do [a]
ys <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
             case [a]
ys of
               [] -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               [a]
_  -> Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isFullTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault :: TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault (TBQueue TVar m Natural
rsize TVar m [a]
_read TVar m Natural
wsize TVar m [a]
_write Natural
_size) = do
  Natural
w <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
wsize
  if (Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
     then Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
     else do
         Natural
r <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
rsize
         if (Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0)
            then Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            else Bool -> STM m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

lengthTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault :: TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault (TBQueue TVar m Natural
rsize TVar m [a]
_read TVar m Natural
wsize TVar m [a]
_write Natural
size) = do
  Natural
r <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
rsize
  Natural
w <- TVar m Natural -> STM m Natural
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m Natural
wsize
  Natural -> STM m Natural
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 :: TBQueueDefault m a -> STM m [a]
flushTBQueueDefault (TBQueue TVar m Natural
rsize TVar m [a]
read TVar m Natural
wsize TVar m [a]
write Natural
size) = do
  [a]
xs <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
read
  [a]
ys <- TVar m [a] -> STM m [a]
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar m [a]
write
  if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
    then [a] -> STM m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
read []
      TVar m [a] -> [a] -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m [a]
write []
      TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
rsize Natural
0
      TVar m Natural -> Natural -> STM m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar m Natural
wsize Natural
size
      [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)


-- | 'throwIO' specialised to @stm@ monad.
--
throwSTM :: (MonadSTMTx stm, MonadThrow.MonadThrow stm, Exception e)
         => e -> stm a
throwSTM :: e -> stm a
throwSTM = e -> stm a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MonadThrow.throwIO


-- | 'catch' speclialized for an @stm@ monad.
--
catchSTM :: (MonadSTMTx stm, MonadThrow.MonadCatch stm, Exception e)
         => stm a -> (e -> stm a) -> stm a
catchSTM :: stm a -> (e -> stm a) -> stm a
catchSTM = stm a -> (e -> stm a) -> stm a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MonadThrow.catch