-- | 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 "Effectful.Exception" module are
-- for.
--
-- 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 Effectful.Exception qualified 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
-- 'Effectful.Exception.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 'Effectful.Exception.finally' and
-- 'Effectful.Exception.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 Control.Monad.State.Strict qualified as T
-- >>> import Control.Monad.Except qualified 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
-- 'Effectful.Exception.bracketOnError' will do the trick.
module Effectful.Error.Static
  ( -- * Effect
    Error

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

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

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

import Data.Kind
import GHC.Stack

import Effectful
import Effectful.Dispatch.Static
import Effectful.Exception
import Effectful.Internal.Utils

-- | Provide the ability to handle errors of type @e@.
data Error (e :: Type) :: 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
   . HasCallStack
  => Eff (Error e : es) a
  -> Eff es (Either (CallStack, e) a)
runError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError Eff (Error e : es) a
action = do
  ErrorId
eid <- IO ErrorId -> Eff es ErrorId
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ IO ErrorId
newErrorId
  StaticRep (Error e)
-> Eff (Error e : es) (Either (CallStack, e) a)
-> Eff es (Either (CallStack, e) a)
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (forall e. ErrorId -> StaticRep (Error e)
Error @e ErrorId
eid) (Eff (Error e : es) (Either (CallStack, e) a)
 -> Eff es (Either (CallStack, e) a))
-> Eff (Error e : es) (Either (CallStack, e) a)
-> Eff es (Either (CallStack, e) a)
forall a b. (a -> b) -> a -> b
$ do
    (ErrorWrapper -> Maybe (CallStack, e))
-> Eff (Error e : es) a
-> Eff (Error e : es) (Either (CallStack, e) a)
forall e b (es :: [(Type -> Type) -> Type -> Type]) a.
Exception e =>
(e -> Maybe b) -> Eff es a -> Eff es (Either b a)
tryJust (ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
forall e. ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
matchError ErrorId
eid) Eff (Error e : es) a
action

-- | Handle errors of type @e@ with a specific error handler.
--
-- @since 2.3.0.0
runErrorWith
  :: HasCallStack
  => (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.
HasCallStack =>
(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
action = Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)
runError Eff (Error e : es) a
action 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
   . HasCallStack
  => Eff (Error e : es) a
  -> Eff es (Either e a)
runErrorNoCallStack :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
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.
HasCallStack =>
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
  :: HasCallStack
  => (e -> Eff es a)
  -- ^ The error handler.
  -> Eff (Error e : es) a
  -> Eff es a
runErrorNoCallStackWith :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
(e -> Eff es a) -> Eff (Error e : es) a -> Eff es a
runErrorNoCallStackWith e -> Eff es a
handler Eff (Error e : es) a
action = Eff (Error e : es) a -> Eff es (Either e a)
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack Eff (Error e : es) a
action 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@ and specify a display function in case a
-- third-party code catches the internal exception and 'show's it.
--
-- @since 2.4.0.0
throwErrorWith
  :: forall e es a. (HasCallStack, Error e :> es)
  => (e -> String)
  -- ^ The display function.
  -> e
  -- ^ The error.
  -> Eff es a
throwErrorWith :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
(e -> String) -> e -> Eff es a
throwErrorWith e -> String
display e
e = do
  Error ErrorId
eid <- forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep @(Error e)
  (HasCallStack => ErrorWrapper -> Eff es a)
-> ErrorWrapper -> Eff es a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => ErrorWrapper -> Eff es a
ErrorWrapper -> Eff es a
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (ErrorWrapper -> Eff es a) -> ErrorWrapper -> Eff es a
forall a b. (a -> b) -> a -> b
$ ErrorId -> CallStack -> String -> Any -> ErrorWrapper
ErrorWrapper ErrorId
eid CallStack
HasCallStack => CallStack
callStack (e -> String
display e
e) (e -> Any
forall a. a -> Any
toAny e
e)

-- | Throw an error of type @e@ with 'show' as a display function.
throwError
  :: forall e es a. (HasCallStack, Error e :> es, Show e)
  => e
  -- ^ The error.
  -> Eff es a
throwError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError = (HasCallStack => (e -> String) -> e -> Eff es a)
-> (e -> String) -> e -> Eff es a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => (e -> String) -> e -> Eff es a
(e -> String) -> e -> Eff es a
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
(e -> String) -> e -> Eff es a
throwErrorWith e -> String
forall a. Show a => a -> String
show

-- | Throw an error of type @e@ with no display function.
--
-- @since 2.4.0.0
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_ = (HasCallStack => (e -> String) -> e -> Eff es a)
-> (e -> String) -> e -> Eff es a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => (e -> String) -> e -> Eff es a
(e -> String) -> e -> Eff es a
forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
(e -> String) -> e -> Eff es a
throwErrorWith (String -> e -> String
forall a b. a -> b -> a
const String
"<opaque>")

-- | Handle an error of type @e@.
catchError
  :: forall e es a. (HasCallStack, 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.
(HasCallStack, Error e :> es) =>
Eff es a -> (CallStack -> e -> Eff es a) -> Eff es a
catchError Eff es a
action CallStack -> e -> Eff es a
handler = do
  Error ErrorId
eid <- forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep @(Error e)
  (ErrorWrapper -> Maybe (CallStack, e))
-> Eff es a -> ((CallStack, e) -> Eff es a) -> Eff es a
forall e b (es :: [(Type -> Type) -> Type -> Type]) a.
Exception e =>
(e -> Maybe b) -> Eff es a -> (b -> Eff es a) -> Eff es a
catchJust (ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
forall e. ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
matchError ErrorId
eid) Eff es a
action (((CallStack, e) -> Eff es a) -> Eff es a)
-> ((CallStack, e) -> Eff es a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \(CallStack
cs, e
e) -> CallStack -> e -> Eff es a
handler CallStack
cs e
e

-- | The same as @'flip' 'catchError'@, which is useful in situations where the
-- code for the handler is shorter.
handleError
  :: forall e es a. (HasCallStack, 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.
(HasCallStack, 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.
(HasCallStack, 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. (HasCallStack, Error e :> es)
  => Eff es a
  -- ^ The inner computation.
  -> Eff es (Either (CallStack, e) a)
tryError :: forall e (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Error e :> es) =>
Eff es a -> Eff es (Either (CallStack, e) a)
tryError Eff es a
action = do
  Error ErrorId
eid <- forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
Eff es (StaticRep e)
getStaticRep @(Error e)
  (ErrorWrapper -> Maybe (CallStack, e))
-> Eff es a -> Eff es (Either (CallStack, e) a)
forall e b (es :: [(Type -> Type) -> Type -> Type]) a.
Exception e =>
(e -> Maybe b) -> Eff es a -> Eff es (Either b a)
tryJust (ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
forall e. ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
matchError ErrorId
eid) Eff es a
action

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

newtype ErrorId = ErrorId Unique
  deriving newtype 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

data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any

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

instance Exception ErrorWrapper

matchError :: ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
matchError :: forall e. ErrorId -> ErrorWrapper -> Maybe (CallStack, e)
matchError ErrorId
eid (ErrorWrapper ErrorId
etag CallStack
cs String
_ Any
e)
  | ErrorId
eid ErrorId -> ErrorId -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorId
etag = (CallStack, e) -> Maybe (CallStack, e)
forall a. a -> Maybe a
Just (CallStack
cs, Any -> e
forall a. Any -> a
fromAny Any
e)
  | Bool
otherwise = Maybe (CallStack, e)
forall a. Maybe a
Nothing