{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Ouroboros.Consensus.Util.MonadSTM.StrictSVar
  ( castStrictSVar
  , isEmptySVar
  , modifySVar
  , modifySVar_
  , newEmptySVar
  , newEmptySVarWithInvariant
  , newSVar
  , newSVarWithInvariant
  , putSVar
  , readSVar
  , readSVarSTM
  , swapSVar
  , takeSVar
  , tryPutSVar
  , tryReadSVar
  , tryTakeSVar
  , updateSVar
  , updateSVar_

    -- * constructors exported for benefit of tests
  , StrictSVar (..)
  ) where

import Control.Concurrent.Class.MonadSTM
import qualified Control.Concurrent.Class.MonadSTM as Lazy
import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked
  ( checkInvariant
  )
import Control.Monad (when)
import Control.Monad.Class.MonadThrow
  ( ExitCase (..)
  , MonadCatch
  , generalBracket
  )
import GHC.Stack
import NoThunks.Class (NoThunks (..))

{-------------------------------------------------------------------------------
  Strict SVar
-------------------------------------------------------------------------------}

-- | Strict SVar (modelled using a lazy 'Lazy.TMVar' under the hood)
--
-- The 'StrictSVar' API is slightly stronger than the usual 'SVar' one, as we
-- offer a primitive to read the value of the SVar even if it is empty (in which
-- case we will return the oldest known stale one). See 'readSVarSTM'.
--
-- There is a weaker invariant for a 'StrictSVar' than for a 'StrictTVar':
-- although all functions that modify the 'StrictSVar' check the invariant, we
-- do /not/ guarantee that the value inside the 'StrictSVar' always satisfies
-- the invariant. Instead, we /do/ guarantee that if the 'StrictSVar' is updated
-- with a value that does not satisfy the invariant, an exception is thrown. The
-- reason for this weaker guarantee is that leaving an 'SVar' empty can lead to
-- very hard to debug "blocked indefinitely" problems.
--
-- This is also the reason we do not offer support for an invariant in
-- 'StrictTMVar': if we throw an exception from an STM transaction, the STM
-- transaction is not executed, and so we would not even be able to provide the
-- weaker guarantee that we provide for 'StrictSVar'.
data StrictSVar m a = StrictSVar
  { forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
invariant :: !(a -> Maybe String)
  -- ^ Invariant checked whenever updating the 'StrictSVar'.
  , forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: !(Lazy.TMVar m a)
  -- ^ The main TMVar supporting this 'StrictSVar'
  , forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: !(Lazy.TVar m a)
  -- ^ TVar for supporting 'readSVarSTM'
  --
  -- This TVar is always kept up to date with the 'Lazy.TMVar', but holds on
  -- the old value of the 'Lazy.TMVar' when it is empty. This is very useful
  -- to support single writer/many reader scenarios.
  --
  -- NOTE: We should always update the 'tmvar' before the 'tvar' so that if
  -- the update to the 'tmvar' fails, the 'tvar is left unchanged.
  }

castStrictSVar ::
  ( Lazy.TMVar m ~ Lazy.TMVar n
  , Lazy.TVar m ~ Lazy.TVar n
  ) =>
  StrictSVar m a -> StrictSVar n a
castStrictSVar :: forall (m :: * -> *) (n :: * -> *) a.
(TMVar m ~ TMVar n, TVar m ~ TVar n) =>
StrictSVar m a -> StrictSVar n a
castStrictSVar StrictSVar{TVar m a
TMVar m a
a -> Maybe String
invariant :: forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
invariant :: a -> Maybe String
tmvar :: TMVar m a
tvar :: TVar m a
..} = StrictSVar{TVar m a
TVar n a
TMVar m a
TMVar n a
a -> Maybe String
invariant :: a -> Maybe String
tmvar :: TMVar n a
tvar :: TVar n a
invariant :: a -> Maybe String
tmvar :: TMVar m a
tvar :: TVar m a
..}

newSVar :: MonadSTM m => a -> m (StrictSVar m a)
newSVar :: forall (m :: * -> *) a. MonadSTM m => a -> m (StrictSVar m a)
newSVar = (a -> Maybe String) -> a -> m (StrictSVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> m (StrictSVar m a)
newSVarWithInvariant (Maybe String -> a -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing)

newSVarWithInvariant ::
  (MonadSTM m, HasCallStack) =>
  -- | Invariant (expect 'Nothing')
  (a -> Maybe String) ->
  a ->
  m (StrictSVar m a)
newSVarWithInvariant :: forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> m (StrictSVar m a)
newSVarWithInvariant a -> Maybe String
invariant !a
a =
  Maybe String -> m (StrictSVar m a) -> m (StrictSVar m a)
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (a -> Maybe String
invariant a
a) (m (StrictSVar m a) -> m (StrictSVar m a))
-> m (StrictSVar m a) -> m (StrictSVar m a)
forall a b. (a -> b) -> a -> b
$
    (a -> Maybe String) -> TMVar m a -> TVar m a -> StrictSVar m a
forall (m :: * -> *) a.
(a -> Maybe String) -> TMVar m a -> TVar m a -> StrictSVar m a
StrictSVar a -> Maybe String
invariant (TMVar m a -> TVar m a -> StrictSVar m a)
-> m (TMVar m a) -> m (TVar m a -> StrictSVar m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (TMVar m a)
forall a. a -> m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVar m a)
Lazy.newTMVarIO a
a m (TVar m a -> StrictSVar m a)
-> m (TVar m a) -> m (StrictSVar m a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m (TVar m a)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
Lazy.newTVarIO a
a

newEmptySVar :: MonadSTM m => a -> m (StrictSVar m a)
newEmptySVar :: forall (m :: * -> *) a. MonadSTM m => a -> m (StrictSVar m a)
newEmptySVar = (a -> Maybe String) -> a -> m (StrictSVar m a)
forall (m :: * -> *) a.
MonadSTM m =>
(a -> Maybe String) -> a -> m (StrictSVar m a)
newEmptySVarWithInvariant (Maybe String -> a -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing)

-- | Create an initially empty 'StrictSVar'
--
-- NOTE: Since 'readSVarSTM' allows to read the 'StrictSVar' even when it is
-- empty, we need an initial value of @a@ even though the 'StrictSVar' starts
-- out empty. However, we are /NOT/ strict in this value, to allow it to be
-- @error@.
newEmptySVarWithInvariant ::
  MonadSTM m =>
  -- | Invariant (expect 'Nothing')
  (a -> Maybe String) ->
  -- | The initial stale value
  a ->
  m (StrictSVar m a)
newEmptySVarWithInvariant :: forall (m :: * -> *) a.
MonadSTM m =>
(a -> Maybe String) -> a -> m (StrictSVar m a)
newEmptySVarWithInvariant a -> Maybe String
invariant a
stale =
  (a -> Maybe String) -> TMVar m a -> TVar m a -> StrictSVar m a
forall (m :: * -> *) a.
(a -> Maybe String) -> TMVar m a -> TVar m a -> StrictSVar m a
StrictSVar a -> Maybe String
invariant (TMVar m a -> TVar m a -> StrictSVar m a)
-> m (TMVar m a) -> m (TVar m a -> StrictSVar m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (TMVar m a)
forall a. m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
Lazy.newEmptyTMVarIO m (TVar m a -> StrictSVar m a)
-> m (TVar m a) -> m (StrictSVar m a)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m (TVar m a)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
Lazy.newTVarIO a
stale

takeSVar :: MonadSTM m => StrictSVar m a -> m a
takeSVar :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m a
takeSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar} = 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 (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ TMVar m a -> STM m a
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
Lazy.takeTMVar TMVar m a
tmvar

tryTakeSVar :: MonadSTM m => StrictSVar m a -> m (Maybe a)
tryTakeSVar :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m (Maybe a)
tryTakeSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar} = 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
$ TMVar m a -> STM m (Maybe a)
forall a. TMVar m a -> STM m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m (Maybe a)
Lazy.tryTakeTMVar TMVar m a
tmvar

putSVar :: (MonadSTM m, HasCallStack) => StrictSVar m a -> a -> m ()
putSVar :: forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m ()
putSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar, TVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar m a
tvar, a -> Maybe String
invariant :: forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
invariant :: a -> Maybe String
invariant} !a
a = 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
    TMVar m a -> a -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
Lazy.putTMVar TMVar m a
tmvar a
a
    TVar m a -> a -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
Lazy.writeTVar TVar m a
tvar a
a
  Maybe String -> m () -> m ()
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (a -> Maybe String
invariant a
a) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

tryPutSVar :: (MonadSTM m, HasCallStack) => StrictSVar m a -> a -> m Bool
tryPutSVar :: forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m Bool
tryPutSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar, TVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar m a
tvar, a -> Maybe String
invariant :: forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
invariant :: a -> Maybe String
invariant} !a
a = do
  didPut <- 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
    didPut <- TMVar m a -> a -> STM m Bool
forall a. TMVar m a -> a -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m Bool
Lazy.tryPutTMVar TMVar m a
tmvar a
a
    when didPut $ Lazy.writeTVar tvar a
    return didPut
  checkInvariant (invariant a) $ return didPut

readSVar :: MonadSTM m => StrictSVar m a -> m a
readSVar :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m a
readSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar} = 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 (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ TMVar m a -> STM m a
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
Lazy.readTMVar TMVar m a
tmvar

tryReadSVar :: MonadSTM m => StrictSVar m a -> m (Maybe a)
tryReadSVar :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m (Maybe a)
tryReadSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar} = 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
$ TMVar m a -> STM m (Maybe a)
forall a. TMVar m a -> STM m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m (Maybe a)
Lazy.tryReadTMVar TMVar m a
tmvar

