Synchronous.hs

{- |
Synchronous exceptions immediately abort a series of computations.
We provide monads for describing this behaviour.
-}
module Control.Monad.Exception.Synchronous where

import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (liftM, )
import Control.Monad.Fix (MonadFix, mfix, )
import Control.Monad.Trans (MonadTrans, lift, )
import Control.Monad.Error (ErrorT(ErrorT, runErrorT))

import Prelude hiding (catch, )


-- * Plain monad

{- |
Like 'Either', but explicitly intended for handling of exceptional results.
In contrast to 'Either' we do not support 'fail'.
Calling 'fail' in the 'Exceptional' monad is an error.
-}
data Exceptional e a =
     Success a
   | Exception e
   deriving (Show, Eq)


fromMaybe :: e -> Maybe a -> Exceptional e a
fromMaybe e = maybe (Exception e) Success

fromEither :: Either e a -> Exceptional e a
fromEither = either Exception Success

toEither :: Exceptional e a -> Either e a
toEither x =
   case x of
      Success a   -> Right a
      Exception e -> Left e

{- |
If you are sure that the value is always a 'Success'
you can tell that the run-time system
thus making your program lazy.
However, try to avoid this function by using 'catch' and friends,
since this function is partial.
-}
force :: Exceptional e a -> Exceptional e a
force ~(Success a) = Success a

mapException :: (e0 -> e1) -> Exceptional e0 a -> Exceptional e1 a
mapException f x =
   case x of
      Success a   -> Success a
      Exception e -> Exception (f e)

mapExceptional :: (e0 -> e1) -> (a -> b) -> Exceptional e0 a -> Exceptional e1 b
mapExceptional f g x =
   case x of
      Success a   -> Success (g a)
      Exception e -> Exception (f e)

throw :: e -> Exceptional e a
throw = Exception

catch :: Exceptional e0 a -> (e0 -> Exceptional e1 a) -> Exceptional e1 a
catch x handler =
   case x of
      Success a   -> Success a
      Exception e -> handler e

{-
bracket ::
   Exceptional e h ->
   (h -> Exceptional e ()) ->
   (h -> Exceptional e a) ->
   Exceptional e a
bracket open close action =
   open >>= \h ->
   case action h of
-}

resolve :: (e -> a) -> Exceptional e a -> a
resolve handler x =
   case x of
      Success a   -> a
      Exception e -> handler e


instance Functor (Exceptional e) where
   fmap f x =
      case x of
         Success a   -> Success (f a)
         Exception e -> Exception e

instance Applicative (Exceptional e) where
   pure = Success
   f <*> x =
      case f of
         Exception e -> Exception e
         Success g ->
            case x of
               Success a   -> Success (g a)
               Exception e -> Exception e

instance Monad (Exceptional e) where
   return = Success
   fail _msg = Exception (error "Exception.Synchronous: Monad.fail method is not supported")
   x >>= f =
      case x of
         Exception e -> Exception e
         Success y -> f y

instance MonadFix (Exceptional e) where
    mfix f =
       let unSuccess ~(Success x) = x
           a = f (unSuccess a)
       in  a



-- * Monad transformer

-- | like ErrorT, but ExceptionalT is the better name in order to distinguish from real (programming) errors
newtype ExceptionalT e m a =
   ExceptionalT {runExceptionalT :: m (Exceptional e a)}


fromErrorT :: Monad m => ErrorT e m a -> ExceptionalT e m a
fromErrorT  =  ExceptionalT . liftM fromEither . runErrorT

toErrorT :: Monad m => ExceptionalT e m a -> ErrorT e m a
toErrorT  =  ErrorT . liftM toEither . runExceptionalT

{- |
see 'force'
-}
forceT :: Monad m => ExceptionalT e m a -> ExceptionalT e m a
forceT =
   ExceptionalT . liftM force . runExceptionalT


mapExceptionT :: (Monad m) =>
   (e0 -> e1) ->
   ExceptionalT e0 m a ->
   ExceptionalT e1 m a
mapExceptionT f =
   ExceptionalT . liftM (mapException f) . runExceptionalT

mapExceptionalT ::
   (m (Exceptional e0 a) -> n (Exceptional e1 b)) ->
   ExceptionalT e0 m a -> ExceptionalT e1 n b
mapExceptionalT f =
   ExceptionalT . f . runExceptionalT

throwT :: (Monad m) =>
   e -> ExceptionalT e m a
throwT = ExceptionalT . return . throw

catchT :: (Monad m) =>
   ExceptionalT e0 m a ->
   (e0 -> ExceptionalT e1 m a) ->
   ExceptionalT e1 m a
catchT action handler =
   ExceptionalT $
   runExceptionalT action >>= \x ->
      case x of
         Success a   -> return $ Success a
         Exception e -> runExceptionalT $ handler e

{- |
If the enclosed monad has custom exception facilities,
they could skip the cleanup code.
Make sure, that this cannot happen by choosing an appropriate monad.
-}
bracketT :: (Monad m) =>
   ExceptionalT e m h ->
   (h -> ExceptionalT e m ()) ->
   (h -> ExceptionalT e m a) ->
   ExceptionalT e m a
bracketT open close action =
   open >>= \h ->
      ExceptionalT $
         do a <- runExceptionalT (action h)
            c <- runExceptionalT (close h)
            return (a >>= \r -> c >> return r)

resolveT :: (Monad m) =>
   (e -> m a) -> ExceptionalT e m a -> m a
resolveT handler x =
   do r <- runExceptionalT x
      resolve handler (fmap return r)

tryT :: (Monad m) =>
   ExceptionalT e m a -> m (Exceptional e a)
tryT = runExceptionalT


{- |
Repeat an action until an exception occurs.
Initialize the result with @empty@ and add new elements using @cons@
(e.g. @[]@ and @(:)@).
The exception handler decides whether the terminating exception
is re-raised ('Just') or catched ('Nothing').
-}
manyT :: (Monad m) =>
   (e0 -> Maybe e1)        {- ^ exception handler -} ->
   (a -> b -> b)           {- ^ @cons@ function -} ->
   b                       {- ^ @empty@ -} ->
   ExceptionalT e0 m a     {- ^ atomic action to repeat -} ->
   ExceptionalT e1 m b
manyT handler cons empty action =
   let recurse =
          do r <- lift $ tryT action
             case r of
                Exception e -> maybe (return empty) throwT (handler e)
                Success x   -> liftM (cons x) recurse
   in  recurse




instance Functor m => Functor (ExceptionalT e m) where
   fmap f (ExceptionalT x) =
      ExceptionalT (fmap (fmap f) x)

instance Applicative m => Applicative (ExceptionalT e m) where
   pure = ExceptionalT . pure . pure
   ExceptionalT f <*> ExceptionalT x =
      ExceptionalT (fmap (<*>) f <*> x)

instance Monad m => Monad (ExceptionalT e m) where
   return = ExceptionalT . return . return
   x0 >>= f =
      ExceptionalT $
         runExceptionalT x0 >>= \x1 ->
         case x1 of
            Exception e -> return (Exception e)
            Success x -> runExceptionalT $ f x

instance (MonadFix m) => MonadFix (ExceptionalT e m) where
   mfix f = ExceptionalT $ mfix $ \(Success r) -> runExceptionalT $ f r

instance MonadTrans (ExceptionalT e) where
   lift m = ExceptionalT $ liftM Success m