----------------------------------------------------------------------------
-- |
-- Module      :  Emacs.Module.Monad.Common
-- Copyright   :  (c) Sergey Vinokurov 2022
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnboxedTuples     #-}

module Emacs.Module.Monad.Common
  ( EmacsRes(..)
  , NonLocalState(..)
  , withNonLocalState
  , unpackEnumFuncallExit
  , unpackEnumFuncallExitSafe
  , Emacs.Module.Monad.Common.nonLocalExitGet
  , nonLocalExitSignal
  , extractText
  , extractShortByteString
  , checkNonLocalExitSignal
  , checkNonLocalExitFull
  , extractSignalInfo
  , extractTextUnsafe
  ) where

import Control.Exception
import Control.Monad.Primitive
import Data.ByteString.Short (ShortByteString)
import Data.ByteString.Short qualified as SBS
import Data.Text (Text)
import Data.Text.Array qualified as TA
import Data.Text.Internal qualified as T
import Data.Traversable
import Data.Tuple.Homogenous
import Data.Void
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import GHC.Exts
import GHC.IO
import GHC.Stack (CallStack, callStack)
import Prettyprinter

#ifdef ASSERTIONS
import Data.ByteString.Internal qualified as BSI
import Data.Text.Encoding qualified as TE
import Foreign.ForeignPtr qualified as Foreign
#endif

import Data.Emacs.Module.Env.Functions
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env (EnumFuncallExit(..))
import Data.Emacs.Module.Raw.Env qualified as Env
import Data.Emacs.Module.Raw.Env.Internal
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
import Emacs.Module.Errors
import Foreign.Ptr.Builder as PtrBuilder

