module Control.Monad.STM.Class
( MonadSTM(..)
, check
, throwSTM
, catchSTM
, makeTransSTM
, liftedOrElse
) where
import Control.Exception (Exception)
import Control.Monad (unless)
import Control.Monad.Reader (ReaderT)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith)
import Control.Monad.Trans.Identity (IdentityT)
import Language.Haskell.TH (DecsQ, Info(VarI), Name, Type(..), reify, varE)
import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.Catch as Ca
import qualified Control.Monad.RWS.Lazy as RL
import qualified Control.Monad.RWS.Strict as RS
import qualified Control.Monad.State.Lazy as SL
import qualified Control.Monad.State.Strict as SS
import qualified Control.Monad.Writer.Lazy as WL
import qualified Control.Monad.Writer.Strict as WS
class Ca.MonadCatch stm => MonadSTM stm where
type TVar stm :: * -> *
retry :: stm a
orElse :: stm a -> stm a -> stm a
newTVar :: a -> stm (TVar stm a)
newTVar = newTVarN ""
newTVarN :: String -> a -> stm (TVar stm a)
newTVarN _ = newTVar
readTVar :: TVar stm a -> stm a
writeTVar :: TVar stm a -> a -> stm ()
check :: MonadSTM stm => Bool -> stm ()
check b = unless b retry
throwSTM :: (MonadSTM stm, Exception e) => e -> stm a
throwSTM = Ca.throwM
catchSTM :: (MonadSTM stm, Exception e) => stm a -> (e -> stm a) -> stm a
catchSTM = Ca.catch
instance MonadSTM STM.STM where
type TVar STM.STM = STM.TVar
retry = STM.retry
orElse = STM.orElse
newTVar = STM.newTVar
readTVar = STM.readTVar
writeTVar = STM.writeTVar
#define INSTANCE(T,C,F) \
instance C => MonadSTM (T stm) where { \
type TVar (T stm) = TVar stm ; \
\
retry = lift retry ; \
orElse = liftedOrElse F ; \
newTVar = lift . newTVar ; \
newTVarN n = lift . newTVarN n ; \
readTVar = lift . readTVar ; \
writeTVar v = lift . writeTVar v }
INSTANCE(ReaderT r, MonadSTM stm, id)
INSTANCE(IdentityT, MonadSTM stm, id)
INSTANCE(WL.WriterT w, (MonadSTM stm, Monoid w), fst)
INSTANCE(WS.WriterT w, (MonadSTM stm, Monoid w), fst)
INSTANCE(SL.StateT s, MonadSTM stm, fst)
INSTANCE(SS.StateT s, MonadSTM stm, fst)
INSTANCE(RL.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a))
INSTANCE(RS.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a))
#undef INSTANCE
makeTransSTM :: Name -> DecsQ
makeTransSTM unstN = do
unstI <- reify unstN
case unstI of
#if MIN_VERSION_template_haskell(2,11,0)
VarI _ (ForallT _ _ (AppT (AppT ArrowT (AppT (AppT (ConT _) t) _)) _)) _ ->
#else
VarI _ (ForallT _ _ (AppT (AppT ArrowT (AppT (AppT (ConT _) t) _)) _)) _ _ ->
#endif
[d|
instance (MonadSTM stm, MonadTransControl $(pure t)) => MonadSTM ($(pure t) stm) where
type TVar ($(pure t) stm) = TVar stm
retry = lift retry
orElse = liftedOrElse $(varE unstN)
newTVar = lift . newTVar
newTVarN n = lift . newTVarN n
readTVar = lift . readTVar
writeTVar v = lift . writeTVar v
|]
_ -> fail "Expected a value of type (forall a -> StT t a -> a)"
liftedOrElse :: (MonadTransControl t, MonadSTM stm)
=> (forall x. StT t x -> x)
-> t stm a -> t stm a -> t stm a
liftedOrElse unst ma mb = liftWith $ \run ->
let ma' = unst <$> run ma
mb' = unst <$> run mb
in ma' `orElse` mb'