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, {- MonadPlus(mzero, mplus), -})
import Control.Monad.Fix (MonadFix, mfix, )
import Control.Monad.Trans (MonadTrans, lift, {- MonadIO(liftIO), -} )
import Control.Monad.Trans.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.
This way, we do not require that an exception can be derived from a 'String',
yet, we require no constraint on the exception type at all.
-}
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

-- | useful in connection with 'Control.Monad.Exception.Asynchronous.continue'
getExceptionNull :: Exceptional e () -> Maybe e
getExceptionNull x =
   case x of
      Success _   -> Nothing
      Exception e -> Just 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

{-
A MonadPlus instance would require another class, say DefaultException,
that provides a default exception used for @mzero@.
In Control.Monad.Error this is handled by the Error class.
Since String is a typical type used for exceptions -
shall there be a DefaultException String instance?
-}



-- * 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  =  fromEitherT . runErrorT

toErrorT :: Monad m => ExceptionalT e m a -> ErrorT e m a
toErrorT  =  ErrorT . toEitherT

fromEitherT :: Monad m => m (Either e a) -> ExceptionalT e m a
fromEitherT  =  ExceptionalT . liftM fromEither

toEitherT :: Monad m => ExceptionalT e m a -> m (Either e a)
toEitherT  =  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 recourse =
          do r <- lift $ tryT action
             case r of
                Exception e -> maybe (return empty) throwT (handler e)
                Success x   -> liftM (cons x) recourse
   in  recourse




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

{-
instance MonadIO m => MonadIO (ExceptionalT e m) where
   liftIO act = ExceptionalT $ liftIO $ liftM Success act
-}