Created
May 24, 2017 18:36
-
-
Save snoyberg/7ac111bc873be6a361e452adb5454cb9 to your computer and use it in GitHub Desktop.
RWST implemented in terms of IORef
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment