{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

{- |

Module      :  Control.Monad.Resumable.Class
Copyright   :  Copyright Nicolas Frisby 2010
License     :  <http://creativecommons.org/licenses/by/3.0/>

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  non-portable (GHC extensions)

A monadic interface for resumable exceptions.

-}

module Control.Monad.Resumable.Class where

import Control.Monad.RWS
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Cont


-- | A monadic interface for resumable exceptions.
class Monad m => MonadResumable req res m | m -> req res where
  yield :: req -> (res -> m a) -> m a
  -- ^ Raise the exception: a request and a resumption to use if the request
  -- can be handled.
  handle :: m a -> (req -> (res -> m a) -> m a) -> m a
  -- ^ Installs a handler to quiesce an exception before it percolates to the
  -- higher-level handlers.

-- | Variation on 'yield' that immediately returns the result.
signal :: (MonadResumable req res m) => req -> m res
signal req = yield req return

-- | Variation on 'handle' that always applies the resumption.
respond :: MonadResumable req res m => (req -> m res) -> m a -> m a
respond f = flip handle (\ req k -> f req >>= k)

instance (Monoid w, MonadResumable req res m) =>
  MonadResumable req res (RWST r w s m) where
  yield req k = RWST $ \ r s -> yield req (\ res -> runRWST (k res) r s)
  handle m h = RWST $ \ r s ->
    let run m = runRWST m r s
    in run m `handle` \ req k -> run (h req (\ res -> RWST $ \ _ _ -> k res))

instance MonadResumable req res m =>
  MonadResumable req res (ReaderT r m) where
  yield req k = ReaderT $ \ r -> yield req (flip runReaderT r . k)
  handle m h = ReaderT $ \ r ->
    let run = flip runReaderT r
    in run m `handle` \ req k -> run (h req (\ res -> ReaderT $ \ _ -> k res))

instance (Monoid w, MonadResumable req res m) =>
  MonadResumable req res (WriterT w m) where
  yield req k = WriterT $ yield req (runWriterT . k)
  handle m h =
    mapWriterT (flip handle (\ req k -> runWriterT (h req (WriterT . k)))) m

instance MonadResumable req res m =>
  MonadResumable req res (StateT s m) where
  yield req k = StateT $ \ s -> yield req (flip runStateT s . k)
  handle m h = StateT $ \ s ->
    let run = flip runStateT s
    in run m `handle` \ req k -> run (h req (\ res -> StateT $ \ _ -> k res))

instance (Error e, MonadResumable req res m) =>
  MonadResumable req res (ErrorT e m) where
  yield req k = ErrorT $ yield req (runErrorT . k)
  handle m h =
    mapErrorT (flip handle (\ req k -> runErrorT (h req (ErrorT . k)))) m

instance MonadResumable req res m =>
  MonadResumable req res (ContT r m) where
  yield req k = ContT $ \ cc -> yield req (flip runContT cc . k)
  handle m h = ContT $ \ cc ->
    let run = flip runContT cc
    in run m `handle` \ req k -> run (h req (\ res -> ContT $ \ _ -> k res))