Skip to content

Instantly share code, notes, and snippets.

@snipsnipsnip
Last active August 24, 2019 15:18
Show Gist options
  • Save snipsnipsnip/112595 to your computer and use it in GitHub Desktop.
Save snipsnipsnip/112595 to your computer and use it in GitHub Desktop.
Pause Monad
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
module PauseMonad
( MonadPause (..)
, Pause (..)
, PauseT (..)
, tracePauseT
, module Control.Monad.Trans
) where
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Trans
class Monad m => MonadPause m where
pause :: m ()
newtype Pause a = Pause
{ runPause :: Either (Pause a) a
} deriving (Eq, Show)
instance MonadPause Pause where
pause = Pause $ Left $ return ()
instance Functor Pause where
fmap f (Pause (Left p)) = Pause $ Left $ fmap f p
fmap f (Pause (Right a)) = Pause $ Right $ f a
instance Monad Pause where
return = Pause . Right
Pause (Left p) >>= f = Pause $ Left $ p >>= f
Pause (Right a) >>= f = f a
newtype PauseT m a = PauseT
{ runPauseT :: m (Either (PauseT m a) a)
}
tracePauseT :: (MonadIO m, Show a) => PauseT m a -> m ()
tracePauseT m = loop (1 :: Int) m
where
loop n m = do
r <- runPauseT m
liftIO $ putStrLn $ "tracePauseT(" ++ show n ++ "): " ++ showPauseT r
case r of
Left p -> loop (n + 1) p
_ -> return ()
showPauseT (Left p) = "Left #<PauseT>"
showPauseT (Right a) = "Right " ++ show a
instance Monad m => MonadPause (PauseT m) where
pause = PauseT $ return $ Left $ return ()
instance (Monad m) => Functor (PauseT m) where
fmap = liftM
instance MonadTrans PauseT where
lift = PauseT . liftM Right
instance (MonadIO m) => MonadIO (PauseT m) where
liftIO = lift . liftIO
instance (Monad m) => Monad (PauseT m) where
return = PauseT . return . Right
t >>= f = PauseT $ do
p <- runPauseT t
case p of
Right a -> runPauseT $ f a
Left p -> return $ Left $ p >>= f
-- Instances for other monad classes
instance (MonadState s m) => MonadState s (PauseT m) where
get = lift get
put = lift . put
instance (MonadReader r m) => MonadReader r (PauseT m) where
ask = lift ask
local f m = PauseT $ local f $ runPauseT m
instance (MonadWriter w m) => MonadWriter w (PauseT m) where
tell = lift . tell
listen m = PauseT $ do
(p, w) <- listen $ runPauseT m
return $ case p of
Left p -> Left $ liftM (\a -> (a, w)) p
Right a -> Right (a, w)
pass m = PauseT $ pass $ do
p <- runPauseT m
return $ case p of
Left p -> (Left $ pass p, id)
Right (a, f) -> (Right a, f)
instance (MonadError e m) => MonadError e (PauseT m) where
throwError = lift . throwError
catchError m f = PauseT $ catchError (runPauseT m) (runPauseT . f)
-- Instances for other transformers
instance (MonadPause m) => MonadPause (ReaderT s m) where
pause = lift pause
instance (MonadPause m) => MonadPause (StateT s m) where
pause = lift pause
instance (MonadPause m, Monoid w) => MonadPause (WriterT w m) where
pause = lift pause
instance (MonadPause m, Error e) => MonadPause (ErrorT e m) where
pause = lift pause
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment