{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}

-- undecidable instances needed for 'ContTSTM' instances of
-- 'MonadThrow' and 'MonadCatch' type classes.
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -Wno-orphans            #-}

module Control.Monad.Class.MonadSTM.Trans (ContTSTM (..)) where

import Control.Monad.Cont (ContT (..))
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.RWS.Lazy qualified as Lazy
import Control.Monad.RWS.Strict qualified as Strict
import Control.Monad.State.Lazy qualified as Lazy
import Control.Monad.State.Strict qualified as Strict
import Control.Monad.Trans (lift)
import Control.Monad.Writer.Lazy qualified as Lazy
import Control.Monad.Writer.Strict qualified as Strict

import Control.Monad.Class.MonadSTM.Internal
import Control.Monad.Class.MonadThrow qualified as MonadThrow

import Data.Array.Base (MArray (..))
import Data.Function (on)
import Data.Kind (Type)


-- | A newtype wrapper for an 'STM' monad for 'ContT'
--
newtype ContTSTM r (m :: Type -> Type) a = ContTSTM { getContTSTM :: STM m a }

deriving instance MonadSTM m => Functor     (ContTSTM r m)
deriving instance MonadSTM m => Applicative (ContTSTM r m)
deriving instance MonadSTM m => Monad       (ContTSTM r m)

instance ( Semigroup a, MonadSTM m ) => Semigroup (ContTSTM r m a) where
    a <> b = (<>) <$> a <*> b
instance ( Monoid a, MonadSTM m )    => Monoid (ContTSTM r m a) where
    mempty = pure mempty

instance ( MonadSTM m, MArray e a (STM m) ) => MArray e a (ContTSTM r m) where
    getBounds         = ContTSTM . getBounds
    getNumElements    = ContTSTM . getNumElements
    unsafeRead arr    = ContTSTM . unsafeRead arr
    unsafeWrite arr i = ContTSTM . unsafeWrite arr i
#if __GLASGOW_HASKELL__ >= 910
    newArray idxs     = ContTSTM . newArray idxs
#endif


-- note: this (and the following) instance requires 'UndecidableInstances'
-- extension because it violates 3rd Paterson condition, however `STM m` will
-- resolve to a concrete type of kind (Type -> Type), and thus no larger than
-- `m` itself, e.g. for `m ~ ReaderT r f`, `STM m ~ WrappedSTM Reader r f`.
-- Instance resolution will terminate as soon as the monad transformer stack
-- depth is exhausted.
instance ( MonadSTM m
         , MonadThrow.MonadThrow (STM m)
         , MonadThrow.MonadCatch (STM m)
         ) => MonadThrow.MonadThrow (ContTSTM r m) where
  throwIO = ContTSTM . MonadThrow.throwIO
#if __GLASGOW_HASKELL__ >= 910
  annotateIO ann (ContTSTM stm) = ContTSTM (MonadThrow.annotateIO ann stm)
#endif

instance ( MonadSTM m
         , MonadThrow.MonadThrow (STM m)
         , MonadThrow.MonadCatch (STM m)
         ) => MonadThrow.MonadCatch (ContTSTM r m) where
  catch action handler = ContTSTM
                       $ MonadThrow.catch (getContTSTM action) (getContTSTM . handler)
  generalBracket acquire release use = ContTSTM $
    MonadThrow.generalBracket (getContTSTM    acquire)
                              (getContTSTM .: release)
                              (getContTSTM .  use)

