{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}
-- | Exception-producing and exception-handling effects
module Control.Eff.Exception ( Exc (..)
                            , exc
                            , withException
                            , Fail
                            , throwError
                            , throwError_
                            , die
                            , runError
                            , runFail
                            , catchError
                            , onFail
                            , rethrowError
                            , liftEither
                            , liftEitherM
                            , liftMaybe
                            , liftMaybeM
                            , ignoreFail
                            ) where

import Control.Eff
import Control.Eff.Extend

import Control.Monad (void)
import Control.Monad.Base
import Control.Monad.Trans.Control

import Data.Function (fix)

-- ------------------------------------------------------------------------
-- | Exceptions
--
-- exceptions of the type e; no resumption
newtype Exc e v = Exc e

-- | Embed a pure value
withException :: Monad m => a -> m (Either e a)
withException = return . Right
-- | Throw an error
exc :: Monad m => e -> m (Either e a)
exc = return . Left
-- | Given a callback, and an 'Exc' request, respond to it.
instance Monad m => Handle (Exc e) r a (m (Either e a)) where
  handle _ _ (Exc e) = exc e

instance ( MonadBase m m
         , LiftedBase m r
         ) => MonadBaseControl m (Eff (Exc e ': r)) where
    type StM (Eff (Exc e ': r)) a = StM (Eff r) (Either e a)
    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->
                       f (runInBase . runError)
    restoreM x = do r :: Either e a <- raise (restoreM x)
                    liftEither r

type Fail = Exc ()

-- | Throw an exception in an effectful computation. The type is inferred.
throwError :: (Member (Exc e) r) => e -> Eff r a
throwError e = send (Exc e)
{-# INLINE throwError #-}

-- | Throw an exception in an effectful computation. The type is unit,
--   which suppresses the ghc-mod warning "A do-notation statement
--   discarded a result of type"
throwError_ :: (Member (Exc e) r) => e -> Eff r ()
throwError_ = throwError
{-# INLINE throwError_ #-}

-- | Makes an effect fail, preventing future effects from happening.
die :: Member Fail r => Eff r a
die = throwError ()
{-# INLINE die #-}

-- | Run a computation that might produce an exception.
runError :: Eff (Exc e ': r) a -> Eff r (Either e a)
runError = fix (handle_relay withException)

-- | Runs a failable effect, such that failed computation return 'Nothing', and
--   'Just' the return value on success.
runFail :: Eff (Fail ': r) a -> Eff r (Maybe a)
runFail = fmap (either (const Nothing) Just) . runError
{-# INLINE runFail #-}

-- | Run a computation that might produce exceptions, and give it a way to deal
-- with the exceptions that come up. The handler is allowed to rethrow the
-- exception
catchError :: Member (Exc e) r =>
        Eff r a -> (e -> Eff r a) -> Eff r a
catchError m h = fix (respond_relay' (\_ _ (Exc e) -> h e) return) m

-- | Add a default value (i.e. failure handler) to a fallible computation.
-- This hides the fact that a failure happened.
onFail :: Eff (Fail ': r) a -- ^ The fallible computation.
       -> Eff r a           -- ^ The computation to run on failure.
       -> Eff r a
onFail e handle_ = runFail e >>= maybe handle_ return
{-# INLINE onFail #-}

-- | Run a computation until it produces an exception,
-- and convert and throw that exception in a new context.
rethrowError :: (Member (Exc e') r)
           => (e -> e')
           -> Eff (Exc e ': r) a
           -> Eff r a
rethrowError t e = runError e >>= either (throwError . t) return

-- | Treat Lefts as exceptions and Rights as return values.
liftEither :: (Member (Exc e) r) => Either e a -> Eff r a
liftEither = either throwError return
{-# INLINE liftEither #-}

-- | `liftEither` in a lifted Monad
liftEitherM :: (Member (Exc e) r, Lifted m r)
            => m (Either e a)
            -> Eff r a
liftEitherM m = lift m >>= liftEither
{-# INLINE liftEitherM #-}

-- | Lift a maybe into the 'Fail' effect, causing failure if it's 'Nothing'.
liftMaybe :: Member Fail r => Maybe a -> Eff r a
liftMaybe = maybe die return
{-# INLINE liftMaybe #-}

-- | `liftMaybe` in a lifted Monad
liftMaybeM :: (Member Fail r, Lifted m r)
           => m (Maybe a)
           -> Eff r a
liftMaybeM m = lift m >>= liftMaybe
{-# INLINE liftMaybeM #-}

-- | Ignores a failure event. Since the event can fail, you cannot inspect its
--   return type, because it has none on failure. To inspect it, use 'runFail'.
ignoreFail :: Eff (Fail ': r) a
           -> Eff r ()
ignoreFail e = void e `onFail` return ()
{-# INLINE ignoreFail #-}