Class.hs

{-# LANGUAGE TypeFamilies #-}

module Control.Monad.Trans.Interruptible.Class (
  Interruptible(..),
  -- * Instance accessors
  inEitherTCtx, peelEitherTCtx,
  inStateTCtx, peelStateTCtx,
  inWriterTCtx, peelWriterTCtx,
  inReaderTCtx, peelReaderTCtx,
  inRWSTCtx, peelRWSTCtx,
  -- * Resumers for stacks of interruptibles
  resume2,
  resume3,
  resume4,
  resume5
  )where

import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Trans.RWS

{- |
Interruptible monad transformers.

A monad transformer can be made interruptible if it returns its
final context from its type creator, and if it is possible
to hoist this context again into the monad at the begining
of its execution.

For example, @StateT@ can be interrupted because
@runStateT@ returns its final state, and because its state
can be set again at creation simply by passing it as an
parameter to @runStateT@. An Error context can not be hoisted
back at the transformer, thus Error can not be interrupted.

When instantiating, do not forget to create the corresponding
inCtx and peelCtx functions, for documenting the RSt format
and keeping the class consistent.
-}
class MonadTrans t => Interruptible t where
  -- | Context data of the transformer
  type RSt t a :: *
  -- | Resumes the execution of an interruptible transformer
  resume :: Monad m => (a -> t m b) -> RSt t a -> m (RSt t b)

instance Interruptible (EitherT e) where
  -- | The context of @EitherT e a@ is @Either e a@.
  type RSt (EitherT e) a = Either e a
  resume f st = runEitherT (hoistEither st >>= f)

-- | Cretes an interrupted EitherT context
inEitherTCtx :: a -> RSt (EitherT e) a
inEitherTCtx = Right

-- | Unwraps an interrupted EitherT context
peelEitherTCtx :: RSt (EitherT e) a -> Either e a
peelEitherTCtx = id

instance Interruptible (StateT st) where
  -- | The context of @StateT st a@ is @(a, st)@
  type RSt (StateT st) a = (a, st)
  resume f (a, st) = runStateT (f a) st

-- | Creates an interrupted StateT context
inStateTCtx :: st -> a -> RSt (StateT st) a
inStateTCtx st a = (a, st)

-- | Unwraps an interrupted StateT context
peelStateTCtx :: RSt (StateT st) a -> (a, st)
peelStateTCtx = id


instance Monoid w => Interruptible (WriterT w) where
  type RSt (WriterT w) a = (a, w)
  resume f (a, w) = do
    (a', w') <- runWriterT (f a)
    return (a', mappend w w')

-- | Creates an interrupted WriterT context
inWriterTCtx :: Monoid w => a -> RSt (WriterT w) a
inWriterTCtx a = (a, mempty)

-- | Unwraps an interrupted WriterT context
peelWriterTCtx :: RSt (WriterT w) a -> (a, w)
peelWriterTCtx = id

instance Interruptible (ReaderT r) where
  type RSt (ReaderT r) a = (a, r)
  resume f (a, r) = do
    a' <- runReaderT (f a) r
    return (a', r)
    
-- | Creates an interrupted ReaderT context
inReaderTCtx :: r -> a -> RSt (ReaderT r) a
inReaderTCtx r a = (a, r)

-- | Unwraps an interrupted WriterT context
peelReaderTCtx :: RSt (ReaderT r) a -> a
peelReaderTCtx (a, _) = a

instance Monoid w => Interruptible (RWST r w s) where
  type RSt (RWST r w s) a = (a, r, w, s)
  resume f (a, r, w, s) = do
    (a', s', w') <- runRWST (f a) r s
    return (a', r, w', s')

-- | Creates an interrupted RWST context
inRWSTCtx :: Monoid w => r -> s -> a -> RSt (RWST r w s) a
inRWSTCtx r s a = (a, r, mempty, s)

-- | Unwraps an interrupted RWST context
peelRWSTCtx :: RSt (RWST r w s) a -> (a, w, s)
peelRWSTCtx (a, r, w, s) = (a, w, s)

resume2 :: (Monad m, Interruptible t, Monad (t m), Interruptible u) =>
           (a -> u (t m) b) -> RSt t (RSt u a) -> m (RSt t (RSt u b))
resume2 = resume.resume

resume3 :: (Monad m, Interruptible t0, Monad (t0 m), Interruptible t1,
            Monad (t1 (t0 m)), Interruptible t2) =>
           (a -> t2 (t1 (t0 m)) b) -> RSt t0 (RSt t1 (RSt t2 a)) ->
           m (RSt t0 (RSt t1 (RSt t2 b)))
resume3 = resume2.resume

resume4 :: (Monad m, Interruptible t0, Interruptible t1, Interruptible t2,
            Interruptible t3, Monad (t0 m), Monad (t1 (t0 m)), Monad (t2 (t1 (t0 m)))) =>
           (a -> t3 (t2 (t1 (t0 m))) b) -> RSt t0 (RSt t1 (RSt t2 (RSt t3 a))) ->
           m (RSt t0 (RSt t1 (RSt t2 (RSt t3 b))))
resume4 = resume3.resume

resume5 :: (Monad m, Interruptible t0, Interruptible t1, Interruptible t2,
            Interruptible t3, Interruptible t4, Monad (t0 m), Monad (t1 (t0 m)),
            Monad (t2 (t1 (t0 m))), Monad (t3 (t2 (t1 (t0 m))))) =>
           (a -> t4 (t3 (t2 (t1 (t0 m)))) b) -> RSt t0 (RSt t1 (RSt t2 (RSt t3 (RSt t4 a)))) ->
           m (RSt t0 (RSt t1 (RSt t2 (RSt t3 (RSt t4 b)))))
resume5 = resume4.resume