----------------------------------------------------------------------------
-- |
-- Module      :  Emacs.Module.Errors
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
--
-- This module defines various kinds of exception that this library
----------------------------------------------------------------------------

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}

module Emacs.Module.Errors
  ( EmacsThrow(..)
  , reportEmacsThrowToEmacs
  , EmacsSignal(..)
  , reportEmacsSignalToEmacs
  , EmacsError(..)
  , mkEmacsError
  , reportErrorToEmacs
  , EmacsInternalError(..)
  , mkEmacsInternalError
  , reportInternalErrorToEmacs
  , UserError(..)
  , mkUserError

  , formatSomeException
  , reportAnyErrorToEmacs
  , reportAllErrorsToEmacs
  ) where

import Control.Applicative
import Control.Exception as Exception

import Data.ByteString.Char8 qualified as C8
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Void
import Data.Void.Unsafe
import Foreign
import Foreign.C.String
import GHC.Stack (CallStack, callStack, prettyCallStack)
import Prettyprinter
import Prettyprinter.Combinators hiding (render, ppCallStack)
import Prettyprinter.Render.Text as PP

import Data.Emacs.Module.Env qualified as Raw
import Data.Emacs.Module.GetRawValue
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env.Internal (Env)
import Data.Emacs.Module.Raw.Value
import Data.Emacs.Module.SymbolName.Internal
import Data.Emacs.Module.SymbolName.Predefined qualified as Sym
import Emacs.Module.Assert

