{-# 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)
                     => (a -> Maybe String)  -- ^ Invariant (expect 'Nothing')
                     -> 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
                          => (a -> Maybe String)  -- ^ Invariant (expect 'Nothing')
                          -> a                    -- ^ The initial stale value
                          -> 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
    Bool
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
        Bool
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
        Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
didPut (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ 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
        Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
didPut
    Maybe String -> m Bool -> m Bool
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (a -> Maybe String
invariant a
a) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
    Maybe a
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 Maybe a
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
    a
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
        a
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
        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
        a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
oldValue
    Maybe String -> m a -> m a
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (a -> Maybe String
invariant a
a) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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
a', b
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
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
a', b
b) = a -> (a, b)
f a
a
        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'
        -- 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
        (a, b) -> STM m (a, b)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a', b
b)
    Maybe String -> m b -> m b
forall a. HasCallStack => Maybe String -> a -> a
checkInvariant (a -> Maybe String
invariant a
a') (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
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
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
      Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt a
a