-- | Read the possibly-stale value of the @SVar@
--
-- Will return the current value of the @SVar@ if it non-empty, or the last
-- known value otherwise.
readSVarSTM :: MonadSTM m => StrictSVar m a -> STM m a
readSVarSTM :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> STM m a
readSVarSTM StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar, TVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar m a
tvar} = do
  ma <- TMVar m a -> STM m (Maybe a)
forall a. TMVar m a -> STM m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m (Maybe a)
Lazy.tryReadTMVar TMVar m a
tmvar
  case ma of
    Just a
a -> a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Maybe a
Nothing -> TVar m a -> STM m a
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
Lazy.readTVar TVar m a
tvar

-- | Swap value of a 'StrictSVar'
--
-- NOTE: Since swapping the value can't leave the 'StrictSVar' empty, we
-- /could/ check the invariant first and only then swap. We nonetheless swap
-- first and check the invariant after to keep the semantics the same with
-- 'putSVar', otherwise it will be difficult to understand when a 'StrictSVar'
-- is updated and when it is not.
swapSVar :: (MonadSTM m, HasCallStack) => StrictSVar m a -> a -> m a
swapSVar :: forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m a
swapSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar, TVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar m a
tvar, a -> Maybe String
invariant :: forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
invariant :: a -> Maybe String
invariant} !a
a = do
  oldValue <- 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 (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ do
    oldValue <- TMVar m a -> a -> STM m a
forall a. TMVar m a -> a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m a
Lazy.swapTMVar TMVar m a
tmvar a
a
    Lazy.writeTVar tvar a
    return oldValue
  checkInvariant (invariant a) $ return oldValue

isEmptySVar :: MonadSTM m => StrictSVar m a -> m Bool
isEmptySVar :: forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m Bool
isEmptySVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar} = 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
$ TMVar m a -> STM m Bool
forall a. TMVar m a -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m Bool
Lazy.isEmptyTMVar TMVar m a
tmvar

