----------------------------------------------------------------------------
-- |
-- 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 DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TypeApplications    #-}

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

  , formatSomeException
  , reportAnyErrorToEmacs
  , reportAllErrorsToEmacs
  ) where

import Control.Applicative
import Control.Exception as Exception
import Control.Exception.Safe.Checked (Throws)
import Control.Exception.Safe.Checked qualified as Checked

import Data.ByteString.Char8 qualified as C8
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding qualified as TE
import Data.Void
import Data.Void.Unsafe
import Foreign.C.String
import Foreign.Marshal.Array
import GHC.Stack (CallStack, callStack, prettyCallStack)
import Prettyprinter
import Prettyprinter.Render.Text as PP

import Data.Emacs.Module.Env qualified as Raw
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env.Internal (Env)
import Data.Emacs.Module.Raw.Value
import Data.Emacs.Module.SymbolName (useSymbolNameAsCString)
import Data.Emacs.Module.SymbolName.TH
import Emacs.Module.Assert
-- import qualified Data.Emacs.Module.Value.Internal as Emacs

-- | 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
emacsThrowTag    :: !RawValue
  , EmacsThrow -> RawValue
emacsThrowValue  :: !RawValue
  }

instance Show EmacsThrow where
  showsPrec :: Int -> EmacsThrow -> ShowS
showsPrec Int
_ EmacsThrow
_ = String -> ShowS
showString String
"EmacsThrow"

instance Exception EmacsThrow

reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO RawValue
reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO RawValue
reportEmacsThrowToEmacs Env
env EmacsThrow
et = do
  Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' Env
env EmacsThrow
et
  Env -> IO RawValue
returnNil Env
env

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

-- | 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
showList :: [UserError] -> ShowS
$cshowList :: [UserError] -> ShowS
show :: UserError -> String
$cshow :: UserError -> String
showsPrec :: Int -> UserError -> ShowS
$cshowsPrec :: Int -> UserError -> ShowS
Show)

instance Exception UserError

instance Pretty UserError where
  pretty :: 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 :: Doc Void -> Doc Void -> UserError
mkUserError Doc Void
funcName Doc Void
body = UserError :: Doc Void -> Doc Void -> CallStack -> UserError
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
showList :: [EmacsError] -> ShowS
$cshowList :: [EmacsError] -> ShowS
show :: EmacsError -> String
$cshow :: EmacsError -> String
showsPrec :: Int -> EmacsError -> ShowS
$cshowsPrec :: Int -> EmacsError -> ShowS
Show)

instance Exception EmacsError

mkEmacsError
  :: WithCallStack
  => Doc Void -- ^ Message
  -> Doc Void -- ^ Error data from Emacs
  -> EmacsError
