module Control.Monad.Backend where
import Control.Monad.Except
import Control.Monad.State
import Control.Concurrent.MVar (MVar, isEmptyMVar, modifyMVar_, takeMVar, putMVar, readMVar, newMVar)
import Control.Arrow (second)
newtype BackendT s m a = BackendT (MVar s -> m (MVar s, a))
runBackendT :: (Monad m, MonadIO m) => BackendT s m a -> s -> m (MVar s, a)
runBackendT (BackendT f) s = do { v <- liftIO (newMVar s); f v }
rawRunBackendT :: BackendT s m a -> MVar s -> m (MVar s, a)
rawRunBackendT (BackendT f) = f
instance (Functor m) => Functor (BackendT s m) where
fmap f bt = BackendT $ \s -> fmap (second f) (rawRunBackendT bt s)
instance (Monad m) => Applicative (BackendT s m) where
pure x = BackendT $ \s -> pure (s, x)
pf <*> q = BackendT $ \s -> do { (s', f) <- rawRunBackendT pf s; (s'', x) <- rawRunBackendT q s'; return (s'', f x) }
instance (Monad m) => Monad (BackendT s m) where
return x = BackendT $ \s -> return (s, x)
p >>= fq = BackendT $ \s -> do { (s', x) <- rawRunBackendT p s; rawRunBackendT (fq x) s' }
instance (Monad m, MonadIO m) => MonadState s (BackendT s m) where
get = BackendT $ \s -> do { v <- liftIO (readMVar s); return (s, v) }
put s = BackendT $
\st -> do { liftIO (modifyMVar_ st (\_ -> return s)); return (st, ()) }
state f = BackendT $
\ms -> do s <- liftIO (takeMVar ms)
let (x, s') = f s
liftIO (putMVar ms s')
return (ms, x)
instance (Monad m, MonadIO m) => MonadIO (BackendT s m) where
liftIO io = BackendT $ \s -> do { x <- liftIO io; return (s, x) }