updateSVar :: (MonadSTM m, HasCallStack) => StrictSVar m a -> (a -> (a, b)) -> m b
updateSVar :: forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> (a -> (a, b)) -> m b
updateSVar StrictSVar{TMVar m a
tmvar :: forall (m :: * -> *) a. StrictSVar m a -> TMVar m a
tmvar :: TMVar m a
tmvar, TVar m a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar m a
tvar, a -> Maybe String
invariant :: forall (m :: * -> *) a. StrictSVar m a -> a -> Maybe String
invariant :: a -> Maybe String
invariant} a -> (a, b)
f = do
  -- it's not unreasonable to assume that forcing !(!a', b) inside the
  -- atomically block will force the new value before putting it into the
  -- SVar, but although the value in the tuple is forced, there's actually
  -- a thin closure constructed that just points to the forced value which
  -- is what GHC returns in the constructed tuple (so it is actually a thunk,
  -- albeit a trivial one!). in order to ensure that we're forcing the value
  -- inside the SVar before calling checkInvariant, we need an additional
  -- bang outside the atomically block, which will correctly force a' before
  -- checkInvariant looks to see if it's been evaluated or not. without this
  -- change, it's possible to put a lazy value inside a StrictSVar (though
  -- it's unlikely to occur in production environments because this
  -- intermediate unforced closure is optimized away at -O1 and above).
  (!a', b) <- STM m (a, b) -> m (a, b)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (a, b) -> m (a, b)) -> STM m (a, b) -> m (a, b)
forall a b. (a -> b) -> a -> b
$ do
    a <- TMVar m a -> STM m a
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
Lazy.takeTMVar TMVar m a
tmvar
    let !(!a', b) = f a
    Lazy.putTMVar tmvar a'
    Lazy.writeTVar tvar a'
    -- To exactly see what we mean, compile this module with `-ddump-stg-final`
    -- and look for the definition of the closure that is placed as the first
    -- item in the tuple returned here
    return (a', b)
  checkInvariant (invariant a') $ return b

updateSVar_ :: (MonadSTM m, HasCallStack) => StrictSVar m a -> (a -> a) -> m ()
updateSVar_ :: forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> (a -> a) -> m ()
updateSVar_ StrictSVar m a
var a -> a
f = StrictSVar m a -> (a -> (a, ())) -> m ()
forall (m :: * -> *) a b.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> (a -> (a, b)) -> m b
updateSVar StrictSVar m a
var ((,()) (a -> (a, ())) -> (a -> a) -> a -> (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)

modifySVar ::
  (MonadSTM m, MonadCatch m, HasCallStack) =>
  StrictSVar m a -> (a -> m (a, b)) -> m b
modifySVar :: forall (m :: * -> *) a b.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictSVar m a -> (a -> m (a, b)) -> m b
modifySVar StrictSVar m a
var a -> m (a, b)
action =
  (a, b) -> b
forall a b. (a, b) -> b
snd ((a, b) -> b) -> (((a, b), ()) -> (a, b)) -> ((a, b), ()) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b), ()) -> (a, b)
forall a b. (a, b) -> a
fst (((a, b), ()) -> b) -> m ((a, b), ()) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
-> (a -> ExitCase (a, b) -> m ())
-> (a -> m (a, b))
-> m ((a, b), ())
forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket (StrictSVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => StrictSVar m a -> m a
takeSVar StrictSVar m a
var) a -> ExitCase (a, b) -> m ()
putBack a -> m (a, b)
action
 where
  putBack :: a -> ExitCase (a, b) -> m ()
putBack a
a ExitCase (a, b)
ec = case ExitCase (a, b)
ec of
    ExitCaseSuccess (a
a', b
_) -> StrictSVar m a -> a -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m ()
putSVar StrictSVar m a
var a
a'
    ExitCaseException SomeException
_ex -> StrictSVar m a -> a -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m ()
putSVar StrictSVar m a
var a
a
    ExitCase (a, b)
ExitCaseAbort -> StrictSVar m a -> a -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictSVar m a -> a -> m ()
putSVar StrictSVar m a
var a
a

modifySVar_ ::
  (MonadSTM m, MonadCatch m, HasCallStack) =>
  StrictSVar m a -> (a -> m a) -> m ()
modifySVar_ :: forall (m :: * -> *) a.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictSVar m a -> (a -> m a) -> m ()
modifySVar_ StrictSVar m a
var a -> m a
action = StrictSVar m a -> (a -> m (a, ())) -> m ()
forall (m :: * -> *) a b.
(MonadSTM m, MonadCatch m, HasCallStack) =>
StrictSVar m a -> (a -> m (a, b)) -> m b
modifySVar StrictSVar m a
var ((a -> (a, ())) -> m a -> m (a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) (m a -> m (a, ())) -> (a -> m a) -> a -> m (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
action)

{-------------------------------------------------------------------------------
  NoThunks
-------------------------------------------------------------------------------}

instance NoThunks a => NoThunks (StrictSVar IO a) where
  showTypeOf :: Proxy (StrictSVar IO a) -> String
showTypeOf Proxy (StrictSVar IO a)
_ = String
"StrictSVar IO"
  wNoThunks :: Context -> StrictSVar IO a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt StrictSVar{TVar IO a
tvar :: forall (m :: * -> *) a. StrictSVar m a -> TVar m a
tvar :: TVar IO a
tvar} = do
    -- We can't use @atomically $ readTVar ..@ here, as that will lead to a
    -- "Control.Concurrent.STM.atomically was nested" exception.
    a <- TVar IO a -> IO a
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar IO a
tvar
    noThunks ctxt a