Pause Monad

PauseMonad.hs

{-# 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