{-# LANGUAGE FlexibleInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | 'StrictTVar's with 'NoThunks' invariants.
--
-- Custom invariants can still be specified in addition to the default
-- 'NoThunks' invariant. See 'newTVarWithInvariant' and
-- 'newTVarWithInvariantIO'.
--
-- Use the @checktvarinvariants@ cabal flag from the @strict-checked-vars@
-- package to enable or disable invariant checks at compile time.
--
-- The exports of this module (should) mirror the exports of the
-- "Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked" module from the
-- @strict-checked-vars@ package.
module Ouroboros.Consensus.Util.NormalForm.StrictTVar (
    -- * StrictTVar
    newTVar
  , newTVarIO
  , newTVarWithInvariant
  , newTVarWithInvariantIO
    -- * Invariant
  , noThunksInvariant
    -- * Unchecked
  , uncheckedNewTVarM
    -- * Re-exports
  , module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked
  ) where

import           Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding
                     (checkInvariant, newTVar, newTVarIO, newTVarWithInvariant,
                     newTVarWithInvariantIO)
import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as Checked
import           Control.Monad.Class.MonadSTM as StrictSTM
import           GHC.Stack
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Util.NormalForm.StrictMVar
                     (noThunksInvariant)

{-------------------------------------------------------------------------------
  StrictTVar
-------------------------------------------------------------------------------}

-- | Create a 'StrictTVar' with a 'NoThunks' invariant.
newTVar :: (HasCallStack, MonadSTM m, NoThunks a) => a -> STM m (StrictTVar m a)
newTVar :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> STM m (StrictTVar m a)
newTVar = (a -> Maybe String) -> a -> STM m (StrictTVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> STM m (StrictTVar m a)
Checked.newTVarWithInvariant a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant

-- | Create an 'StrictTVar' with a 'NoThunks' invariant.
newTVarIO :: (HasCallStack, MonadSTM m, NoThunks a) => a -> m (StrictTVar m a)
newTVarIO :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO = (a -> Maybe String) -> a -> m (StrictTVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> m (StrictTVar m a)
Checked.newTVarWithInvariantIO a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant

-- | Create a 'StrictTVar' with a custom invariant /and/ a 'NoThunks' invariant.
--
-- When both the custom and 'NoThunks' invariants are broken, only the error
-- related to the custom invariant is reported.
newTVarWithInvariant ::
     (HasCallStack, MonadSTM m, NoThunks a)
  => (a -> Maybe String)
  -> a
  -> STM m (StrictTVar m a)
newTVarWithInvariant :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
(a -> Maybe String) -> a -> STM m (StrictTVar m a)
newTVarWithInvariant a -> Maybe String
inv =
    (a -> Maybe String) -> a -> STM m (StrictTVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> STM m (StrictTVar m a)
Checked.newTVarWithInvariant (\a
x -> a -> Maybe String
inv a
x Maybe String -> Maybe String -> Maybe String
forall a. Semigroup a => a -> a -> a
<> a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant a
x)

-- | Create a 'StrictTVar' with a custom invariant /and/ a 'NoThunks' invariant.
--
-- When both the custom and 'NoThunks' invariants are broken, only the error
-- related to the custom invariant is reported.
newTVarWithInvariantIO ::
     (HasCallStack, MonadSTM m, NoThunks a)
  => (a -> Maybe String)
  -> a
  -> m (StrictTVar m a)
newTVarWithInvariantIO :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
(a -> Maybe String) -> a -> m (StrictTVar m a)
newTVarWithInvariantIO a -> Maybe String
inv =
    (a -> Maybe String) -> a -> m (StrictTVar m a)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> m (StrictTVar m a)
Checked.newTVarWithInvariantIO (\a
x -> a -> Maybe String
inv a
x Maybe String -> Maybe String -> Maybe String
forall a. Semigroup a => a -> a -> a
<> a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant a
x)

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

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

{-------------------------------------------------------------------------------
  Unchecked
-------------------------------------------------------------------------------}

-- | Like 'newTVarIO', but without a 'NoThunks' invariant.
uncheckedNewTVarM :: MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM :: forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM = a -> m (StrictTVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
Checked.newTVarIO