-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Util.Exception
  ( -- * General simple helpers
    throwLeft

  , -- * Common exceptions
    TextException (..)

    -- * Better printing of exceptions
  , DisplayExceptionInShow(..)
  , displayUncaughtException
  ) where

import Control.Exception (throwIO)
import Fmt (Buildable(..), pretty)
import System.Exit (ExitCode(..))
import qualified Text.Show

-- | If monadic action returns a 'Left' value, it will be
-- thrown. Otherwise the returned value will be returned as is.
throwLeft :: (MonadThrow m, Exception e) => m (Either e a) -> m a
throwLeft :: m (Either e a) -> m a
throwLeft =
  (m (Either e a) -> (Either e a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left e :: e
e -> e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
      Right x :: a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)

----------------------------------------------------------------------------
-- Common exceptions
----------------------------------------------------------------------------

data TextException = TextException Text
instance Exception TextException

instance Buildable TextException where
  build :: TextException -> Builder
build (TextException desc :: Text
desc) = Text -> Builder
forall p. Buildable p => p -> Builder
build Text
desc

instance Show TextException where
  show :: TextException -> String
show = TextException -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

----------------------------------------------------------------------------
-- Better printing of exceptions at executable-level
----------------------------------------------------------------------------

newtype DisplayExceptionInShow = DisplayExceptionInShow { DisplayExceptionInShow -> SomeException
unDisplayExceptionInShow :: SomeException }

instance Show DisplayExceptionInShow where
  show :: DisplayExceptionInShow -> String
show (DisplayExceptionInShow se :: SomeException
se) = SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
se

instance Exception DisplayExceptionInShow

-- | Customise default uncaught exception handling. The problem with
-- the default handler is that it uses `show` to display uncaught
-- exceptions, but `displayException` may provide more reasonable
-- output. We do not modify uncaught exception handler, but simply
-- wrap uncaught exceptions (only synchronous ones) into
-- 'DisplayExceptionInShow'.
--
-- Some exceptions (currently we are aware only of 'ExitCode') are
-- handled specially by default exception handler, so we don't wrap
-- them.
displayUncaughtException :: IO () -> IO ()
displayUncaughtException :: IO () -> IO ()
displayUncaughtException = (SomeException -> SomeException) -> IO () -> IO ()
forall a. (SomeException -> SomeException) -> IO a -> IO a
mapIOExceptions SomeException -> SomeException
wrapUnlessExitCode
  where
    -- We can't use `mapException` here, because it only works with
    -- exceptions inside pure values, not with `IO` exceptions.
    -- Note: it doesn't catch async exceptions.
    mapIOExceptions :: (SomeException -> SomeException) -> IO a -> IO a
    mapIOExceptions :: (SomeException -> SomeException) -> IO a -> IO a
mapIOExceptions f :: SomeException -> SomeException
f action :: IO a
action = IO a
action IO a -> (SomeException -> IO a) -> IO a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO a)
-> (SomeException -> SomeException) -> SomeException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> SomeException
f)

    -- We don't wrap `ExitCode` because it seems to be handled specially.
    -- Application exit code depends on the value stored in `ExitCode`.
    wrapUnlessExitCode :: SomeException -> SomeException
    wrapUnlessExitCode :: SomeException -> SomeException
wrapUnlessExitCode e :: SomeException
e =
      case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException @ExitCode SomeException
e of
        Just _ -> SomeException
e
        Nothing -> DisplayExceptionInShow -> SomeException
forall e. Exception e => e -> SomeException
toException (DisplayExceptionInShow -> SomeException)
-> DisplayExceptionInShow -> SomeException
forall a b. (a -> b) -> a -> b
$ SomeException -> DisplayExceptionInShow
DisplayExceptionInShow SomeException
e