-- | A Haskell exception used to signal a @throw@ exit performed by an
-- Emacs function.
--
-- Unlikely to be needed when developing Emacs extensions.
data EmacsThrow = EmacsThrow
  { EmacsThrow -> RawValue 'Regular
emacsThrowTag    :: !(RawValue 'Regular)
  , EmacsThrow -> RawValue 'Regular
emacsThrowValue  :: !(RawValue 'Regular)
  , EmacsThrow -> CallStack
emacsThrowOrigin :: CallStack
  }

instance Show EmacsThrow where
  showsPrec :: Int -> EmacsThrow -> ShowS
showsPrec Int
_ EmacsThrow{CallStack
emacsThrowOrigin :: EmacsThrow -> CallStack
emacsThrowOrigin :: CallStack
emacsThrowOrigin}
    = String -> ShowS
showString String
"EmacsThrow\n"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (CallStack -> String
prettyCallStack CallStack
emacsThrowOrigin)

instance Exception EmacsThrow

reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO (RawValue 'Unknown)
reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO (RawValue 'Unknown)
reportEmacsThrowToEmacs Env
env EmacsThrow
et = do
  RawValue 'Unknown
nil <- (() :: Constraint) => Env -> IO (RawValue 'Unknown)
Env -> IO (RawValue 'Unknown)
mkNil Env
env
  Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' Env
env EmacsThrow
et
  RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Unknown
nil

reportEmacsThrowToEmacs' :: Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' :: Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' Env
env EmacsThrow{RawValue 'Regular
emacsThrowTag :: EmacsThrow -> RawValue 'Regular
emacsThrowTag :: RawValue 'Regular
emacsThrowTag, RawValue 'Regular
emacsThrowValue :: EmacsThrow -> RawValue 'Regular
emacsThrowValue :: RawValue 'Regular
emacsThrowValue} =
  Env -> RawValue 'Regular -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Raw.nonLocalExitThrow Env
env RawValue 'Regular
emacsThrowTag RawValue 'Regular
emacsThrowValue

-- | A Haskell exception used to signal a @signal@ exit performed by an
-- Emacs function.
--
-- Unlikely to be needed when developing Emacs extensions.
data EmacsSignal = EmacsSignal
  { EmacsSignal -> RawValue 'Unknown
emacsSignalSym    :: !(RawValue 'Unknown)
  , EmacsSignal -> RawValue 'Regular
emacsSignalData   :: !(RawValue 'Regular)
  , EmacsSignal -> Text
emacsSignalInfo   :: !Text
  , EmacsSignal -> CallStack
emacsSignalOrigin :: CallStack
  }

instance Show EmacsSignal where
  showsPrec :: Int -> EmacsSignal -> ShowS
showsPrec Int
_ EmacsSignal{Text
emacsSignalInfo :: EmacsSignal -> Text
emacsSignalInfo :: Text
emacsSignalInfo, CallStack
emacsSignalOrigin :: EmacsSignal -> CallStack
emacsSignalOrigin :: CallStack
emacsSignalOrigin}
    = String -> ShowS
showString String
"EmacsSignal "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Text -> String
T.unpack Text
emacsSignalInfo)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (CallStack -> String
prettyCallStack CallStack
emacsSignalOrigin)

instance Exception EmacsSignal

reportEmacsSignalToEmacs :: Env -> EmacsSignal -> IO (RawValue 'Unknown)
reportEmacsSignalToEmacs :: Env -> EmacsSignal -> IO (RawValue 'Unknown)
reportEmacsSignalToEmacs Env
env EmacsSignal
et = do
  RawValue 'Unknown
nil <- (() :: Constraint) => Env -> IO (RawValue 'Unknown)
Env -> IO (RawValue 'Unknown)
mkNil Env
env
  Env -> EmacsSignal -> IO ()
reportEmacsSignalToEmacs' Env
env EmacsSignal
et
  RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Unknown
nil

reportEmacsSignalToEmacs' :: Env -> EmacsSignal -> IO ()
reportEmacsSignalToEmacs' :: Env -> EmacsSignal -> IO ()
reportEmacsSignalToEmacs' Env
env EmacsSignal{RawValue 'Unknown
emacsSignalSym :: EmacsSignal -> RawValue 'Unknown
emacsSignalSym :: RawValue 'Unknown
emacsSignalSym, RawValue 'Regular
emacsSignalData :: EmacsSignal -> RawValue 'Regular
emacsSignalData :: RawValue 'Regular
emacsSignalData} =
  Env -> RawValue 'Unknown -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Raw.nonLocalExitSignal Env
env RawValue 'Unknown
emacsSignalSym RawValue 'Regular
emacsSignalData

-- | Error thrown to emacs by Haskell functions when anything goes awry.
data UserError = UserError
  { UserError -> Doc Void
userErrFunctionName :: Doc Void
  , UserError -> Doc Void
userErrMsg          :: Doc Void
  , UserError -> CallStack
userErrStack        :: CallStack
  } deriving (Int -> UserError -> ShowS
[UserError] -> ShowS
UserError -> String
(Int -> UserError -> ShowS)
-> (UserError -> String)
-> ([UserError] -> ShowS)
-> Show UserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserError -> ShowS
showsPrec :: Int -> UserError -> ShowS
$cshow :: UserError -> String
show :: UserError -> String
$cshowList :: [UserError] -> ShowS
showList :: [UserError] -> ShowS
Show)

instance Exception UserError

instance Pretty UserError where
  pretty :: forall ann. UserError -> Doc ann
pretty (UserError Doc Void
func Doc Void
msg CallStack
stack) =
    Doc ann
"Error in function" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc ann
forall (f :: * -> *) a. Functor f => f Void -> f a
unsafeVacuous Doc Void
func Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Void -> Doc ann
forall (f :: * -> *) a. Functor f => f Void -> f a
unsafeVacuous Doc Void
msg) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Doc ann
"Location:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2  (CallStack -> Doc ann
forall ann. CallStack -> Doc ann
ppCallStack CallStack
stack)

mkUserError
  :: WithCallStack
  => Doc Void -- ^ Function name
  -> Doc Void -- ^ Message body
  -> UserError
mkUserError :: (() :: Constraint) => Doc Void -> Doc Void -> UserError
mkUserError Doc Void
funcName Doc Void
body = UserError
  { userErrFunctionName :: Doc Void
userErrFunctionName = Doc Void
funcName
  , userErrMsg :: Doc Void
userErrMsg          = Doc Void
body
  , userErrStack :: CallStack
userErrStack        = CallStack
HasCallStack => CallStack
callStack
  }

-- | A high-level error thrown when an Emacs function fails.
data EmacsError = EmacsError
  { EmacsError -> Doc Void
emacsErrMsg    :: Doc Void
  , EmacsError -> Doc Void
emacsErrData   :: Doc Void
  , EmacsError -> CallStack
emacsErrStack  :: CallStack
  } deriving (Int -> EmacsError -> ShowS
[EmacsError] -> ShowS
EmacsError -> String
(Int -> EmacsError -> ShowS)
-> (EmacsError -> String)
-> ([EmacsError] -> ShowS)
-> Show EmacsError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmacsError -> ShowS
showsPrec :: Int -> EmacsError -> ShowS
$cshow :: EmacsError -> String
show :: EmacsError -> String
$cshowList :: [EmacsError] -> ShowS
showList :: [EmacsError] -> ShowS
Show)

instance Exception EmacsError

mkEmacsError
  :: WithCallStack
  => Doc Void -- ^ Message
  -> Doc Void -- ^ Error data from Emacs
  -> EmacsError
mkEmacsError :: (() :: Constraint) => Doc Void -> Doc Void -> EmacsError
mkEmacsError Doc Void
msg Doc Void
errData = EmacsError
  { emacsErrMsg :: Doc Void
emacsErrMsg   = Doc Void
msg
  , emacsErrData :: Doc Void
emacsErrData  = Doc Void
errData
  , emacsErrStack :: CallStack
emacsErrStack = CallStack
HasCallStack => CallStack
callStack
  }

instance Pretty EmacsError where
  pretty :: forall ann. EmacsError -> Doc ann
pretty EmacsError{Doc Void
emacsErrMsg :: EmacsError -> Doc Void
emacsErrMsg :: Doc Void
emacsErrMsg, Doc Void
emacsErrData :: EmacsError -> Doc Void
emacsErrData :: Doc Void
emacsErrData, CallStack
emacsErrStack :: EmacsError -> CallStack
emacsErrStack :: CallStack
emacsErrStack} =
    Doc ann
"Error within Haskell<->Emacs bindings:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Void -> Doc ann
forall (f :: * -> *) a. Functor f => f Void -> f a
unsafeVacuous Doc Void
emacsErrMsg) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Doc ann
"Emacs error:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Void -> Doc ann
forall (f :: * -> *) a. Functor f => f Void -> f a
unsafeVacuous Doc Void
emacsErrData) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Doc ann
"Location:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (CallStack -> Doc ann
forall ann. CallStack -> Doc ann
ppCallStack CallStack
emacsErrStack)

reportErrorToEmacs :: Env -> EmacsError -> IO (RawValue 'Unknown)
reportErrorToEmacs :: Env -> EmacsError -> IO (RawValue 'Unknown)
reportErrorToEmacs Env
env EmacsError
e = do
  RawValue 'Unknown
nil <- (() :: Constraint) => Env -> IO (RawValue 'Unknown)
Env -> IO (RawValue 'Unknown)
mkNil Env
env
  (EmacsError -> Text) -> Env -> EmacsError -> IO ()
forall e. (e -> Text) -> Env -> e -> IO ()
report EmacsError -> Text
forall a. Pretty a => a -> Text
render Env
env EmacsError
e
  RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Unknown
nil

-- | A low-level error thrown when assumptions of this package are
-- violated and it's not safe to proceed further.
--
-- E.g. Emacs returned value not specified in a C enum - cannot
-- really process it in a meaningful way.
data EmacsInternalError = EmacsInternalError
  { EmacsInternalError -> Doc Void
emacsInternalErrMsg   :: Doc Void
  , EmacsInternalError -> CallStack
emacsInternalErrStack :: CallStack
  }

instance Exception EmacsInternalError

instance Show EmacsInternalError where
  showsPrec :: Int -> EmacsInternalError -> ShowS
showsPrec Int
_ (EmacsInternalError Doc Void
msg CallStack
stack)
    = String -> ShowS
showString (Doc Void -> String
forall ann. Doc ann -> String
renderString (Doc Void
"EmacsInternalError" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
## Doc Void
msg Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
<> Doc Void
forall ann. Doc ann
line Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
<> CallStack -> Doc Void
forall ann. CallStack -> Doc ann
ppCallStack CallStack
stack))

mkEmacsInternalError
  :: WithCallStack
  => Doc Void -- ^ Error message
  -> EmacsInternalError
mkEmacsInternalError :: (() :: Constraint) => Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
msg = EmacsInternalError
  { emacsInternalErrMsg :: Doc Void
emacsInternalErrMsg   = Doc Void
msg
  , emacsInternalErrStack :: CallStack
emacsInternalErrStack = CallStack
HasCallStack => CallStack
callStack
  }

reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO (RawValue 'Unknown)
reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO (RawValue 'Unknown)
reportInternalErrorToEmacs Env
env EmacsInternalError
e = do
  RawValue 'Unknown
nil <- (() :: Constraint) => Env -> IO (RawValue 'Unknown)
Env -> IO (RawValue 'Unknown)
mkNil Env
env
  (EmacsInternalError -> Text) -> Env -> EmacsInternalError -> IO ()
forall e. (e -> Text) -> Env -> e -> IO ()
report EmacsInternalError -> Text
forall a. Pretty a => a -> Text
render Env
env EmacsInternalError
e
  RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Unknown
nil

instance Pretty EmacsInternalError where
  pretty :: forall ann. EmacsInternalError -> Doc ann
pretty EmacsInternalError{Doc Void
emacsInternalErrMsg :: EmacsInternalError -> Doc Void
emacsInternalErrMsg :: Doc Void
emacsInternalErrMsg, CallStack
emacsInternalErrStack :: EmacsInternalError -> CallStack
emacsInternalErrStack :: CallStack
emacsInternalErrStack} =
    Doc ann
"Internal error within Haskell<->Emacs bindings:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Void -> Doc ann
forall (f :: * -> *) a. Functor f => f Void -> f a
unsafeVacuous Doc Void
emacsInternalErrMsg) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Doc ann
"Location:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (CallStack -> Doc ann
forall ann. CallStack -> Doc ann
ppCallStack CallStack
emacsInternalErrStack)

formatSomeException :: SomeException -> Text
formatSomeException :: SomeException -> Text
formatSomeException SomeException
e =
  case forall a ann. Pretty a => a -> Doc ann
pretty @EmacsError         (EmacsError -> Doc Void) -> Maybe EmacsError -> Maybe (Doc Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe EmacsError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e Maybe (Doc Void) -> Maybe (Doc Void) -> Maybe (Doc Void)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       forall a ann. Pretty a => a -> Doc ann
pretty @EmacsInternalError (EmacsInternalError -> Doc Void)
-> Maybe EmacsInternalError -> Maybe (Doc Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe EmacsInternalError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just Doc Void
formatted -> Doc Void -> Text
render' Doc Void
formatted
    Maybe (Doc Void)
Nothing        ->
      SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (SimpleDocStream Any -> Text) -> SimpleDocStream Any -> Text
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$
        Doc Any
"Error within Haskell<->Emacs bindings:" Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
forall ann. Doc ann
line Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<>
        Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (String -> Doc Any
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))

reportAnyErrorToEmacs :: Env -> SomeException -> IO (RawValue 'Unknown)
reportAnyErrorToEmacs :: Env -> SomeException -> IO (RawValue 'Unknown)
reportAnyErrorToEmacs Env
env !SomeException
e = do
  !RawValue 'Unknown
nil <- (() :: Constraint) => Env -> IO (RawValue 'Unknown)
Env -> IO (RawValue 'Unknown)
mkNil Env
env
  (SomeException -> Text) -> Env -> SomeException -> IO ()
forall e. (e -> Text) -> Env -> e -> IO ()
report SomeException -> Text
formatSomeException Env
env SomeException
e
  RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Unknown
nil

-- | Catch all errors this package might throw in an IO action
-- and make Emacs aware of them.
--
-- This is a convenience function intended to be used around exported
-- @initialise@ entry point into an Emacs module.
reportAllErrorsToEmacs
  :: Env
  -> IO a -- ^ Result to return on error.
  -> IO a
  -> IO a
reportAllErrorsToEmacs :: forall a. Env -> IO a -> IO a -> IO a
reportAllErrorsToEmacs Env
env IO a
resultOnErr IO a
x
  = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (\SomeException
e -> (SomeException -> Text) -> Env -> SomeException -> IO ()
forall e. (e -> Text) -> Env -> e -> IO ()
report SomeException -> Text
formatSomeException Env
env SomeException
e IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
resultOnErr)
  (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (EmacsThrow -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (\EmacsThrow
et -> Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' Env
env EmacsThrow
et IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
resultOnErr)
  (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (EmacsSignal -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (\EmacsSignal
et -> Env -> EmacsSignal -> IO ()
reportEmacsSignalToEmacs' Env
env EmacsSignal
et IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
resultOnErr) IO a
x

report :: (e -> Text) -> Env -> e -> IO ()
report :: forall e. (e -> Text) -> Env -> e -> IO ()
report e -> Text
format Env
env e
err = do
  RawValue 'Regular
errSym  <- Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw Env
env SymbolName
Sym.error
  RawValue 'Regular
listSym <- Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw Env
env SymbolName
Sym.list
  Text -> (CString -> Int -> IO ()) -> IO ()
forall a. Text -> (CString -> Int -> IO a) -> IO a
withTextAsCString0AndLen (e -> Text
format e
err) ((CString -> Int -> IO ()) -> IO ())
-> (CString -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
str Int
len -> do
    RawValue 'Regular
str' <- Env -> CString -> CPtrdiff -> IO (RawValue 'Regular)
forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m (RawValue 'Regular)
Raw.makeString Env
env CString
str (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    (Ptr (RawValue 'Regular) -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (RawValue 'Regular) -> IO ()) -> IO ())
-> (Ptr (RawValue 'Regular) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (RawValue 'Regular)
argsPtr -> do
      Ptr (RawValue 'Regular) -> RawValue 'Regular -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (RawValue 'Regular)
argsPtr RawValue 'Regular
str'
      RawValue 'Regular
errData <- Env
-> RawValue 'Regular
-> CPtrdiff
-> NonNullPtr (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Raw.funcallPrimitive Env
env (RawValue 'Regular -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue RawValue 'Regular
listSym) CPtrdiff
1 (Ptr (RawValue 'Regular) -> NonNullPtr (RawValue 'Regular)
forall a. (() :: Constraint) => Ptr a -> NonNullPtr a
mkNonNullPtr Ptr (RawValue 'Regular)
argsPtr)
      -- The 'nonLocalExitSignal' function does not overwrite pending
      -- signals, so it's ok to use it here without checking whether an
      -- error is already going on.
      Env -> RawValue 'Regular -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Raw.nonLocalExitSignal Env
env RawValue 'Regular
errSym RawValue 'Regular
errData

withTextAsCString0AndLen :: Text -> (CString -> Int -> IO a) -> IO a
withTextAsCString0AndLen :: forall a. Text -> (CString -> Int -> IO a) -> IO a
withTextAsCString0AndLen Text
str CString -> Int -> IO a
f =
  ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
C8.useAsCString ByteString
utf8 (\CString
ptr -> CString -> Int -> IO a
f CString
ptr (ByteString -> Int
C8.length ByteString
utf8))
  where
    utf8 :: ByteString
utf8 = Text -> ByteString
TE.encodeUtf8 Text
str

mkNil :: WithCallStack => Env -> IO (RawValue 'Unknown)
mkNil :: (() :: Constraint) => Env -> IO (RawValue 'Unknown)
mkNil Env
env = Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
Sym.nil

render :: Pretty a => a -> Text
render :: forall a. Pretty a => a -> Text
render = Doc Void -> Text
render' (Doc Void -> Text) -> (a -> Doc Void) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Void
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

render' :: Doc Void -> Text
render' :: Doc Void -> Text
render' = SimpleDocStream Void -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (SimpleDocStream Void -> Text)
-> (Doc Void -> SimpleDocStream Void) -> Doc Void -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Void -> SimpleDocStream Void
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

ppCallStack :: CallStack -> Doc ann
ppCallStack :: forall ann. CallStack -> Doc ann
ppCallStack = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (CallStack -> String) -> CallStack -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> String
prettyCallStack