module Freckle.App.Exception.MonadThrow
  ( throwM
  , throwString
  , fromJustNoteM
  , impossible
  , catch
  , catchJust
  , catches
  , try
  , tryJust
  , withException
  , checkpoint
  , checkpointMany
  , checkpointCallStack

    -- * Miscellany
  , MonadThrow
  , MonadCatch
  , MonadMask
  , module Freckle.App.Exception.Types
  ) where

import Freckle.App.Exception.Types

import Control.Applicative (pure)
import Control.Exception.Annotated (checkpoint, checkpointMany)
import Control.Monad (void)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Data.Either (Either (..))
import Data.Function (($), (.))
import Data.Functor (fmap, (<$>))
import Data.Maybe (Maybe, maybe)
import Data.String (String)
import GHC.IO.Exception (userError)
import GHC.Stack (withFrozenCallStack)

import Control.Exception.Annotated qualified as Annotated
import Control.Monad.Catch qualified

-- Throws an exception, wrapped in 'AnnotatedException' which includes a call stack
throwM :: forall e m a. (Exception e, MonadThrow m, HasCallStack) => e -> m a
throwM :: forall e (m :: * -> *) a.
(Exception e, MonadThrow m, HasCallStack) =>
e -> m a
throwM e
e = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ e -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Annotated.throw e
e

throwString :: forall m a. (MonadThrow m, HasCallStack) => String -> m a
throwString :: forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
s = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ IOError -> m a
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, HasCallStack) =>
e -> m a
throwM (IOError -> m a) -> IOError -> m a
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
s

fromJustNoteM
  :: forall m a. (MonadThrow m, HasCallStack) => String -> Maybe a -> m a
fromJustNoteM :: forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> Maybe a -> m a
fromJustNoteM String
err = (HasCallStack => Maybe a -> m a) -> Maybe a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Maybe a -> m a) -> Maybe a -> m a)
-> (HasCallStack => Maybe a -> m a) -> Maybe a -> m a
forall a b. (a -> b) -> a -> b
$ m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
err) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

impossible :: forall m a. (MonadThrow m, HasCallStack) => m a
impossible :: forall (m :: * -> *) a. (MonadThrow m, HasCallStack) => m a
impossible = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ String -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
"Impossible"

catch
  :: forall e m a
   . (Exception e, MonadCatch m, HasCallStack)
  => m a
  -> (e -> m a)
  -> m a
catch :: forall e (m :: * -> *) a.
(Exception e, MonadCatch m, HasCallStack) =>
m a -> (e -> m a) -> m a
catch m a
action e -> m a
handler = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
Annotated.catch m a
action e -> m a
handler

catchJust
  :: forall e b m a
   . (Exception e, MonadCatch m, HasCallStack)
  => (e -> Maybe b)
  -> m a
  -> (b -> m a)
  -> m a
catchJust :: forall e b (m :: * -> *) a.
(Exception e, MonadCatch m, HasCallStack) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust e -> Maybe b
test m a
action b -> m a
handler =
  (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
Annotated.catch m a
action ((e -> m a) -> m a) -> (e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \e
e ->
    m a -> (b -> m a) -> Maybe b -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Control.Monad.Catch.throwM e
e) b -> m a
handler (e -> Maybe b
test e
e)

catches
  :: forall m a
   . (MonadCatch m, HasCallStack)
  => m a
  -- ^ Action to run
  -> [ExceptionHandler m a]
  -- ^ Recovery actions to run if the first action throws an exception
  --   with a type of either @e@ or @'AnnotatedException' e@
  -> m a
catches :: forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
m a -> [ExceptionHandler m a] -> m a
catches m a
action [ExceptionHandler m a]
handlers =
  (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$
    m a -> [Handler m a] -> m a
forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
m a -> [Handler m a] -> m a
Annotated.catches
      m a
action
      ((ExceptionHandler m a -> Handler m a)
-> [ExceptionHandler m a] -> [Handler m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case (ExceptionHandler e -> m a
f) -> (e -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Annotated.Handler e -> m a
f) [ExceptionHandler m a]
handlers)

try
  :: forall e m a
   . (Exception e, MonadCatch m, HasCallStack)
  => m a
  -- ^ Action to run
  -> m (Either e a)
  -- ^ Returns 'Left' if the action throws an exception with a type
  --   of either @e@ or @'AnnotatedException' e@
try :: forall e (m :: * -> *) a.
(Exception e, MonadCatch m, HasCallStack) =>
m a -> m (Either e a)
try m a
action = (HasCallStack => m (Either e a)) -> m (Either e a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Either e a)) -> m (Either e a))
-> (HasCallStack => m (Either e a)) -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ m a -> m (Either e a)
forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
m a -> m (Either e a)
Annotated.try m a
action

tryJust
  :: forall e b m a
   . (Exception e, MonadCatch m, HasCallStack)
  => (e -> Maybe b)
  -> m a
  -- ^ Action to run
  -> m (Either b a)
tryJust :: forall e b (m :: * -> *) a.
(Exception e, MonadCatch m, HasCallStack) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust e -> Maybe b
test m a
action =
  (HasCallStack => m (Either b a)) -> m (Either b a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Either b a)) -> m (Either b a))
-> (HasCallStack => m (Either b a)) -> m (Either b a)
forall a b. (a -> b) -> a -> b
$ m (Either b a) -> (e -> m (Either b a)) -> m (Either b a)
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
Annotated.catch (a -> Either b a
forall a b. b -> Either a b
Right (a -> Either b a) -> m a -> m (Either b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action) ((e -> m (Either b a)) -> m (Either b a))
-> (e -> m (Either b a)) -> m (Either b a)
forall a b. (a -> b) -> a -> b
$ \e
e ->
    m (Either b a)
-> (b -> m (Either b a)) -> Maybe b -> m (Either b a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m (Either b a)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Control.Monad.Catch.throwM e
e) (Either b a -> m (Either b a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b a -> m (Either b a))
-> (b -> Either b a) -> b -> m (Either b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either b a
forall a b. a -> Either a b
Left) (e -> Maybe b
test e
e)

withException
  :: forall e a m b
   . (Exception e, MonadCatch m, HasCallStack)
  => m a
  -> (e -> m b)
  -> m a
withException :: forall e a (m :: * -> *) b.
(Exception e, MonadCatch m, HasCallStack) =>
m a -> (e -> m b) -> m a
withException m a
action e -> m b
onException =
  (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
Annotated.catch m a
action ((e -> m a) -> m a) -> (e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \e
e -> do
    m b -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m b -> m ()) -> m b -> m ()
forall a b. (a -> b) -> a -> b
$ e -> m b
onException e
e
    e -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Control.Monad.Catch.throwM e
e

-- | When dealing with a library that does not use 'AnnotatedException',
--   apply this function to augment its exceptions with call stacks.
checkpointCallStack
  :: forall m a
   . (MonadCatch m, HasCallStack)
  => m a
  -- ^ Action that might throw whatever types of exceptions
  -> m a
  -- ^ Action that only throws 'AnnotatedException',
  --   where the annotations include a call stack
checkpointCallStack :: forall (m :: * -> *) a. (MonadCatch m, HasCallStack) => m a -> m a
checkpointCallStack m a
action =
  (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> m a
forall (m :: * -> *) a. (MonadCatch m, HasCallStack) => m a -> m a
Annotated.checkpointCallStack m a
action