{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.CLI.Compatible.Exception
  ( CIO
  , CustomCliException (..)
  , throwCliError
  , fromEitherCli
  , fromEitherIOCli
  , fromExceptTCli
  )
where

import Cardano.Api

import RIO

import GHC.Stack

-- | Type alias that enforces the presence of a call stack.
type CIO e a = HasCallStack => RIO e a

-- | Custom exception type for CLI commands. Any custom errors created
-- in `cardano-cl` should be wrapped in this exception type.
data CustomCliException where
  CustomCliException
    :: (HasCallStack, Show err, Typeable err, Error err)
    => err -> CustomCliException

deriving instance Show CustomCliException

instance Exception CustomCliException where
  displayException :: CustomCliException -> String
displayException (CustomCliException err
e) =
    [String] -> String
unlines
      [ Doc Any -> String
forall a. Show a => a -> String
show (err -> Doc Any
forall ann. err -> Doc ann
forall e ann. Error e => e -> Doc ann
prettyError err
e)
      , CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
      ]

-- | Wrapper function which allows throwing of types of instance `Error`, attaching call stack
-- from the call site
throwCliError
  :: forall e m a
   . (HasCallStack, Show e, Typeable e, Error e, MonadIO m)
  => e
  -> m a
throwCliError :: forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError = (HasCallStack => e -> m a) -> e -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => e -> m a) -> e -> m a)
-> (HasCallStack => e -> m a) -> e -> m a
forall a b. (a -> b) -> a -> b
$ CustomCliException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CustomCliException -> m a)
-> (e -> CustomCliException) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> CustomCliException
forall err.
(HasCallStack, Show err, Typeable err, Error err) =>
err -> CustomCliException
CustomCliException

fromEitherCli
  :: forall e m a
   . (HasCallStack, MonadIO m, Show e, Typeable e, Error e)
  => Either e a
  -> m a
fromEitherCli :: forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
Either e a -> m a
fromEitherCli = (HasCallStack => Either e a -> m a) -> Either e a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Either e a -> m a) -> Either e a -> m a)
-> (HasCallStack => Either e a -> m a) -> Either e a -> m a
forall a b. (a -> b) -> a -> b
$ \case
  Left e
e -> e -> m a
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError e
e
  Right a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

fromEitherIOCli
  :: forall e m a
   . (HasCallStack, MonadIO m, Show e, Typeable e, Error e)
  => IO (Either e a)
  -> m a
fromEitherIOCli :: forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli IO (Either e 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
$ IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either e a)
action m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> m a
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
Either e a -> m a
fromEitherCli

fromExceptTCli
  :: forall e m a
   . (HasCallStack, MonadIO m, Show e, Typeable e, Error e)
  => ExceptT e IO a
  -> m a
fromExceptTCli :: forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli = (HasCallStack => ExceptT e IO a -> m a) -> ExceptT e IO a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => ExceptT e IO a -> m a) -> ExceptT e IO a -> m a)
-> (HasCallStack => ExceptT e IO a -> m a) -> ExceptT e IO a -> m a
forall a b. (a -> b) -> a -> b
$ IO (Either e a) -> m a
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli (IO (Either e a) -> m a)
-> (ExceptT e IO a -> IO (Either e a)) -> ExceptT e IO a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT