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

    -- * Miscellany
  , IO
  , MonadIO
  , MonadUnliftIO
  , module Freckle.App.Exception.Types
  ) where

import Freckle.App.Exception.Types

import Control.Applicative (pure)
import Control.Exception.Annotated.UnliftIO (checkpoint, checkpointMany)
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 System.IO (IO)
import UnliftIO (MonadIO, MonadUnliftIO)

import qualified Control.Exception.Annotated.UnliftIO as Annotated
import qualified UnliftIO.Exception

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

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

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

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

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

catchJust
  :: forall e b m a
   . (Exception e, MonadUnliftIO m, HasCallStack)
  => (e -> Maybe b)
  -> m a
  -> (b -> m a)
  -> m a
catchJust :: forall e b (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust e -> Maybe b
test m a
action b -> m a
handler =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
(MonadUnliftIO m, Exception e, HasCallStack) =>
m a -> (e -> m a) -> m a
Annotated.catch m a
action forall a b. (a -> b) -> a -> b
$ \e
e ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.Exception.throwIO e
e) b -> m a
handler (e -> Maybe b
test e
e)

catches
  :: forall m a
   . (MonadUnliftIO 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.
(MonadUnliftIO m, HasCallStack) =>
m a -> [ExceptionHandler m a] -> m a
catches m a
action [ExceptionHandler m a]
handlers =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
m a -> [Handler m a] -> m a
Annotated.catches
      m a
action
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case (ExceptionHandler e -> m a
f) -> 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, MonadUnliftIO 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, MonadUnliftIO m, HasCallStack) =>
m a -> m (Either e a)
try = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall e (m :: * -> *) a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
Annotated.try

tryJust
  :: forall e b m a
   . (Exception e, MonadUnliftIO m, HasCallStack)
  => (e -> Maybe b)
  -> m a
  -- ^ Action to run
  -> m (Either b a)
tryJust :: forall e b (m :: * -> *) a.
(Exception e, MonadUnliftIO m, HasCallStack) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust e -> Maybe b
test m a
action =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
(MonadUnliftIO m, Exception e, HasCallStack) =>
m a -> (e -> m a) -> m a
Annotated.catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action) forall a b. (a -> b) -> a -> b
$ \e
e ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.Exception.throwIO e
e) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (e -> Maybe b
test 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
   . (MonadUnliftIO 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.
(MonadUnliftIO m, HasCallStack) =>
m a -> m a
checkpointCallStack m a
action =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
m a -> m a
Annotated.checkpointCallStack m a
action