-- | Support for handling errors of a particular type, i.e. checked exceptions.
--
-- The 'Error' effect is __not__ a general mechanism for handling regular
-- exceptions, that's what functions from the @exceptions@ library are for (see
-- "Control.Monad.Catch" for more information).
--
-- In particular, regular exceptions of type @e@ are distinct from errors of
-- type @e@ and will __not__ be caught by functions from this module:
--
-- >>> import qualified Control.Monad.Catch as E
--
-- >>> boom = error "BOOM!"
--
-- >>> runEff . runError @ErrorCall $ boom `catchError` \_ (_::ErrorCall) -> pure "caught"
-- *** Exception: BOOM!
-- ...
--
-- If you want to catch regular exceptions, you should use
-- 'Control.Monad.Catch.catch' (or a similar function):
--
-- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught"
-- "caught"
--
-- On the other hand, functions for safe finalization and management of
-- resources such as 'Control.Monad.Catch.finally' and
-- 'Control.Monad.Catch.bracket' work as expected:
--
-- >>> msg = liftIO . putStrLn
--
-- >>> :{
-- runEff . runErrorNoCallStack @String $ do
--   E.bracket_ (msg "Beginning.")
--              (msg "Cleaning up.")
--              (msg "Computing." >> throwError "oops" >> msg "More.")
-- :}
-- Beginning.
-- Computing.
-- Cleaning up.
-- Left "oops"
--
-- /Note:/ unlike the 'Control.Monad.Trans.Except.ExceptT' monad transformer
-- from the @transformers@ library, the order in which you handle the 'Error'
-- effect with regard to other stateful effects does not matter. Consider the
-- following:
--
-- >>> import qualified Control.Monad.State.Strict as T
-- >>> import qualified Control.Monad.Except as T
--
-- >>> m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure ()
--
-- >>> (`T.runStateT` "Hi") . T.runExceptT $ m1
-- (Right (),"Hi there!")
--
-- >>> T.runExceptT . (`T.runStateT` "Hi") $ m1
-- Right ((),"Hi")
--
-- Here, whether state updates within the 'catchError' block are discarded or
-- not depends on the shape of the monad transformer stack, which is surprising
-- and can be a source of subtle bugs. On the other hand:
--
-- >>> import Effectful.State.Static.Local
--
-- >>> m2 = (modify (++ " there!") >> throwError "oops") `catchError` \_ (_::String) -> pure ()
--
-- >>> runEff . runState "Hi" . runError @String $ m2
-- (Right (),"Hi there!")
--
-- >>> runEff . runError @String . runState "Hi" $ m2
-- Right ((),"Hi there!")
--
-- Here, no matter the order of effects, state updates made within the
-- @catchError@ block before the error happens always persist, giving
-- predictable behavior.
--
-- /Hint:/ if you'd like to reproduce the transactional behavior with the
-- t'Effectful.State.Static.Local.State' effect, appropriate usage of
-- 'Control.Monad.Catch.bracketOnError' will do the trick.
module Effectful.Error.Static
  ( -- * Effect
    Error

    -- ** Handlers
  , runError
  , runErrorWith
  , runErrorNoCallStack
  , runErrorNoCallStackWith

    -- ** Operations
  , throwError
  , catchError
  , handleError
  , tryError

  -- * Re-exports
  , HasCallStack
  , CallStack
  , getCallStack
  , prettyCallStack
  ) where

import Control.Exception
import GHC.Stack

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Internal.Utils

-- | Provide the ability to handle errors of type @e@.
data Error e :: Effect

type instance DispatchOf (Error e) = Static NoSideEffects
newtype instance StaticRep (Error e) = Error ErrorId

-- | Handle errors of type @e@.
runError
  :: forall e es a
  .  Eff (Error e : es) a
  -> Eff es (Either (CallStack, e) a)