mkEmacsError :: Doc Void -> Doc Void -> EmacsError
mkEmacsError Doc Void
msg Doc Void
errData = EmacsError :: Doc Void -> Doc Void -> CallStack -> EmacsError
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 :: EmacsError -> Doc ann
pretty EmacsError{Doc Void
emacsErrMsg :: Doc Void
emacsErrMsg :: EmacsError -> Doc Void
emacsErrMsg, Doc Void
emacsErrData :: Doc Void
emacsErrData :: EmacsError -> Doc Void
emacsErrData, CallStack
emacsErrStack :: CallStack
emacsErrStack :: EmacsError -> 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
reportErrorToEmacs :: Env -> EmacsError -> IO RawValue
reportErrorToEmacs Env
env EmacsError
e = do
  (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
  Env -> IO RawValue
returnNil Env
env

-- | A low-level error thrown when assumptions of this package are
-- violated and it's not safe to proceed further.
data EmacsInternalError = EmacsInternalError
  { EmacsInternalError -> Doc Void
emacsInternalErrMsg   :: Doc Void
  , EmacsInternalError -> CallStack
emacsInternalErrStack :: CallStack
  } deriving (Int -> EmacsInternalError -> ShowS
[EmacsInternalError] -> ShowS
EmacsInternalError -> String
(Int -> EmacsInternalError -> ShowS)
-> (EmacsInternalError -> String)
-> ([EmacsInternalError] -> ShowS)
-> Show EmacsInternalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmacsInternalError] -> ShowS
$cshowList :: [EmacsInternalError] -> ShowS
show :: EmacsInternalError -> String
$cshow :: EmacsInternalError -> String
showsPrec :: Int -> EmacsInternalError -> ShowS
$cshowsPrec :: Int -> EmacsInternalError -> ShowS
Show)

instance Exception EmacsInternalError

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

reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO RawValue
reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO RawValue
reportInternalErrorToEmacs Env
env EmacsInternalError
e = do
  (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
  Env -> IO RawValue
returnNil Env
env

instance Pretty EmacsInternalError where
  pretty :: EmacsInternalError -> Doc ann
pretty EmacsInternalError{Doc Void
emacsInternalErrMsg :: Doc Void
emacsInternalErrMsg :: EmacsInternalError -> Doc Void
emacsInternalErrMsg, CallStack
emacsInternalErrStack :: CallStack
emacsInternalErrStack :: EmacsInternalError -> 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 ann. Pretty EmacsError => EmacsError -> Doc ann
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       forall ann.
Pretty EmacsInternalError =>
EmacsInternalError -> Doc ann
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 Maybe (Doc Void) -> Maybe (Doc Void) -> Maybe (Doc Void)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       forall ann. Pretty UserError => UserError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty @UserError          (UserError -> Doc Void) -> Maybe UserError -> Maybe (Doc Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe UserError
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 a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))

reportAnyErrorToEmacs :: Env -> SomeException -> IO RawValue
reportAnyErrorToEmacs :: Env -> SomeException -> IO RawValue
reportAnyErrorToEmacs Env
env SomeException
e = do
  (SomeException -> Text) -> Env -> SomeException -> IO ()
forall e. (e -> Text) -> Env -> e -> IO ()
report SomeException -> Text
formatSomeException Env
env SomeException
e
  Env -> IO RawValue
returnNil Env
env

-- | 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.
  -> ((Throws EmacsInternalError, Throws EmacsError, Throws UserError, Throws EmacsThrow) => IO a)
  -> IO a
reportAllErrorsToEmacs :: Env
-> IO a
-> ((Throws EmacsInternalError, Throws EmacsError,
     Throws UserError, Throws EmacsThrow) =>
    IO a)
-> IO a
reportAllErrorsToEmacs Env
env IO a
resultOnErr (Throws EmacsInternalError, Throws EmacsError, Throws UserError,
 Throws EmacsThrow) =>
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 (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) -> (Throws EmacsThrow => IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> (Throws e => m a) -> m a
Checked.handle (\EmacsThrow
et -> Env -> EmacsThrow -> IO ()
reportEmacsThrowToEmacs' Env
env EmacsThrow
et IO () -> IO a -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
resultOnErr) ((Throws EmacsThrow => IO a) -> IO a)
-> (Throws EmacsThrow => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  Proxy EmacsInternalError
-> (Throws EmacsInternalError => IO a) -> IO a
forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
Checked.uncheck (Proxy EmacsInternalError
forall k (t :: k). Proxy t
Proxy @EmacsInternalError) ((Throws EmacsInternalError => IO a) -> IO a)
-> (Throws EmacsInternalError => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  Proxy EmacsError -> (Throws EmacsError => IO a) -> IO a
forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
Checked.uncheck (Proxy EmacsError
forall k (t :: k). Proxy t
Proxy @EmacsError) ((Throws EmacsError => IO a) -> IO a)
-> (Throws EmacsError => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  Proxy UserError -> (Throws UserError => IO a) -> IO a
forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
Checked.uncheck (Proxy UserError
forall k (t :: k). Proxy t
Proxy @UserError) (Throws EmacsInternalError, Throws EmacsError, Throws UserError,
 Throws EmacsThrow) =>
IO a
Throws UserError => IO a
x

report :: (e -> Text) -> Env -> e -> IO ()
report :: (e -> Text) -> Env -> e -> IO ()
report e -> Text
format Env
env e
err = do
  RawValue
errSym  <- SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString [esym|error|] (Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env)
  RawValue
listSym <- SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString [esym|list|]  (Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env)
  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
str' <- Env -> CString -> CPtrdiff -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m RawValue
Raw.makeString Env
env CString
str (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    [RawValue] -> (Int -> Ptr RawValue -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [RawValue
str'] ((Int -> Ptr RawValue -> IO ()) -> IO ())
-> (Int -> Ptr RawValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
nargs Ptr RawValue
argsPtr -> do
      RawValue
errData <- Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> m RawValue
Raw.funcallPrimitive Env
env RawValue
listSym (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nargs) (Ptr RawValue -> NonNullPtr RawValue
forall a. WithCallStack => Ptr a -> NonNullPtr a
mkNonNullPtr Ptr RawValue
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 -> RawValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> RawValue -> m ()
Raw.nonLocalExitSignal Env
env RawValue
errSym RawValue
errData

withTextAsCString0AndLen :: Text -> (CString -> Int -> IO a) -> IO a
withTextAsCString0AndLen :: 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

returnNil :: Env -> IO RawValue
returnNil :: Env -> IO RawValue
returnNil Env
env =
  SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString [esym|nil|] (Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env)


render :: Pretty a => a -> Text
render :: 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 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 :: CallStack -> Doc ann
ppCallStack = 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