RWST implemented in terms of IORef

RWSTref.hs

#!/usr/bin/env stack
-- stack --resolver lts-8.12 script
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Data.IORef
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.RWS.Class

newtype RWST r w s m a = RWST
  { runRWST :: r
            -> IORef w
            -> IORef s
            -> m a
  }
  deriving Functor

instance (Applicative m) => Applicative (RWST r w s m) where
  pure x = RWST $ \_r _w _s -> pure x
  RWST f <*> RWST x = RWST $ \r w s -> f r w s <*> x r w s
instance Monad m => Monad (RWST r w s m) where
  return = pure
  RWST m >>= f = RWST $ \r w s -> do
    x <- m r w s
    let RWST m' = f x
    m' r w s
instance MonadTrans (RWST r w s) where
  lift m = RWST $ \_r _w _s -> m
instance MonadIO m => MonadIO (RWST r w s m) where
  liftIO = lift . liftIO
instance Monad m => MonadReader r (RWST r w s m) where
  ask = RWST $ \r _w _s -> pure r
  local f (RWST m) = RWST $ \r w s -> m (f r) w s
instance (MonadIO m, Monoid w) => MonadWriter w (RWST r w s m) where
  tell w2 = RWST $ \r wRef s -> liftIO $ do
    w1 <- readIORef wRef
    writeIORef wRef $! mappend w1 w2
  pass (RWST f) = RWST $ \r wRef s -> do
    (a, g) <- f r wRef s
    liftIO $ modifyIORef wRef g
    pure a
  listen (RWST m) = RWST $ \r wRef s -> do
    ref <- liftIO $ newIORef mempty
    a <- m r ref s
    w <- liftIO $ readIORef ref
    liftIO $ modifyIORef ref (`mappend` w)
    pure (a, w)
instance MonadIO m => MonadState s (RWST r w s m) where
  get = RWST $ \_r _w s -> liftIO $ readIORef s
  put x = RWST $ \_r _w s -> liftIO $ writeIORef s $! x
instance (MonadIO m, Monoid w) => MonadRWS r w s (RWST r w s m)