runError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError Eff (Error e : es) a
m = (Env es -> IO (Either (CallStack, e) a))
-> Eff es (Either (CallStack, e) a)
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO (Either (CallStack, e) a))
 -> Eff es (Either (CallStack, e) a))
-> (Env es -> IO (Either (CallStack, e) a))
-> Eff es (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> ((forall a. IO a -> IO a) -> IO (Either (CallStack, e) a))
-> IO (Either (CallStack, e) a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Either (CallStack, e) a))
 -> IO (Either (CallStack, e) a))
-> ((forall a. IO a -> IO a) -> IO (Either (CallStack, e) a))
-> IO (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
  ErrorId
eid <- IO ErrorId
newErrorId
  Env (Error e : es)
es <- EffectRep (DispatchOf (Error e)) (Error e)
-> Relinker (EffectRep (DispatchOf (Error e))) (Error e)
-> Env es
-> IO (Env (Error e : es))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv (forall e. ErrorId -> StaticRep (Error e)
Error @e ErrorId
eid) Relinker (EffectRep (DispatchOf (Error e))) (Error e)
Relinker StaticRep (Error e)
forall (rep :: ((Type -> Type) -> Type -> Type) -> Type)
       (e :: (Type -> Type) -> Type -> Type).
Relinker rep e
dummyRelinker Env es
es0
  Either (CallStack, e) a
r <- (IO a -> IO a)
-> ErrorId -> Env (Error e : es) -> IO (Either (CallStack, e) a)
tryErrorIO IO a -> IO a
forall a. IO a -> IO a
unmask ErrorId
eid Env (Error e : es)
es IO (Either (CallStack, e) a)
-> IO () -> IO (Either (CallStack, e) a)
forall a b. IO a -> IO b -> IO a
`onException` Env (Error e : es) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
Env (e : es) -> IO ()
unconsEnv Env (Error e : es)
es
  Env (Error e : es) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
Env (e : es) -> IO ()
unconsEnv Env (Error e : es)
es
  Either (CallStack, e) a -> IO (Either (CallStack, e) a)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Either (CallStack, e) a
r
  where
    tryErrorIO :: (IO a -> IO a)
-> ErrorId -> Env (Error e : es) -> IO (Either (CallStack, e) a)
tryErrorIO IO a -> IO a
unmask ErrorId
eid Env (Error e : es)
es = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
unmask (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Eff (Error e : es) a -> Env (Error e : es) -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff Eff (Error e : es) a
m Env (Error e : es)
es) IO (Either SomeException a)
-> (Either SomeException a -> IO (Either (CallStack, e) a))
-> IO (Either (CallStack, e) a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right a
a -> Either (CallStack, e) a -> IO (Either (CallStack, e) a)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either (CallStack, e) a -> IO (Either (CallStack, e) a))
-> Either (CallStack, e) a -> IO (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ a -> Either (CallStack, e) a
forall a b. b -> Either a b
Right a
a
      Left SomeException
ex -> SomeException
-> ErrorId
-> (CallStack -> e -> Either (CallStack, e) a)
-> IO (Either (CallStack, e) a)
-> IO (Either (CallStack, e) a)
forall e r.
SomeException -> ErrorId -> (CallStack -> e -> r) -> IO r -> IO r
tryHandler SomeException
ex ErrorId
eid (\CallStack
cs e
e -> (CallStack, e) -> Either (CallStack, e) a
forall a b. a -> Either a b
Left (CallStack
cs, e
e))
               (IO (Either (CallStack, e) a) -> IO (Either (CallStack, e) a))
-> IO (Either (CallStack, e) a) -> IO (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ SomeException -> IO (Either (CallStack, e) a)
forall e a. Exception e => e -> IO a
throwIO SomeException
ex

-- | Handle errors of type @e@ with a specific error handler.
--
-- @since 2.3.0.0
runErrorWith
  :: (CallStack -> e -> Eff es a)
  -- ^ The error handler.
  -> Eff (Error e : es) a
  -> Eff es a
runErrorWith :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(CallStack -> e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
runErrorWith CallStack -> e -> Eff es a
handler Eff (Error e : es) a
m = Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError Eff (Error e : es) a
m Eff es (Either (CallStack, e) a)
-> (Either (CallStack, e) a -> Eff es a) -> Eff es a
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left (CallStack
cs, e
e) -> CallStack -> e -> Eff es a
handler CallStack
cs e
e
  Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

-- | Handle errors of type @e@. In case of an error discard the 'CallStack'.
--
-- @since 2.3.0.0
runErrorNoCallStack
  :: forall e es a
  .  Eff (Error e : es) a
  -> Eff es (Either e a)
runErrorNoCallStack :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack = (Either (CallStack, e) a -> Either e a)
-> Eff es (Either (CallStack, e) a) -> Eff es (Either e a)
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CallStack, e) -> Either e a)
-> (a -> Either e a) -> Either (CallStack, e) a -> Either e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e -> Either e a
forall a b. a -> Either a b
Left (e -> Either e a)
-> ((CallStack, e) -> e) -> (CallStack, e) -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CallStack, e) -> e
forall a b. (a, b) -> b
snd) a -> Either e a
forall a b. b -> Either a b
Right) (Eff es (Either (CallStack, e) a) -> Eff es (Either e a))
-> (Eff (Error e : es) a -> Eff es (Either (CallStack, e) a))
-> Eff (Error e : es) a
-> Eff es (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError

-- | Handle errors of type @e@ with a specific error handler. In case of an
-- error discard the 'CallStack'.
runErrorNoCallStackWith
  :: (e -> Eff es a)
  -- ^ The error handler.
  -> Eff (Error e : es) a
  -> Eff es a
runErrorNoCallStackWith :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
runErrorNoCallStackWith e -> Eff es a
handler Eff (Error e : es) a
m = Eff (Error e : es) a -> Eff es (Either e a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack Eff (Error e : es) a
m Eff es (Either e a) -> (Either e a -> Eff es a) -> Eff es a
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left e
e -> e -> Eff es a
handler e
e
  Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

-- | Throw an error of type @e@.
throwError
  :: forall e es a. (HasCallStack, Error e :> es)
  => e
  -- ^ The error.
  -> Eff es a
throwError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError e
e = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Error ErrorId
eid <- forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv @(Error e) Env es
es
  ErrorWrapper -> IO a
forall e a. Exception e => e -> IO a
throwIO (ErrorWrapper -> IO a) -> ErrorWrapper -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorId -> CallStack -> Any -> ErrorWrapper
ErrorWrapper ErrorId
eid CallStack
HasCallStack => CallStack
callStack (e -> Any
forall a. a -> Any
toAny e
e)

-- | Handle an error of type @e@.
catchError
  :: forall e es a. Error e :> es
  => Eff es a
  -- ^ The inner computation.
  -> (CallStack -> e -> Eff es a)
  -- ^ A handler for errors in the inner computation.
  -> Eff es a
catchError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
catchError Eff es a
m CallStack -> e -> Eff es a
handler = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Error ErrorId
eid <- forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv @(Error e) Env es
es
  ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
forall a e. ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
catchErrorIO ErrorId
eid (Eff es a -> Env es -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es) ((CallStack -> e -> IO a) -> IO a)
-> (CallStack -> e -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \CallStack
cs e
e -> do
    Eff es a -> Env es -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff (CallStack -> e -> Eff es a
handler CallStack
cs e
e) Env es
es

-- | The same as @'flip' 'catchError'@, which is useful in situations where the
-- code for the handler is shorter.
handleError
  :: forall e es a. Error e :> es
  => (CallStack -> e -> Eff es a)
  -- ^ A handler for errors in the inner computation.
  -> Eff es a
  -- ^ The inner computation.
  -> Eff es a
handleError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
(CallStack -> e -> Eff es a) -> Eff es a -> Eff es a
handleError = (Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a)
-> (CallStack -> e -> Eff es a) -> Eff es a -> Eff es a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
catchError

-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'
-- if no error was thrown and a 'Left' otherwise.
tryError
  :: forall e es a. Error e :> es
  => Eff es a
  -- ^ The inner computation.
  -> Eff es (Either (CallStack, e) a)
tryError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> Eff es (Either (CallStack, e) a)
tryError Eff es a
m = (a -> Either (CallStack, e) a
forall a b. b -> Either a b
Right (a -> Either (CallStack, e) a)
-> Eff es a -> Eff es (Either (CallStack, e) a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es a
m) Eff es (Either (CallStack, e) a)
-> (CallStack -> e -> Eff es (Either (CallStack, e) a))
-> Eff es (Either (CallStack, e) a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
`catchError` \CallStack
es e
e -> Either (CallStack, e) a -> Eff es (Either (CallStack, e) a)
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either (CallStack, e) a -> Eff es (Either (CallStack, e) a))
-> Either (CallStack, e) a -> Eff es (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ (CallStack, e) -> Either (CallStack, e) a
forall a b. a -> Either a b
Left (CallStack
es, e
e)

----------------------------------------
-- Helpers

newtype ErrorId = ErrorId Unique
  deriving ErrorId -> ErrorId -> Bool
(ErrorId -> ErrorId -> Bool)
-> (ErrorId -> ErrorId -> Bool) -> Eq ErrorId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorId -> ErrorId -> Bool
== :: ErrorId -> ErrorId -> Bool
$c/= :: ErrorId -> ErrorId -> Bool
/= :: ErrorId -> ErrorId -> Bool
Eq

-- | A unique is picked so that distinct 'Error' handlers for the same type
-- don't catch each other's exceptions.
newErrorId :: IO ErrorId
newErrorId :: IO ErrorId
newErrorId = Unique -> ErrorId
ErrorId (Unique -> ErrorId) -> IO Unique -> IO ErrorId
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

tryHandler
  :: SomeException
  -> ErrorId
  -> (CallStack -> e -> r)
  -> IO r
  -> IO r
tryHandler :: forall e r.
SomeException -> ErrorId -> (CallStack -> e -> r) -> IO r -> IO r
tryHandler SomeException
ex ErrorId
eid0 CallStack -> e -> r
handler IO r
next = case SomeException -> Maybe ErrorWrapper
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex of
  Just (ErrorWrapper ErrorId
eid CallStack
cs Any
e)
    | ErrorId
eid0 ErrorId -> ErrorId -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorId
eid -> r -> IO r
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (r -> IO r) -> r -> IO r
forall a b. (a -> b) -> a -> b
$ CallStack -> e -> r
handler CallStack
cs (Any -> e
forall a. Any -> a
fromAny Any
e)
    | Bool
otherwise   -> IO r
next
  Maybe ErrorWrapper
Nothing -> IO r
next

data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any
instance Show ErrorWrapper where
  showsPrec :: Int -> ErrorWrapper -> ShowS
showsPrec Int
p (ErrorWrapper ErrorId
_ CallStack
cs Any
_)
    = (String
"Effectful.Error.Static.ErrorWrapper\n\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (CallStack -> String
prettyCallStack CallStack
cs)
instance Exception ErrorWrapper

catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
catchErrorIO :: forall a e. ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
catchErrorIO ErrorId
eid IO a
m CallStack -> e -> IO a
handler = do
  IO a
m IO a -> (ErrorWrapper -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \err :: ErrorWrapper
err@(ErrorWrapper ErrorId
etag CallStack
cs Any
e) -> do
    if ErrorId
eid ErrorId -> ErrorId -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorId
etag
      then CallStack -> e -> IO a
handler CallStack
cs (Any -> e
forall a. Any -> a
fromAny Any
e)
      else ErrorWrapper -> IO a
forall e a. Exception e => e -> IO a
throwIO ErrorWrapper
err