data EmacsRes s t a
  = EmacsSuccess a
  | EmacsExitSignal s
  | EmacsExitThrow t
  deriving ((forall a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b)
-> (forall a b. a -> EmacsRes s t b -> EmacsRes s t a)
-> Functor (EmacsRes s t)
forall a b. a -> EmacsRes s t b -> EmacsRes s t a
forall a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
forall s t a b. a -> EmacsRes s t b -> EmacsRes s t a
forall s t a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s t a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
fmap :: forall a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
$c<$ :: forall s t a b. a -> EmacsRes s t b -> EmacsRes s t a
<$ :: forall a b. a -> EmacsRes s t b -> EmacsRes s t a
Functor, (forall m. Monoid m => EmacsRes s t m -> m)
-> (forall m a. Monoid m => (a -> m) -> EmacsRes s t a -> m)
-> (forall m a. Monoid m => (a -> m) -> EmacsRes s t a -> m)
-> (forall a b. (a -> b -> b) -> b -> EmacsRes s t a -> b)
-> (forall a b. (a -> b -> b) -> b -> EmacsRes s t a -> b)
-> (forall b a. (b -> a -> b) -> b -> EmacsRes s t a -> b)
-> (forall b a. (b -> a -> b) -> b -> EmacsRes s t a -> b)
-> (forall a. (a -> a -> a) -> EmacsRes s t a -> a)
-> (forall a. (a -> a -> a) -> EmacsRes s t a -> a)
-> (forall a. EmacsRes s t a -> [a])
-> (forall a. EmacsRes s t a -> Bool)
-> (forall a. EmacsRes s t a -> Int)
-> (forall a. Eq a => a -> EmacsRes s t a -> Bool)
-> (forall a. Ord a => EmacsRes s t a -> a)
-> (forall a. Ord a => EmacsRes s t a -> a)
-> (forall a. Num a => EmacsRes s t a -> a)
-> (forall a. Num a => EmacsRes s t a -> a)
-> Foldable (EmacsRes s t)
forall a. Eq a => a -> EmacsRes s t a -> Bool
forall a. Num a => EmacsRes s t a -> a
forall a. Ord a => EmacsRes s t a -> a
forall m. Monoid m => EmacsRes s t m -> m
forall a. EmacsRes s t a -> Bool
forall a. EmacsRes s t a -> Int
forall a. EmacsRes s t a -> [a]
forall a. (a -> a -> a) -> EmacsRes s t a -> a
forall m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
forall b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
forall a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
forall s t a. Eq a => a -> EmacsRes s t a -> Bool
forall s t a. Num a => EmacsRes s t a -> a
forall s t a. Ord a => EmacsRes s t a -> a
forall s t m. Monoid m => EmacsRes s t m -> m
forall s t a. EmacsRes s t a -> Bool
forall s t a. EmacsRes s t a -> Int
forall s t a. EmacsRes s t a -> [a]
forall s t a. (a -> a -> a) -> EmacsRes s t a -> a
forall s t m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
forall s t b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
forall s t a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall s t m. Monoid m => EmacsRes s t m -> m
fold :: forall m. Monoid m => EmacsRes s t m -> m
$cfoldMap :: forall s t m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
$cfoldMap' :: forall s t m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
$cfoldr :: forall s t a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
foldr :: forall a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
$cfoldr' :: forall s t a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
$cfoldl :: forall s t b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
foldl :: forall b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
$cfoldl' :: forall s t b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> EmacsRes s t a -> b
$cfoldr1 :: forall s t a. (a -> a -> a) -> EmacsRes s t a -> a
foldr1 :: forall a. (a -> a -> a) -> EmacsRes s t a -> a
$cfoldl1 :: forall s t a. (a -> a -> a) -> EmacsRes s t a -> a
foldl1 :: forall a. (a -> a -> a) -> EmacsRes s t a -> a
$ctoList :: forall s t a. EmacsRes s t a -> [a]
toList :: forall a. EmacsRes s t a -> [a]
$cnull :: forall s t a. EmacsRes s t a -> Bool
null :: forall a. EmacsRes s t a -> Bool
$clength :: forall s t a. EmacsRes s t a -> Int
length :: forall a. EmacsRes s t a -> Int
$celem :: forall s t a. Eq a => a -> EmacsRes s t a -> Bool
elem :: forall a. Eq a => a -> EmacsRes s t a -> Bool
$cmaximum :: forall s t a. Ord a => EmacsRes s t a -> a
maximum :: forall a. Ord a => EmacsRes s t a -> a
$cminimum :: forall s t a. Ord a => EmacsRes s t a -> a
minimum :: forall a. Ord a => EmacsRes s t a -> a
$csum :: forall s t a. Num a => EmacsRes s t a -> a
sum :: forall a. Num a => EmacsRes s t a -> a
$cproduct :: forall s t a. Num a => EmacsRes s t a -> a
product :: forall a. Num a => EmacsRes s t a -> a
Foldable, Functor (EmacsRes s t)
Foldable (EmacsRes s t)
(Functor (EmacsRes s t), Foldable (EmacsRes s t)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    EmacsRes s t (f a) -> f (EmacsRes s t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b))
-> (forall (m :: * -> *) a.
    Monad m =>
    EmacsRes s t (m a) -> m (EmacsRes s t a))
-> Traversable (EmacsRes s t)
forall s t. Functor (EmacsRes s t)
forall s t. Foldable (EmacsRes s t)
forall s t (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
forall s t (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
forall s t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
forall s t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
forall (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b)
$ctraverse :: forall s t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b)
$csequenceA :: forall s t (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
$cmapM :: forall s t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
$csequence :: forall s t (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
sequence :: forall (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
Traversable)

data NonLocalState = NonLocalState
  { NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsErr  :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))
  , NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsData :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))
  , NonLocalState -> NonNullPtr CPtrdiff
nlsSize :: {-# UNPACK #-} !(NonNullPtr CPtrdiff)
  }

withNonLocalState :: (NonLocalState -> IO a) -> IO a
withNonLocalState :: forall a. (NonLocalState -> IO a) -> IO a
withNonLocalState NonLocalState -> IO a
f =
  (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr (RawValue 'Regular) -> IO a) -> IO a)
-> (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ !NonNullPtr (RawValue 'Regular)
nlsErr ->
    (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr (RawValue 'Regular) -> IO a) -> IO a)
-> (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ !NonNullPtr (RawValue 'Regular)
nlsData ->
      (NonNullPtr CPtrdiff -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr CPtrdiff -> IO a) -> IO a)
-> (NonNullPtr CPtrdiff -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ !NonNullPtr CPtrdiff
nlsSize ->
        NonLocalState -> IO a
f NonLocalState{NonNullPtr (RawValue 'Regular)
nlsErr :: NonNullPtr (RawValue 'Regular)
nlsErr :: NonNullPtr (RawValue 'Regular)
nlsErr, NonNullPtr (RawValue 'Regular)
nlsData :: NonNullPtr (RawValue 'Regular)
nlsData :: NonNullPtr (RawValue 'Regular)
nlsData, NonNullPtr CPtrdiff
nlsSize :: NonNullPtr CPtrdiff
nlsSize :: NonNullPtr CPtrdiff
nlsSize}

unpackEnumFuncallExit
  :: WithCallStack
  => EnumFuncallExit -> IO (FuncallExit ())
unpackEnumFuncallExit :: WithCallStack => EnumFuncallExit -> IO (FuncallExit ())
unpackEnumFuncallExit =
  (EmacsInternalError -> IO (FuncallExit ()))
-> (FuncallExit () -> IO (FuncallExit ()))
-> Either EmacsInternalError (FuncallExit ())
-> IO (FuncallExit ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EmacsInternalError -> IO (FuncallExit ())
forall e a. Exception e => e -> IO a
throwIO FuncallExit () -> IO (FuncallExit ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EmacsInternalError (FuncallExit ()) -> IO (FuncallExit ()))
-> (EnumFuncallExit -> Either EmacsInternalError (FuncallExit ()))
-> EnumFuncallExit
-> IO (FuncallExit ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack =>
EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe

unpackEnumFuncallExitSafe
  :: WithCallStack
  => EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe :: WithCallStack =>
EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe (EnumFuncallExit (CInt !Int32
x)) =
  case Int32 -> Maybe (FuncallExit ())
forall a. (Eq a, Num a) => a -> Maybe (FuncallExit ())
funcallExitFromNum Int32
x of
    Maybe (FuncallExit ())
Nothing -> EmacsInternalError -> Either EmacsInternalError (FuncallExit ())
forall a b. a -> Either a b
Left (EmacsInternalError -> Either EmacsInternalError (FuncallExit ()))
-> EmacsInternalError -> Either EmacsInternalError (FuncallExit ())
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError (Doc Void -> EmacsInternalError) -> Doc Void -> EmacsInternalError
forall a b. (a -> b) -> a -> b
$
      Doc Void
"Unknown value of enum emacs_funcall_exit:" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int32 -> Doc Void
forall ann. Int32 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int32
x
    Just FuncallExit ()
y  -> FuncallExit () -> Either EmacsInternalError (FuncallExit ())
forall a b. b -> Either a b
Right FuncallExit ()
y

{-# INLINE nonLocalExitGet #-}
nonLocalExitGet
  :: WithCallStack
  => Env
  -> NonLocalState
  -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet :: WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet Env
env NonLocalState{NonNullPtr (RawValue 'Regular)
nlsErr :: NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsErr :: NonNullPtr (RawValue 'Regular)
nlsErr, NonNullPtr (RawValue 'Regular)
nlsData :: NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsData :: NonNullPtr (RawValue 'Regular)
nlsData} = do
  EnumFuncallExit
exit <- Env
-> NonNullPtr (RawValue 'Regular)
-> NonNullPtr (RawValue 'Regular)
-> IO EnumFuncallExit
forall (m :: * -> *).
MonadIO m =>
Env
-> NonNullPtr (RawValue 'Regular)
-> NonNullPtr (RawValue 'Regular)
-> m EnumFuncallExit
Env.nonLocalExitGet Env
env NonNullPtr (RawValue 'Regular)
nlsErr NonNullPtr (RawValue 'Regular)
nlsData
  CInt
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
-> (FuncallExit ()
    -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular)))
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
forall a b. (Eq a, Num a) => a -> b -> (FuncallExit () -> b) -> b
foldFuncallExitFromNum
    (EnumFuncallExit -> CInt
unEnumFuncallExit EnumFuncallExit
exit)
    (EmacsInternalError
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError
 -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular)))
-> EmacsInternalError
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError (Doc Void -> EmacsInternalError) -> Doc Void -> EmacsInternalError
forall a b. (a -> b) -> a -> b
$ Doc Void
"Unknown value of enum emacs_funcall_exit:" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> EnumFuncallExit -> Doc Void
forall a ann. Pretty a => a -> Doc ann
forall ann. EnumFuncallExit -> Doc ann
pretty EnumFuncallExit
exit)
    (\FuncallExit ()
x ->
      FuncallExit ()
-> (() -> IO (RawValue 'Regular, RawValue 'Regular))
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FuncallExit ()
x ((() -> IO (RawValue 'Regular, RawValue 'Regular))
 -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular)))
-> (() -> IO (RawValue 'Regular, RawValue 'Regular))
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
forall a b. (a -> b) -> a -> b
$ \(()
_ :: ()) ->
        (,) (RawValue 'Regular
 -> RawValue 'Regular -> (RawValue 'Regular, RawValue 'Regular))
-> IO (RawValue 'Regular)
-> IO (RawValue 'Regular -> (RawValue 'Regular, RawValue 'Regular))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (RawValue 'Regular) -> IO (RawValue 'Regular)
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr (RawValue 'Regular) -> Ptr (RawValue 'Regular)
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr (RawValue 'Regular)
nlsErr) IO (RawValue 'Regular -> (RawValue 'Regular, RawValue 'Regular))
-> IO (RawValue 'Regular)
-> IO (RawValue 'Regular, RawValue 'Regular)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr (RawValue 'Regular) -> IO (RawValue 'Regular)
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr (RawValue 'Regular) -> Ptr (RawValue 'Regular)
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr (RawValue 'Regular)
nlsData))
  -- x <- unpackEnumFuncallExit =<< Env.nonLocalExitGet env nlsErr nlsData
  -- for x $ \(_ :: ()) ->
  --   (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData)

{-# INLINE nonLocalExitSignal #-}
nonLocalExitSignal
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> CallStack
  -> RawValue 'Unknown           -- ^ Error symbol
  -> Builder (RawValue 'Regular) -- ^ Error data
  -> IO EmacsSignal
nonLocalExitSignal :: forall (a :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> CallStack
-> RawValue 'Unknown
-> Builder (RawValue 'Regular)
-> IO EmacsSignal
nonLocalExitSignal BuilderCache (RawValue a)
cache Env
env !CallStack
emacsSignalOrigin !RawValue 'Unknown
sym !Builder (RawValue 'Regular)
dat = do
  RawValue 'Unknown
listSym <- Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
Sym.list
  BuilderCache (RawValue 'Regular)
-> Builder (RawValue 'Regular)
-> (Int -> NonNullPtr (RawValue 'Regular) -> IO EmacsSignal)
-> IO EmacsSignal
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (BuilderCache (RawValue a) -> BuilderCache (RawValue 'Regular)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) Builder (RawValue 'Regular)
dat ((Int -> NonNullPtr (RawValue 'Regular) -> IO EmacsSignal)
 -> IO EmacsSignal)
-> (Int -> NonNullPtr (RawValue 'Regular) -> IO EmacsSignal)
-> IO EmacsSignal
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args -> do
    RawValue 'Regular
dat'            <- Env
-> RawValue 'Unknown
-> 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)
Env.funcallPrimitive Env
env RawValue 'Unknown
listSym (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args
    Text
emacsSignalInfo <- BuilderCache (RawValue a)
-> Env -> RawValue 'Unknown -> RawValue 'Regular -> IO Text
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo BuilderCache (RawValue a)
cache Env
env RawValue 'Unknown
sym RawValue 'Regular
dat'
    Env -> RawValue 'Unknown -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Env.nonLocalExitSignal Env
env RawValue 'Unknown
sym RawValue 'Regular
dat'
    EmacsSignal -> IO EmacsSignal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmacsSignal
      { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym  = RawValue 'Unknown -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Unknown
sym
      , emacsSignalData :: RawValue 'Regular
emacsSignalData = RawValue 'Regular
dat'
      , CallStack
emacsSignalOrigin :: CallStack
emacsSignalOrigin :: CallStack
emacsSignalOrigin
      , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
      }

{-# INLINE extractStringWith #-}
extractStringWith
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> (Int# -> MutableByteArray# RealWorld -> IO b)
  -> IO (EmacsRes EmacsSignal Void b)
extractStringWith :: forall (a :: Pinning) (p :: Pinning) b.
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> (Int# -> MutableByteArray# RealWorld -> IO b)
-> IO (EmacsRes EmacsSignal Void b)
extractStringWith BuilderCache (RawValue a)
cache Env
env !nls :: NonLocalState
nls@NonLocalState{NonNullPtr CPtrdiff
nlsSize :: NonLocalState -> NonNullPtr CPtrdiff
nlsSize :: NonNullPtr CPtrdiff
nlsSize} !RawValue p
x Int# -> MutableByteArray# RealWorld -> IO b
k = do
  CBoolean
res <- Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x CString
forall a. Ptr a
nullPtr NonNullPtr CPtrdiff
nlsSize
  if CBoolean -> Bool
Env.isNonTruthy CBoolean
res
  then do
    Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
    EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO (EmacsRes EmacsSignal Void b))
-> EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError
      Doc Void
"Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."
  else do
    I# Int#
size# <- CPtrdiff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CPtrdiff -> Int) -> IO CPtrdiff -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CPtrdiff -> IO CPtrdiff
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr CPtrdiff -> Ptr CPtrdiff
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CPtrdiff
nlsSize)
    (State# RealWorld
 -> (# State# RealWorld, EmacsRes EmacsSignal Void b #))
-> IO (EmacsRes EmacsSignal Void b)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld
  -> (# State# RealWorld, EmacsRes EmacsSignal Void b #))
 -> IO (EmacsRes EmacsSignal Void b))
-> (State# RealWorld
    -> (# State# RealWorld, EmacsRes EmacsSignal Void b #))
-> IO (EmacsRes EmacsSignal Void b)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 -> case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
size# State# RealWorld
s1 of
      (# State# RealWorld
s2, MutableByteArray# RealWorld
mbarr# #) -> (\State# RealWorld
-> (# State# RealWorld, EmacsRes EmacsSignal Void b #)
kk -> State# RealWorld
-> (# State# RealWorld, EmacsRes EmacsSignal Void b #)
kk State# RealWorld
s2) (IO (EmacsRes EmacsSignal Void b)
-> State# RealWorld
-> (# State# RealWorld, EmacsRes EmacsSignal Void b #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (do
        !CBoolean
copyPerformed <- Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x (Addr# -> CString
forall a. Addr# -> Ptr a
Ptr (MutableByteArray# RealWorld -> Addr#
forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mbarr#)) NonNullPtr CPtrdiff
nlsSize
        if CBoolean -> Bool
Env.isTruthy CBoolean
copyPerformed
        then
          b -> EmacsRes EmacsSignal Void b
forall s t a. a -> EmacsRes s t a
EmacsSuccess (b -> EmacsRes EmacsSignal Void b)
-> IO b -> IO (EmacsRes EmacsSignal Void b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int# -> MutableByteArray# RealWorld -> IO b
k Int#
size# MutableByteArray# RealWorld
mbarr#
        else
         WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet Env
env NonLocalState
nls IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
-> (FuncallExit (RawValue 'Regular, RawValue 'Regular)
    -> IO (EmacsRes EmacsSignal Void b))
-> IO (EmacsRes EmacsSignal Void b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           FuncallExitSignal (RawValue 'Regular
sym, RawValue 'Regular
dat) -> do
             -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
             Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
             Text
emacsSignalInfo <- BuilderCache (RawValue a)
-> Env -> RawValue 'Regular -> RawValue 'Regular -> IO Text
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo BuilderCache (RawValue a)
cache Env
env RawValue 'Regular
sym RawValue 'Regular
dat
             EmacsRes EmacsSignal Void b -> IO (EmacsRes EmacsSignal Void b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal Void b -> IO (EmacsRes EmacsSignal Void b))
-> EmacsRes EmacsSignal Void b -> IO (EmacsRes EmacsSignal Void b)
forall a b. (a -> b) -> a -> b
$ EmacsSignal -> EmacsRes EmacsSignal Void b
forall s t a. s -> EmacsRes s t a
EmacsExitSignal (EmacsSignal -> EmacsRes EmacsSignal Void b)
-> EmacsSignal -> EmacsRes EmacsSignal Void b
forall a b. (a -> b) -> a -> b
$ EmacsSignal
               { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = RawValue 'Regular -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
               , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
               , emacsSignalOrigin :: CallStack
emacsSignalOrigin = CallStack
HasCallStack => CallStack
callStack
               , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
               }
           FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
             EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO (EmacsRes EmacsSignal Void b))
-> EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to unpack string"
           FuncallExitThrow{} ->
             EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO (EmacsRes EmacsSignal Void b))
-> EmacsInternalError -> IO (EmacsRes EmacsSignal Void b)
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError
               Doc Void
"The copy string contents operation should have never exited via throw"))

{-# INLINE extractText #-}
extractText
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> IO (EmacsRes EmacsSignal Void Text)
extractText :: forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void Text)
extractText BuilderCache (RawValue a)
cache Env
env NonLocalState
nls RawValue p
x =
  BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> (Int# -> MutableByteArray# RealWorld -> IO Text)
-> IO (EmacsRes EmacsSignal Void Text)
forall (a :: Pinning) (p :: Pinning) b.
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> (Int# -> MutableByteArray# RealWorld -> IO b)
-> IO (EmacsRes EmacsSignal Void b)
extractStringWith BuilderCache (RawValue a)
cache Env
env NonLocalState
nls RawValue p
x ((Int# -> MutableByteArray# RealWorld -> IO Text)
 -> IO (EmacsRes EmacsSignal Void Text))
-> (Int# -> MutableByteArray# RealWorld -> IO Text)
-> IO (EmacsRes EmacsSignal Void Text)
forall a b. (a -> b) -> a -> b
$ \Int#
size# MutableByteArray# RealWorld
mbarr# ->
#ifdef ASSERTIONS
    do
      -- Should subtract 1 from size to avoid NULL terminator at the end.
      ptr <- Foreign.newForeignPtr_ (Ptr (mutableByteArrayContents# mbarr#))
      evaluate $ TE.decodeUtf8 $ BSI.BS ptr (I# (size# -# 1#))
#else
    (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text)
-> (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 ->
      case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s1 of
        (# State# RealWorld
s2, ByteArray#
barr #) ->
          -- Should subtract 1 from size to avoid NULL terminator at the end.
          (# State# RealWorld
s2, Array -> Int -> Int -> Text
T.Text (ByteArray# -> Array
TA.ByteArray ByteArray#
barr) Int
0 (Int# -> Int
I# (Int#
size# Int# -> Int# -> Int#
-# Int#
1#)) #)
#endif

{-# INLINE extractShortByteString #-}
extractShortByteString
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> IO (EmacsRes EmacsSignal Void ShortByteString)
extractShortByteString :: forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void ShortByteString)
extractShortByteString BuilderCache (RawValue a)
cache Env
env NonLocalState
nls RawValue p
x =
  BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> (Int# -> MutableByteArray# RealWorld -> IO ShortByteString)
-> IO (EmacsRes EmacsSignal Void ShortByteString)
forall (a :: Pinning) (p :: Pinning) b.
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> (Int# -> MutableByteArray# RealWorld -> IO b)
-> IO (EmacsRes EmacsSignal Void b)
extractStringWith BuilderCache (RawValue a)
cache Env
env NonLocalState
nls RawValue p
x ((Int# -> MutableByteArray# RealWorld -> IO ShortByteString)
 -> IO (EmacsRes EmacsSignal Void ShortByteString))
-> (Int# -> MutableByteArray# RealWorld -> IO ShortByteString)
-> IO (EmacsRes EmacsSignal Void ShortByteString)
forall a b. (a -> b) -> a -> b
$ \Int#
size# MutableByteArray# RealWorld
mbarr# ->
    (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ShortByteString #))
 -> IO ShortByteString)
-> (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s3 ->
      -- Should subtract 1 from size to avoid NULL terminator at the end.
      case MutableByteArray# RealWorld
-> Int# -> State# RealWorld -> State# RealWorld
forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkMutableByteArray# MutableByteArray# RealWorld
mbarr# (Int#
size# Int# -> Int# -> Int#
-# Int#
1#) State# RealWorld
s3 of
        State# RealWorld
s4 ->
          case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr# State# RealWorld
s4 of
            (# State# RealWorld
s5, ByteArray#
barr #) ->
              (# State# RealWorld
s5, ByteArray# -> ShortByteString
SBS.SBS ByteArray#
barr #)

{-# INLINE checkNonLocalExitSignal #-}
checkNonLocalExitSignal
  :: WithCallStack
  => BuilderCache (RawValue b)
  -> Env
  -> NonLocalState
  -> Text
  -> a
  -> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal :: forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal BuilderCache (RawValue b)
cache Env
env !NonLocalState
nls !Text
errMsg !a
res = do
  WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet Env
env NonLocalState
nls IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
-> (FuncallExit (RawValue 'Regular, RawValue 'Regular)
    -> IO (EmacsRes EmacsSignal Void a))
-> IO (EmacsRes EmacsSignal Void a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
      EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a))
-> EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a)
forall a b. (a -> b) -> a -> b
$ a -> EmacsRes EmacsSignal Void a
forall s t a. a -> EmacsRes s t a
EmacsSuccess a
res
    FuncallExitSignal (RawValue 'Regular
sym, RawValue 'Regular
dat) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      Text
emacsSignalInfo <- BuilderCache (RawValue b)
-> Env -> RawValue 'Regular -> RawValue 'Regular -> IO Text
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo BuilderCache (RawValue b)
cache Env
env RawValue 'Regular
sym RawValue 'Regular
dat
      EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a))
-> EmacsRes EmacsSignal Void a -> IO (EmacsRes EmacsSignal Void a)
forall a b. (a -> b) -> a -> b
$ EmacsSignal -> EmacsRes EmacsSignal Void a
forall s t a. s -> EmacsRes s t a
EmacsExitSignal (EmacsSignal -> EmacsRes EmacsSignal Void a)
-> EmacsSignal -> EmacsRes EmacsSignal Void a
forall a b. (a -> b) -> a -> b
$ EmacsSignal
        { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = RawValue 'Regular -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
        , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
        , emacsSignalOrigin :: CallStack
emacsSignalOrigin = CallStack
HasCallStack => CallStack
callStack
        , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
        }
    FuncallExitThrow{} ->
      EmacsInternalError -> IO (EmacsRes EmacsSignal Void a)
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO (EmacsRes EmacsSignal Void a))
-> EmacsInternalError -> IO (EmacsRes EmacsSignal Void a)
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError (Doc Void -> EmacsInternalError) -> Doc Void -> EmacsInternalError
forall a b. (a -> b) -> a -> b
$
        Doc Void
"The operation should have never exited via throw:" 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
<> Text -> Doc Void
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
errMsg

{-# INLINE checkNonLocalExitFull #-}
checkNonLocalExitFull
  :: WithCallStack
  => BuilderCache (RawValue b)
  -> Env
  -> NonLocalState
  -> a
  -> IO (EmacsRes EmacsSignal EmacsThrow a)
checkNonLocalExitFull :: forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
checkNonLocalExitFull BuilderCache (RawValue b)
cache Env
env !NonLocalState
nls !a
res =
  WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet Env
env NonLocalState
nls IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
-> (FuncallExit (RawValue 'Regular, RawValue 'Regular)
    -> IO (EmacsRes EmacsSignal EmacsThrow a))
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
      EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal EmacsThrow a
 -> IO (EmacsRes EmacsSignal EmacsThrow a))
-> EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a b. (a -> b) -> a -> b
$ a -> EmacsRes EmacsSignal EmacsThrow a
forall s t a. a -> EmacsRes s t a
EmacsSuccess a
res
    FuncallExitSignal (RawValue 'Regular
sym, RawValue 'Regular
dat) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      Text
emacsSignalInfo <- BuilderCache (RawValue b)
-> Env -> RawValue 'Regular -> RawValue 'Regular -> IO Text
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo BuilderCache (RawValue b)
cache Env
env RawValue 'Regular
sym RawValue 'Regular
dat
      EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal EmacsThrow a
 -> IO (EmacsRes EmacsSignal EmacsThrow a))
-> EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a b. (a -> b) -> a -> b
$ EmacsSignal -> EmacsRes EmacsSignal EmacsThrow a
forall s t a. s -> EmacsRes s t a
EmacsExitSignal (EmacsSignal -> EmacsRes EmacsSignal EmacsThrow a)
-> EmacsSignal -> EmacsRes EmacsSignal EmacsThrow a
forall a b. (a -> b) -> a -> b
$ EmacsSignal
        { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = RawValue 'Regular -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
        , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
        , emacsSignalOrigin :: CallStack
emacsSignalOrigin = CallStack
HasCallStack => CallStack
callStack
        , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
        }
      -- -- Important to clean up so that we can still call Emacs
      -- -- functions to make nil return value, etc
      -- Env.nonLocalExitClear env
    FuncallExitThrow (RawValue 'Regular
tag, RawValue 'Regular
value) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmacsRes EmacsSignal EmacsThrow a
 -> IO (EmacsRes EmacsSignal EmacsThrow a))
-> EmacsRes EmacsSignal EmacsThrow a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
forall a b. (a -> b) -> a -> b
$ EmacsThrow -> EmacsRes EmacsSignal EmacsThrow a
forall s t a. t -> EmacsRes s t a
EmacsExitThrow (EmacsThrow -> EmacsRes EmacsSignal EmacsThrow a)
-> EmacsThrow -> EmacsRes EmacsSignal EmacsThrow a
forall a b. (a -> b) -> a -> b
$ EmacsThrow
        { emacsThrowTag :: RawValue 'Regular
emacsThrowTag    = RawValue 'Regular
tag
        , emacsThrowValue :: RawValue 'Regular
emacsThrowValue  = RawValue 'Regular
value
        , emacsThrowOrigin :: CallStack
emacsThrowOrigin = CallStack
HasCallStack => CallStack
callStack
        }

extractSignalInfo
  :: WithCallStack
  => BuilderCache (RawValue a) -> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo :: forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo BuilderCache (RawValue a)
cache Env
env !RawValue p
sym !RawValue 'Regular
dat = do
  RawValue 'Unknown
cons          <- Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
Sym.cons
  RawValue 'Regular
dat'          <- BuilderCache (RawValue 'Unknown)
-> Builder (RawValue 'Unknown)
-> (Int
    -> NonNullPtr (RawValue 'Unknown) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (BuilderCache (RawValue a) -> BuilderCache (RawValue 'Unknown)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) ((RawValue 'Unknown -> Builder (RawValue 'Unknown))
-> Tuple2 (RawValue 'Unknown) -> Builder (RawValue 'Unknown)
forall m a. Monoid m => (a -> m) -> Tuple2 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RawValue 'Unknown -> Builder (RawValue 'Unknown)
forall a. Storable a => a -> Builder a
PtrBuilder.storable (Tuple2 (RawValue 'Unknown) -> Builder (RawValue 'Unknown))
-> Tuple2 (RawValue 'Unknown) -> Builder (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$ (RawValue 'Unknown, RawValue 'Unknown)
-> Tuple2 (RawValue 'Unknown)
forall a. (a, a) -> Tuple2 a
Tuple2 (RawValue p -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue p
sym, RawValue 'Regular -> RawValue 'Unknown
forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
dat)) ((Int -> NonNullPtr (RawValue 'Unknown) -> IO (RawValue 'Regular))
 -> IO (RawValue 'Regular))
-> (Int
    -> NonNullPtr (RawValue 'Unknown) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Unknown)
args ->
    Env
-> RawValue 'Unknown
-> CPtrdiff
-> NonNullPtr (RawValue 'Unknown)
-> IO (RawValue 'Regular)
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcallPrimitive Env
env RawValue 'Unknown
cons (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Unknown)
args
  RawValue 'Unknown
prin1ToString <- Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
Sym.prin1ToString
  RawValue 'Regular
formatted     <- BuilderCache (RawValue 'Regular)
-> Builder (RawValue 'Regular)
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (BuilderCache (RawValue a) -> BuilderCache (RawValue 'Regular)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) ((RawValue 'Regular -> Builder (RawValue 'Regular))
-> Tuple1 (RawValue 'Regular) -> Builder (RawValue 'Regular)
forall m a. Monoid m => (a -> m) -> Tuple1 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RawValue 'Regular -> Builder (RawValue 'Regular)
forall a. Storable a => a -> Builder a
PtrBuilder.storable (Tuple1 (RawValue 'Regular) -> Builder (RawValue 'Regular))
-> Tuple1 (RawValue 'Regular) -> Builder (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$ RawValue 'Regular -> Tuple1 (RawValue 'Regular)
forall a. a -> Tuple1 a
Tuple1 RawValue 'Regular
dat') ((Int -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
 -> IO (RawValue 'Regular))
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args ->
    Env
-> RawValue 'Unknown
-> 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)
Env.funcallPrimitive Env
env RawValue 'Unknown
prin1ToString (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args
  FuncallExit ()
formatRes     <- WithCallStack => EnumFuncallExit -> IO (FuncallExit ())
EnumFuncallExit -> IO (FuncallExit ())
unpackEnumFuncallExit (EnumFuncallExit -> IO (FuncallExit ()))
-> IO EnumFuncallExit -> IO (FuncallExit ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> IO EnumFuncallExit
forall (m :: * -> *). MonadIO m => Env -> m EnumFuncallExit
Env.nonLocalExitCheck Env
env
  case FuncallExit ()
formatRes of
    FuncallExitSignal{} -> do
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      EmacsInternalError -> IO Text
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO Text) -> EmacsInternalError -> IO Text
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to format Emacs signal data"
    FuncallExitThrow{}  -> do
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      EmacsInternalError -> IO Text
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO Text) -> EmacsInternalError -> IO Text
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to format Emacs signal data"
    FuncallExit ()
FuncallExitReturn   ->
      Env -> RawValue 'Regular -> IO Text
forall (p :: Pinning).
WithCallStack =>
Env -> RawValue p -> IO Text
extractTextUnsafe Env
env RawValue 'Regular
formatted

extractTextUnsafe
  :: WithCallStack
  => Env
  -> RawValue p
  -> IO Text
extractTextUnsafe :: forall (p :: Pinning).
WithCallStack =>
Env -> RawValue p -> IO Text
extractTextUnsafe Env
env !RawValue p
x = do
  (NonNullPtr CPtrdiff -> IO Text) -> IO Text
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr CPtrdiff -> IO Text) -> IO Text)
-> (NonNullPtr CPtrdiff -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \NonNullPtr CPtrdiff
pSize -> do
    CBoolean
res <- Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x CString
forall a. Ptr a
nullPtr NonNullPtr CPtrdiff
pSize
    if CBoolean -> Bool
Env.isNonTruthy CBoolean
res
    then do
      Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      EmacsInternalError -> IO Text
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO Text) -> EmacsInternalError -> IO Text
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError
        Doc Void
"Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."
    else do
      !size :: Int
size@(I# Int#
size#) <- CPtrdiff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CPtrdiff -> Int) -> IO CPtrdiff -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CPtrdiff -> IO CPtrdiff
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr CPtrdiff -> Ptr CPtrdiff
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CPtrdiff
pSize)
      (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text)
-> (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 -> case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
size# State# RealWorld
s1 of
        (# State# RealWorld
s2, MutableByteArray# RealWorld
mbarr #) -> (\State# RealWorld -> (# State# RealWorld, Text #)
k -> State# RealWorld -> (# State# RealWorld, Text #)
k State# RealWorld
s2) (IO Text -> State# RealWorld -> (# State# RealWorld, Text #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (do
          !CBoolean
copyPerformed <- Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x (Addr# -> CString
forall a. Addr# -> Ptr a
Ptr (MutableByteArray# RealWorld -> Addr#
forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mbarr)) NonNullPtr CPtrdiff
pSize
          if CBoolean -> Bool
Env.isTruthy CBoolean
copyPerformed
          then
            (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text)
-> (State# RealWorld -> (# State# RealWorld, Text #)) -> IO Text
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s3 ->
              case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mbarr State# RealWorld
s3 of
                (# State# RealWorld
s4, ByteArray#
barr #) ->
                  -- Should subtract 1 from size to avoid NULL terminator at the end.
                  (# State# RealWorld
s4, Array -> Int -> Int -> Text
T.Text (ByteArray# -> Array
TA.ByteArray ByteArray#
barr) Int
0 (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
-  Int
1) #)
          else do
            Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
            EmacsInternalError -> IO Text
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO Text) -> EmacsInternalError -> IO Text
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to unpack string"))