MutableState.hs

module Control.Monad.MutableState where

import Control.Applicative 
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State.Class
import Control.Monad.Trans
import Control.Monad.Trans.Reader hiding (ask)
import Data.IORef

newtype MutableState c s io a = MutableState { unMutableState :: ReaderT (c s) io a }

type RefState = MutableState IORef

class MutableIO m where
  newMutable :: (MonadIO io) => a -> io (m a)
  readMutable :: (MonadIO io) => m a -> io a
  writeMutable :: (MonadIO io) => m a -> a -> io ()

instance MutableIO IORef where
  newMutable a = liftIO (newIORef a)
  readMutable a = liftIO (readIORef a)
  writeMutable a b = liftIO (writeIORef a b)

runMutableState :: (MutableIO c, MonadIO m) => MutableState c s m a -> s -> m a
runMutableState (MutableState x) s = do
  ioref <- newMutable s
  runReaderT x ioref

instance Functor m => Functor (MutableState c s m) where
  fmap f (MutableState a) = MutableState (fmap f a)

instance Applicative m => Applicative (MutableState c s m) where
  pure a = MutableState (pure a)
  (MutableState f) <*> (MutableState a) = MutableState (f <*> a)

instance Monad m => Monad (MutableState c s m) where
  return a = MutableState (return a)
  (MutableState a) >>= f = MutableState (a >>= unMutableState . f)

instance MonadIO m => MonadIO (MutableState c s m) where
  liftIO a = MutableState (liftIO a)

instance MonadTrans (MutableState c s) where
  lift x = MutableState $ (lift x)

instance (MutableIO c, MonadIO m) => MonadState s (MutableState c s m) where
  get = MutableState $ do
    s <- ask
    readMutable s
  put n = MutableState $ do
    s <- ask
    writeMutable s n