-- 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 =
  (>>= \case
      Left e -> throwM e
      Right x -> return x)

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

data TextException = TextException Text
instance Exception TextException

instance Buildable TextException where
  build (TextException desc) = build desc

instance Show TextException where
  show = pretty

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

newtype DisplayExceptionInShow = DisplayExceptionInShow { unDisplayExceptionInShow :: SomeException }

instance Show DisplayExceptionInShow where
  show (DisplayExceptionInShow se) = displayException 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 = mapIOExceptions 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 f action = action `catchAny` (throwIO . 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 e =
      case fromException @ExitCode e of
        Just _ -> e
        Nothing -> toException $ DisplayExceptionInShow e