----------------------------------------------------------------------------
-- |
-- 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 -> 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
<$ :: forall a b. a -> EmacsRes s t b -> EmacsRes s t a
$c<$ :: forall s t a b. a -> EmacsRes s t b -> EmacsRes s t a
fmap :: forall a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
$cfmap :: forall s t a b. (a -> b) -> EmacsRes s t a -> EmacsRes s t b
Functor, forall a. EmacsRes s t a -> Bool
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 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
product :: forall a. Num a => EmacsRes s t a -> a
$cproduct :: forall s t a. Num a => EmacsRes s t a -> a
sum :: forall a. Num a => EmacsRes s t a -> a
$csum :: forall s t a. Num a => EmacsRes s t a -> a
minimum :: forall a. Ord a => EmacsRes s t a -> a
$cminimum :: forall s t a. Ord a => EmacsRes s t a -> a
maximum :: forall a. Ord a => EmacsRes s t a -> a
$cmaximum :: forall s t a. Ord a => EmacsRes s t a -> a
elem :: forall a. Eq a => a -> EmacsRes s t a -> Bool
$celem :: forall s t a. Eq a => a -> EmacsRes s t a -> Bool
length :: forall a. EmacsRes s t a -> Int
$clength :: forall s t a. EmacsRes s t a -> Int
null :: forall a. EmacsRes s t a -> Bool
$cnull :: forall s t a. EmacsRes s t a -> Bool
toList :: forall a. EmacsRes s t a -> [a]
$ctoList :: forall s t a. EmacsRes s t a -> [a]
foldl1 :: forall a. (a -> a -> a) -> EmacsRes s t a -> a
$cfoldl1 :: forall s t a. (a -> a -> a) -> EmacsRes s t a -> a
foldr1 :: forall a. (a -> a -> a) -> EmacsRes s t a -> a
$cfoldr1 :: forall s t a. (a -> a -> a) -> EmacsRes s t a -> a
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
$cfoldl :: forall s t b a. (b -> a -> 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
$cfoldr :: forall s t a b. (a -> b -> b) -> b -> EmacsRes s t a -> b
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
$cfoldMap :: forall s t m a. Monoid m => (a -> m) -> EmacsRes s t a -> m
fold :: forall m. Monoid m => EmacsRes s t m -> m
$cfold :: forall s t m. Monoid m => EmacsRes s t m -> m
Foldable, 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 (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmacsRes s t a -> f (EmacsRes s t b)
sequence :: forall (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
$csequence :: forall s t (m :: * -> *) a.
Monad m =>
EmacsRes s t (m a) -> m (EmacsRes s t a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
$cmapM :: forall s t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmacsRes s t a -> m (EmacsRes s t b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
$csequenceA :: forall s t (f :: * -> *) a.
Applicative f =>
EmacsRes s t (f a) -> f (EmacsRes s t a)
traverse :: 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)
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 =
  forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull forall a b. (a -> b) -> a -> b
$ \ !NonNullPtr (RawValue 'Regular)
nlsErr ->
    forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull forall a b. (a -> b) -> a -> b
$ \ !NonNullPtr (RawValue 'Regular)
nlsData ->
      forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull 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 =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack =>
EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe

unpackEnumFuncallExitSafe
  :: WithCallStack
  => EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe :: WithCallStack =>
EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe (EnumFuncallExit (CInt !Int32
x)) =
  case forall a. (Eq a, Num a) => a -> Maybe (FuncallExit ())
funcallExitFromNum Int32
x of
    Maybe (FuncallExit ())
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError forall a b. (a -> b) -> a -> b
$
      Doc Void
"Unknown value of enum emacs_funcall_exit:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Int32
x
    Just FuncallExit ()
y  -> 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 :: NonNullPtr (RawValue 'Regular)
nlsErr :: NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsErr, NonNullPtr (RawValue 'Regular)
nlsData :: NonNullPtr (RawValue 'Regular)
nlsData :: NonLocalState -> NonNullPtr (RawValue 'Regular)
nlsData} = do
  EnumFuncallExit
exit <- 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
  forall a b. (Eq a, Num a) => a -> b -> (FuncallExit () -> b) -> b
foldFuncallExitFromNum
    (EnumFuncallExit -> CInt
unEnumFuncallExit EnumFuncallExit
exit)
    (forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError forall a b. (a -> b) -> a -> b
$ Doc Void
"Unknown value of enum emacs_funcall_exit:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty EnumFuncallExit
exit)
    (\FuncallExit ()
x ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FuncallExit ()
x forall a b. (a -> b) -> a -> b
$ \(()
_ :: ()) ->
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr (RawValue 'Regular)
nlsErr) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Storable a => Ptr a -> IO a
peek (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
  forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) Builder (RawValue 'Regular)
dat forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args -> do
    RawValue 'Regular
dat'            <- 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args
    Text
emacsSignalInfo <- 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'
    forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Env.nonLocalExitSignal Env
env RawValue 'Unknown
sym RawValue 'Regular
dat'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure EmacsSignal
      { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym  = 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 :: NonNullPtr CPtrdiff
nlsSize :: NonLocalState -> NonNullPtr CPtrdiff
nlsSize} !RawValue p
x Int# -> MutableByteArray# RealWorld -> IO b
k = do
  CBoolean
res <- forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x forall a. Ptr a
nullPtr NonNullPtr CPtrdiff
nlsSize
  if CBoolean -> Bool
Env.isNonTruthy CBoolean
res
  then do
    forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
    forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => 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# <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CPtrdiff
nlsSize)
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 -> case 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) (forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (do
        !CBoolean
copyPerformed <- forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x (forall a. Addr# -> Ptr a
Ptr (forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mbarr#)) NonNullPtr CPtrdiff
nlsSize
        if CBoolean -> Bool
Env.isTruthy CBoolean
copyPerformed
        then
          forall s t a. a -> EmacsRes s t a
EmacsSuccess 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))
nonLocalExitGet Env
env NonLocalState
nls 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
             forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
             Text
emacsSignalInfo <- 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
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s t a. s -> EmacsRes s t a
EmacsExitSignal forall a b. (a -> b) -> a -> b
$ EmacsSignal
               { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
               , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
               , emacsSignalOrigin :: CallStack
emacsSignalOrigin = HasCallStack => CallStack
callStack
               , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
               }
           FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
             forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to unpack string"
           FuncallExitThrow{} ->
             forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => 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 =
  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 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
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 ->
      case 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 =
  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 forall a b. (a -> b) -> a -> b
$ \Int#
size# MutableByteArray# RealWorld
mbarr# ->
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s3 ->
      -- Should subtract 1 from size to avoid NULL terminator at the end.
      case 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 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))
nonLocalExitGet Env
env NonLocalState
nls forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      Text
emacsSignalInfo <- 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s t a. s -> EmacsRes s t a
EmacsExitSignal forall a b. (a -> b) -> a -> b
$ EmacsSignal
        { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
        , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
        , emacsSignalOrigin :: CallStack
emacsSignalOrigin = HasCallStack => CallStack
callStack
        , Text
emacsSignalInfo :: Text
emacsSignalInfo :: Text
emacsSignalInfo
        }
    FuncallExitThrow{} ->
      forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError forall a b. (a -> b) -> a -> b
$
        Doc Void
"The operation should have never exited via throw:" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> 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))
nonLocalExitGet Env
env NonLocalState
nls forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FuncallExit (RawValue 'Regular, RawValue 'Regular)
FuncallExitReturn            ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      Text
emacsSignalInfo <- 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s t a. s -> EmacsRes s t a
EmacsExitSignal forall a b. (a -> b) -> a -> b
$ EmacsSignal
        { emacsSignalSym :: RawValue 'Unknown
emacsSignalSym    = forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
sym
        , emacsSignalData :: RawValue 'Regular
emacsSignalData   = RawValue 'Regular
dat
        , emacsSignalOrigin :: CallStack
emacsSignalOrigin = 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
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall s t a. t -> EmacsRes s t a
EmacsExitThrow 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 = 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'          <- forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Storable a => a -> Builder a
PtrBuilder.storable forall a b. (a -> b) -> a -> b
$ forall a. (a, a) -> Tuple2 a
Tuple2 (forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue p
sym, forall (p :: Pinning). RawValue p -> RawValue 'Unknown
toUnknown RawValue 'Regular
dat)) forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Unknown)
args ->
    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 (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     <- forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue a)
cache) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Storable a => a -> Builder a
PtrBuilder.storable forall a b. (a -> b) -> a -> b
$ forall a. a -> Tuple1 a
Tuple1 RawValue 'Regular
dat') forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args ->
    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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args
  FuncallExit ()
formatRes     <- WithCallStack => EnumFuncallExit -> IO (FuncallExit ())
unpackEnumFuncallExit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => Env -> m EnumFuncallExit
Env.nonLocalExitCheck Env
env
  case FuncallExit ()
formatRes of
    FuncallExitSignal{} -> do
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to format Emacs signal data"
    FuncallExitThrow{}  -> do
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to format Emacs signal data"
    FuncallExit ()
FuncallExitReturn   ->
      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
  forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull forall a b. (a -> b) -> a -> b
$ \NonNullPtr CPtrdiff
pSize -> do
    CBoolean
res <- forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x forall a. Ptr a
nullPtr NonNullPtr CPtrdiff
pSize
    if CBoolean -> Bool
Env.isNonTruthy CBoolean
res
    then do
      forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
      forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => 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#) <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CPtrdiff
pSize)
      forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1 -> case 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) (forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (do
          !CBoolean
copyPerformed <- forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Env.copyStringContents Env
env RawValue p
x (forall a. Addr# -> Ptr a
Ptr (forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mbarr)) NonNullPtr CPtrdiff
pSize
          if CBoolean -> Bool
Env.isTruthy CBoolean
copyPerformed
          then
            forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s3 ->
              case 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 forall a. Num a => a -> a -> a
-  Int
1) #)
          else do
            forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear Env
env
            forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to unpack string"))