{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | 'StrictMVar's with 'NoThunks' invariants.
--
-- Custom invariants can still be specified in addition to the default
-- 'NoThunks' invariant. See 'newMVarWithInvariant' and
-- 'newEmptyMVarWithInvariant'.
--
-- Use the @checkmvarinvariants@ 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.MonadMVar.Strict.Checked" module from the
-- @strict-checked-vars@ package.
module Ouroboros.Consensus.Util.NormalForm.StrictMVar (
    -- * StrictMVar
    newEmptyMVar
  , newEmptyMVarWithInvariant
  , newMVar
  , newMVarWithInvariant
    -- * Invariant
  , noThunksInvariant
    -- * Unchecked
  , uncheckedNewEmptyMVar
  , uncheckedNewMVar
    -- * Re-exports
  , module Control.Concurrent.Class.MonadMVar.Strict.Checked
  ) where

import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict
import           Control.Concurrent.Class.MonadMVar.Strict.Checked hiding
                     (newEmptyMVar, newEmptyMVarWithInvariant, newMVar,
                     newMVarWithInvariant)
import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (NoThunks (..), unsafeNoThunks)

{-------------------------------------------------------------------------------
  StrictMVar
-------------------------------------------------------------------------------}

-- | Create a 'StrictMVar' with a 'NoThunks' invariant.
newMVar :: (HasCallStack, MonadMVar m, NoThunks a) => a -> m (StrictMVar m a)
newMVar :: forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar = (a -> Maybe String) -> a -> m (StrictMVar m a)
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
(a -> Maybe String) -> a -> m (StrictMVar m a)
Checked.newMVarWithInvariant a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant

-- | Create an empty 'StrictMVar' with a 'NoThunks' invariant.
newEmptyMVar :: (MonadMVar m, NoThunks a) => m (StrictMVar m a)
newEmptyMVar :: forall (m :: * -> *) a.
(MonadMVar m, NoThunks a) =>
m (StrictMVar m a)
newEmptyMVar = (a -> Maybe String) -> m (StrictMVar m a)
forall (m :: * -> *) a.
MonadMVar m =>
(a -> Maybe String) -> m (StrictMVar m a)
Checked.newEmptyMVarWithInvariant a -> Maybe String
forall a. NoThunks a => a -> Maybe String
noThunksInvariant

-- | Create a 'StrictMVar' 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.
newMVarWithInvariant ::
     (HasCallStack, MonadMVar m, NoThunks a)
  => (a -> Maybe String)
  -> a
  -> m (StrictMVar m a)
newMVarWithInvariant :: forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
(a -> Maybe String) -> a -> m (StrictMVar m a)
newMVarWithInvariant a -> Maybe String
inv =
    (a -> Maybe String) -> a -> m (StrictMVar m a)
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
(a -> Maybe String) -> a -> m (StrictMVar m a)
Checked.newMVarWithInvariant (\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 an empty 'StrictMVar' 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.
newEmptyMVarWithInvariant ::
     (MonadMVar m, NoThunks a)
  => (a -> Maybe String)
  -> m (StrictMVar m a)
newEmptyMVarWithInvariant :: forall (m :: * -> *) a.
(MonadMVar m, NoThunks a) =>
(a -> Maybe String) -> m (StrictMVar m a)
newEmptyMVarWithInvariant a -> Maybe String
inv =
    (a -> Maybe String) -> m (StrictMVar m a)
forall (m :: * -> *) a.
MonadMVar m =>
(a -> Maybe String) -> m (StrictMVar m a)
Checked.newEmptyMVarWithInvariant (\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)

{-------------------------------------------------------------------------------
  Invariant
-------------------------------------------------------------------------------}

noThunksInvariant :: NoThunks a => a -> Maybe String
noThunksInvariant :: forall a. NoThunks a => a -> Maybe String
noThunksInvariant = (ThunkInfo -> String) -> Maybe ThunkInfo -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThunkInfo -> String
forall a. Show a => a -> String
show (Maybe ThunkInfo -> Maybe String)
-> (a -> Maybe ThunkInfo) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks

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

instance NoThunks (Strict.StrictMVar IO a) => NoThunks (StrictMVar IO a) where
  showTypeOf :: Proxy (StrictMVar IO a) -> String
showTypeOf Proxy (StrictMVar IO a)
_ = String
"StrictMVar IO"
  wNoThunks :: Context -> StrictMVar IO a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt StrictMVar IO a
mvar = Context -> StrictMVar IO a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (StrictMVar IO a -> StrictMVar IO a
forall (m :: * -> *) a. StrictMVar m a -> StrictMVar m a
Checked.unsafeToUncheckedStrictMVar StrictMVar IO a
mvar)

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

-- | Like 'newMVar', but without a 'NoThunks' invariant.
uncheckedNewMVar :: MonadMVar m => a -> m (StrictMVar m a)
uncheckedNewMVar :: forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
uncheckedNewMVar = a -> m (StrictMVar m a)
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
Checked.newMVar

-- | Like 'newEmptyMVar', but without a 'NoThunks' invariant.
uncheckedNewEmptyMVar :: MonadMVar m => m (StrictMVar m a)
uncheckedNewEmptyMVar :: forall (m :: * -> *) a. MonadMVar m => m (StrictMVar m a)
uncheckedNewEmptyMVar = m (StrictMVar m a)
forall (m :: * -> *) a. MonadMVar m => m (StrictMVar m a)
Checked.newEmptyMVar