{-# LANGUAGE BangPatterns   #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies   #-}
{-# LANGUAGE TypeOperators  #-}

-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package
--
module Control.Concurrent.Class.MonadSTM.Strict.TVar
  ( -- * StrictTVar
    StrictTVar
  , LazyTVar
  , toLazyTVar
  , fromLazyTVar
  , castStrictTVar
  , newTVar
  , newTVarIO
  , readTVar
  , readTVarIO
  , writeTVar
  , modifyTVar
  , stateTVar
  , swapTVar
  , check
    -- * MonadLabelSTM
  , labelTVar
  , labelTVarIO
    -- * MonadTraceSTM
  , traceTVar
  , traceTVarIO
  ) where

import Control.Concurrent.Class.MonadSTM.TVar qualified as Lazy
import Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO)

type LazyTVar m = Lazy.TVar m

newtype StrictTVar m a = StrictTVar {
    forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
  }

labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m ()
labelTVar :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar { LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar } = LazyTVar m a -> String -> STM m ()
forall a. TVar m a -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
TVar m a -> String -> STM m ()
Lazy.labelTVar LazyTVar m a
tvar

labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m ()
labelTVarIO :: forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> m ()
labelTVarIO StrictTVar m a
v = 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 ()) -> (String -> STM m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m a -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m a
v

traceTVar :: MonadTraceSTM m
          => proxy m
          -> StrictTVar m a
          -> (Maybe a -> a -> InspectMonad m TraceValue)
          -> STM m ()
traceTVar :: forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> StrictTVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
traceTVar proxy m
p StrictTVar {LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar} = proxy m
-> LazyTVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadTraceSTM m =>
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
forall (proxy :: (* -> *) -> *) a.
proxy m
-> TVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue)
-> STM m ()
Lazy.traceTVar proxy m
p LazyTVar m a
tvar

traceTVarIO :: MonadTraceSTM m
            => StrictTVar m a
            -> (Maybe a -> a -> InspectMonad m TraceValue)
            -> m ()
traceTVarIO :: forall (m :: * -> *) a.
MonadTraceSTM m =>
StrictTVar m a
-> (Maybe a -> a -> InspectMonad m TraceValue) -> m ()
traceTVarIO StrictTVar {LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar} = LazyTVar m a -> (Maybe a -> a -> InspectMonad m TraceValue) -> m ()
forall a.
TVar m a -> (Maybe a -> a -> InspectMonad m TraceValue) -> m ()
forall (m :: * -> *) a.
MonadTraceSTM m =>
TVar m a -> (Maybe a -> a -> InspectMonad m TraceValue) -> m ()
Lazy.traceTVarIO LazyTVar m a
tvar

-- | Cast the monad if both use the same representation of `TVar`s.
--
-- This function is useful for monad transformers stacks if the `TVar` is used
-- in different monad stacks.
--
castStrictTVar :: LazyTVar m ~ LazyTVar n
               => StrictTVar m a -> StrictTVar n a
castStrictTVar :: forall (m :: * -> *) (n :: * -> *) a.
(LazyTVar m ~ LazyTVar n) =>
StrictTVar m a -> StrictTVar n a
castStrictTVar StrictTVar {LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar} = StrictTVar {LazyTVar m a
LazyTVar n a
tvar :: LazyTVar n a
tvar :: LazyTVar m a
tvar}

-- | Get the underlying @TVar@
--
-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be
-- strict, this should be used with caution.
toLazyTVar :: StrictTVar m a -> LazyTVar m a
toLazyTVar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
toLazyTVar StrictTVar { LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar } = LazyTVar m a
tvar

fromLazyTVar :: LazyTVar m a -> StrictTVar m a
fromLazyTVar :: forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
fromLazyTVar = LazyTVar m a -> StrictTVar m a
forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
StrictTVar

newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
newTVar :: forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar !a
a = LazyTVar m a -> StrictTVar m a
forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
StrictTVar (LazyTVar m a -> StrictTVar m a)
-> STM m (LazyTVar m a) -> STM m (StrictTVar m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> STM m (LazyTVar m a)
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
Lazy.newTVar a
a

newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)
newTVarIO :: forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO !a
a = LazyTVar m a -> StrictTVar m a
forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
StrictTVar (LazyTVar m a -> StrictTVar m a)
-> m (LazyTVar m a) -> m (StrictTVar m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (LazyTVar m a)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
Lazy.newTVarIO a
a

readTVar :: MonadSTM m => StrictTVar m a -> STM m a
readTVar :: forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar { LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar } = LazyTVar 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 LazyTVar m a
tvar

readTVarIO :: MonadSTM m => StrictTVar m a -> m a
readTVarIO :: forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar { LazyTVar m a
tvar :: forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar :: LazyTVar m a
tvar } = LazyTVar m a -> m a
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
Lazy.readTVarIO LazyTVar m a
tvar

writeTVar :: MonadSTM m => StrictTVar m a -> a -> STM m ()
writeTVar :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m a
v !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 (StrictTVar m a -> TVar m a
forall (m :: * -> *) a. StrictTVar m a -> LazyTVar m a
tvar StrictTVar m a
v) a
a

modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m a
v a -> a
f = StrictTVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m a
v STM m a -> (a -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictTVar m a -> a -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m a
v (a -> STM m ()) -> (a -> a) -> a -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f

stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar :: forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m s
v s -> (a, s)
f = do
    s
a <- StrictTVar m s -> STM m s
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m s
v
    let (a
b, s
a') = s -> (a, s)
f s
a
    StrictTVar m s -> s -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m s
v s
a'
    a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b

swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a
swapTVar :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m a
swapTVar StrictTVar m a
v a
a' = do
    a
a <- StrictTVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m a
v
    StrictTVar m a -> a -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m a
v a
a'
    a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a