-- | @'ContT' r m@ monad is using underlying @'STM' m@ monad as its stm monad,
-- without transforming it.
--
instance MonadSTM m => MonadSTM (ContT r m) where
    type STM (ContT r m) = ContTSTM r m
    atomically = lift . atomically . getContTSTM

    type TVar (ContT r m) = TVar m
    newTVar        = ContTSTM .  newTVar
    readTVar       = ContTSTM .  readTVar
    writeTVar      = ContTSTM .: writeTVar
    retry          = ContTSTM    retry
    orElse         = ContTSTM .: on orElse getContTSTM

    modifyTVar     = ContTSTM .: modifyTVar
    modifyTVar'    = ContTSTM .: modifyTVar'
    stateTVar      = ContTSTM .: stateTVar
    swapTVar       = ContTSTM .: swapTVar
    check          = ContTSTM .  check

    type TMVar (ContT r m) = TMVar m
    newTMVar       = ContTSTM .  newTMVar
    newEmptyTMVar  = ContTSTM    newEmptyTMVar
    takeTMVar      = ContTSTM .  takeTMVar
    tryTakeTMVar   = ContTSTM .  tryTakeTMVar
    putTMVar       = ContTSTM .: putTMVar
    tryPutTMVar    = ContTSTM .: tryPutTMVar
    readTMVar      = ContTSTM .  readTMVar
    tryReadTMVar   = ContTSTM .  tryReadTMVar
    swapTMVar      = ContTSTM .: swapTMVar
    writeTMVar     = ContTSTM .: writeTMVar
    isEmptyTMVar   = ContTSTM .  isEmptyTMVar

    type TQueue (ContT r m) = TQueue m
    newTQueue      = ContTSTM newTQueue
    readTQueue     = ContTSTM . readTQueue
    tryReadTQueue  = ContTSTM . tryReadTQueue
    peekTQueue     = ContTSTM . peekTQueue
    tryPeekTQueue  = ContTSTM . tryPeekTQueue
    flushTQueue    = ContTSTM .  flushTQueue
    writeTQueue v  = ContTSTM . writeTQueue v
    isEmptyTQueue  = ContTSTM . isEmptyTQueue
    unGetTQueue    = ContTSTM .: unGetTQueue

    type TBQueue (ContT r m) = TBQueue m
    newTBQueue     = ContTSTM .  newTBQueue
    readTBQueue    = ContTSTM .  readTBQueue
    tryReadTBQueue = ContTSTM .  tryReadTBQueue
    peekTBQueue    = ContTSTM .  peekTBQueue
    tryPeekTBQueue = ContTSTM .  tryPeekTBQueue
    flushTBQueue   = ContTSTM .  flushTBQueue
    writeTBQueue   = ContTSTM .: writeTBQueue
    lengthTBQueue  = ContTSTM .  lengthTBQueue
    isEmptyTBQueue = ContTSTM .  isEmptyTBQueue
    isFullTBQueue  = ContTSTM .  isFullTBQueue
    unGetTBQueue   = ContTSTM .: unGetTBQueue

    type TArray (ContT r m) = TArray m

    type TSem (ContT r m) = TSem m
    newTSem        = ContTSTM .  newTSem
    waitTSem       = ContTSTM .  waitTSem
    signalTSem     = ContTSTM .  signalTSem
    signalTSemN    = ContTSTM .: signalTSemN

    type TChan (ContT r m) = TChan m
    newTChan          = ContTSTM    newTChan
    newBroadcastTChan = ContTSTM    newBroadcastTChan
    dupTChan          = ContTSTM .  dupTChan
    cloneTChan        = ContTSTM .  cloneTChan
    readTChan         = ContTSTM .  readTChan
    tryReadTChan      = ContTSTM .  tryReadTChan
    peekTChan         = ContTSTM .  peekTChan
    tryPeekTChan      = ContTSTM .  tryPeekTChan
    writeTChan        = ContTSTM .: writeTChan
    unGetTChan        = ContTSTM .: unGetTChan
    isEmptyTChan      = ContTSTM .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where
    type STM (Lazy.WriterT w m) = Lazy.WriterT w (STM m)
    atomically (Lazy.WriterT stm) = Lazy.WriterT (atomically stm)

    type TVar (Lazy.WriterT w m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Lazy.WriterT a) (Lazy.WriterT b) = Lazy.WriterT $ a `orElse` b

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Lazy.WriterT w m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Lazy.WriterT w m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift .  readTQueue
    tryReadTQueue  = lift .  tryReadTQueue
    peekTQueue     = lift .  peekTQueue
    tryPeekTQueue  = lift .  tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift .  writeTQueue v
    isEmptyTQueue  = lift .  isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Lazy.WriterT w m) = TBQueue m
    newTBQueue     = lift .  newTBQueue
    readTBQueue    = lift .  readTBQueue
    tryReadTBQueue = lift .  tryReadTBQueue
    peekTBQueue    = lift .  peekTBQueue
    tryPeekTBQueue = lift .  tryPeekTBQueue
    flushTBQueue   = lift .  flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift .  lengthTBQueue
    isEmptyTBQueue = lift .  isEmptyTBQueue
    isFullTBQueue  = lift .  isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Lazy.WriterT w m) = TArray m

    type TSem (Lazy.WriterT w m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Lazy.WriterT w m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where
    type STM (Strict.WriterT w m) = Strict.WriterT w (STM m)
    atomically (Strict.WriterT stm) = Strict.WriterT (atomically stm)

    type TVar (Strict.WriterT w m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Strict.WriterT a) (Strict.WriterT b) = Strict.WriterT $ a `orElse` b

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Strict.WriterT w m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Strict.WriterT w m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift .  readTQueue
    tryReadTQueue  = lift .  tryReadTQueue
    peekTQueue     = lift .  peekTQueue
    tryPeekTQueue  = lift .  tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift .  writeTQueue v
    isEmptyTQueue  = lift .  isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Strict.WriterT w m) = TBQueue m
    newTBQueue     = lift .  newTBQueue
    readTBQueue    = lift .  readTBQueue
    tryReadTBQueue = lift .  tryReadTBQueue
    peekTBQueue    = lift .  peekTBQueue
    tryPeekTBQueue = lift .  tryPeekTBQueue
    flushTBQueue   = lift .  flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift .  lengthTBQueue
    isEmptyTBQueue = lift .  isEmptyTBQueue
    isFullTBQueue  = lift .  isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Strict.WriterT w m) = TArray m

    type TSem (Strict.WriterT w m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Strict.WriterT w m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance MonadSTM m => MonadSTM (Lazy.StateT s m) where
    type STM (Lazy.StateT s m) = Lazy.StateT s (STM m)
    atomically (Lazy.StateT stm) = Lazy.StateT $ \s -> atomically (stm s)

    type TVar (Lazy.StateT s m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Lazy.StateT a) (Lazy.StateT b) = Lazy.StateT $ \s -> a s `orElse` b s

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Lazy.StateT s m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Lazy.StateT s m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift . readTQueue
    tryReadTQueue  = lift . tryReadTQueue
    peekTQueue     = lift . peekTQueue
    tryPeekTQueue  = lift . tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift . writeTQueue v
    isEmptyTQueue  = lift . isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Lazy.StateT s m) = TBQueue m
    newTBQueue     = lift .  newTBQueue
    readTBQueue    = lift .  readTBQueue
    tryReadTBQueue = lift .  tryReadTBQueue
    peekTBQueue    = lift .  peekTBQueue
    tryPeekTBQueue = lift .  tryPeekTBQueue
    flushTBQueue   = lift .  flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift .  lengthTBQueue
    isEmptyTBQueue = lift .  isEmptyTBQueue
    isFullTBQueue  = lift .  isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Lazy.StateT s m) = TArray m

    type TSem (Lazy.StateT s m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Lazy.StateT s m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance MonadSTM m => MonadSTM (Strict.StateT s m) where
    type STM (Strict.StateT s m) = Strict.StateT s (STM m)
    atomically (Strict.StateT stm) = Strict.StateT $ \s -> atomically (stm s)

    type TVar (Strict.StateT s m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Strict.StateT a) (Strict.StateT b) = Strict.StateT $ \s -> a s `orElse` b s

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Strict.StateT s m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Strict.StateT s m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift . readTQueue
    tryReadTQueue  = lift . tryReadTQueue
    peekTQueue     = lift . peekTQueue
    tryPeekTQueue  = lift . tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift . writeTQueue v
    isEmptyTQueue  = lift . isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Strict.StateT s m) = TBQueue m
    newTBQueue     = lift .  newTBQueue
    readTBQueue    = lift .  readTBQueue
    tryReadTBQueue = lift .  tryReadTBQueue
    peekTBQueue    = lift .  peekTBQueue
    tryPeekTBQueue = lift .  tryPeekTBQueue
    flushTBQueue   = lift .  flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift .  lengthTBQueue
    isEmptyTBQueue = lift .  isEmptyTBQueue
    isFullTBQueue  = lift .  isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Strict.StateT s m) = TArray m

    type TSem (Strict.StateT s m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Strict.StateT s m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance MonadSTM m => MonadSTM (ExceptT e m) where
    type STM (ExceptT e m) = ExceptT e (STM m)
    atomically = ExceptT . atomically . runExceptT

    type TVar (ExceptT e m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse         = ExceptT .: on orElse runExceptT

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (ExceptT e m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (ExceptT e m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift .  readTQueue
    tryReadTQueue  = lift .  tryReadTQueue
    peekTQueue     = lift .  peekTQueue
    tryPeekTQueue  = lift .  tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift .  writeTQueue v
    isEmptyTQueue  = lift .  isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (ExceptT e m) = TBQueue m
    newTBQueue     = lift .  newTBQueue
    readTBQueue    = lift .  readTBQueue
    tryReadTBQueue = lift .  tryReadTBQueue
    peekTBQueue    = lift .  peekTBQueue
    tryPeekTBQueue = lift .  tryPeekTBQueue
    flushTBQueue   = lift .  flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift .  lengthTBQueue
    isEmptyTBQueue = lift .  isEmptyTBQueue
    isFullTBQueue  = lift .  isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (ExceptT e m) = TArray m

    type TSem (ExceptT e m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (ExceptT e m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where
    type STM (Lazy.RWST r w s m) = Lazy.RWST r w s (STM m)
    atomically (Lazy.RWST stm) = Lazy.RWST $ \r s -> atomically (stm r s)

    type TVar (Lazy.RWST r w s m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Lazy.RWST a) (Lazy.RWST b) = Lazy.RWST $ \r s -> a r s `orElse` b r s

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Lazy.RWST r w s m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Lazy.RWST r w s m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift .  readTQueue
    tryReadTQueue  = lift .  tryReadTQueue
    peekTQueue     = lift .  peekTQueue
    tryPeekTQueue  = lift .  tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift .  writeTQueue v
    isEmptyTQueue  = lift .  isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Lazy.RWST r w s m) = TBQueue m
    newTBQueue     = lift . newTBQueue
    readTBQueue    = lift . readTBQueue
    tryReadTBQueue = lift . tryReadTBQueue
    peekTBQueue    = lift . peekTBQueue
    tryPeekTBQueue = lift . tryPeekTBQueue
    flushTBQueue   = lift . flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift . lengthTBQueue
    isEmptyTBQueue = lift . isEmptyTBQueue
    isFullTBQueue  = lift . isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Lazy.RWST r w s m) = TArray m

    type TSem (Lazy.RWST r w s m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Lazy.RWST r w s m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


-- | The underlying stm monad is also transformed.
--
instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where
    type STM (Strict.RWST r w s m) = Strict.RWST r w s (STM m)
    atomically (Strict.RWST stm) = Strict.RWST $ \r s -> atomically (stm r s)

    type TVar (Strict.RWST r w s m) = TVar m
    newTVar        = lift .  newTVar
    readTVar       = lift .  readTVar
    writeTVar      = lift .: writeTVar
    retry          = lift    retry
    orElse (Strict.RWST a) (Strict.RWST b) = Strict.RWST $ \r s -> a r s `orElse` b r s

    modifyTVar     = lift .: modifyTVar
    modifyTVar'    = lift .: modifyTVar'
    stateTVar      = lift .: stateTVar
    swapTVar       = lift .: swapTVar
    check          = lift .  check

    type TMVar (Strict.RWST r w s m) = TMVar m
    newTMVar       = lift .  newTMVar
    newEmptyTMVar  = lift    newEmptyTMVar
    takeTMVar      = lift .  takeTMVar
    tryTakeTMVar   = lift .  tryTakeTMVar
    putTMVar       = lift .: putTMVar
    tryPutTMVar    = lift .: tryPutTMVar
    readTMVar      = lift .  readTMVar
    tryReadTMVar   = lift .  tryReadTMVar
    swapTMVar      = lift .: swapTMVar
    writeTMVar     = lift .: writeTMVar
    isEmptyTMVar   = lift .  isEmptyTMVar

    type TQueue (Strict.RWST r w s m) = TQueue m
    newTQueue      = lift newTQueue
    readTQueue     = lift .  readTQueue
    tryReadTQueue  = lift .  tryReadTQueue
    peekTQueue     = lift .  peekTQueue
    tryPeekTQueue  = lift .  tryPeekTQueue
    flushTQueue    = lift .  flushTQueue
    writeTQueue v  = lift .  writeTQueue v
    isEmptyTQueue  = lift .  isEmptyTQueue
    unGetTQueue    = lift .: unGetTQueue

    type TBQueue (Strict.RWST r w s m) = TBQueue m
    newTBQueue     = lift . newTBQueue
    readTBQueue    = lift . readTBQueue
    tryReadTBQueue = lift . tryReadTBQueue
    peekTBQueue    = lift . peekTBQueue
    tryPeekTBQueue = lift . tryPeekTBQueue
    flushTBQueue   = lift . flushTBQueue
    writeTBQueue   = lift .: writeTBQueue
    lengthTBQueue  = lift . lengthTBQueue
    isEmptyTBQueue = lift . isEmptyTBQueue
    isFullTBQueue  = lift . isFullTBQueue
    unGetTBQueue   = lift .: unGetTBQueue

    type TArray (Strict.RWST r w s m) = TArray m

    type TSem (Strict.RWST r w s m) = TSem m
    newTSem        = lift .  newTSem
    waitTSem       = lift .  waitTSem
    signalTSem     = lift .  signalTSem
    signalTSemN    = lift .: signalTSemN

    type TChan (Strict.RWST r w s m) = TChan m
    newTChan          = lift    newTChan
    newBroadcastTChan = lift    newBroadcastTChan
    dupTChan          = lift .  dupTChan
    cloneTChan        = lift .  cloneTChan
    readTChan         = lift .  readTChan
    tryReadTChan      = lift .  tryReadTChan
    peekTChan         = lift .  peekTChan
    tryPeekTChan      = lift .  tryPeekTChan
    writeTChan        = lift .: writeTChan
    unGetTChan        = lift .: unGetTChan
    isEmptyTChan      = lift .  isEmptyTChan


(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(f .: g) x y = f (g x y)