content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module RON.Error (
      Error (..),
      MonadE,
      correct,
      errorContext,
      liftEither,
      liftEitherString,
      liftMaybe,
      throwError,
      throwErrorString,
      throwErrorText,
      tryIO,
  ) where
  
  import RON.Prelude
  
  import Control.Exception (SomeException, try)
  import Data.String (IsString, fromString)
  import Data.Text qualified as Text
  import GHC.Stack (callStack, getCallStack, prettySrcLoc)
  import Text.Show qualified
  
  data Error = Error {description :: Text, reasons :: [Error]}
      deriving (Eq)
  
  instance Show Error where
      show = unlines . go
        where
          go Error{description, reasons} =
              Text.unpack description : foldMap (map ("  " ++) . go) reasons
  
  instance Exception Error
  
  instance IsString Error where
      fromString s = Error (fromString s) []
  
  type MonadE = MonadError Error
  
  errorContext :: (MonadE m) => Text -> m a -> m a
  errorContext ctx action = action `catchError` \e -> throwError $ Error ctx [e]
  
  liftMaybe :: (MonadE m) => Text -> Maybe a -> m a
  liftMaybe msg = maybe (throwErrorText msg) pure
  
  liftEitherString :: (IsString e, MonadError e m) => Either String a -> m a
  liftEitherString = either throwErrorString pure
  
  throwErrorText :: (MonadE m) => Text -> m a
  throwErrorText msg = throwError $ Error msg []
  
  throwErrorString :: (IsString e, MonadError e m) => String -> m a
  throwErrorString = throwError . fromString
  
  correct :: (MonadError e m) => a -> m a -> m a
  correct def action =
      action
          `catchError` \_e ->
              -- TODO(2019-08-06, cblp) $logWarnSH e
              pure def
  
  tryIO :: (HasCallStack, MonadE m, MonadIO m) => IO a -> m a
  tryIO action = do
      e <- liftIO $ try action
      case e of
          Right a -> pure a
          Left (exc :: SomeException) -> do
              let description =
                      case getCallStack callStack of
                          [] -> "tryIO"
                          (f, loc) : _ ->
                              Text.pack $ f ++ ", called at " ++ prettySrcLoc loc
              throwError Error{description, reasons = [fromString $ show exc]}
  