----------------------------------------------------------------------------
-- |
-- Module      :  Emacs.Module.Monad
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
--
-- This module defines the implementation of the 'MonadEmacs'.
----------------------------------------------------------------------------

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost        #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Emacs.Module.Monad
  ( EmacsM
  , runEmacsM
  ) where

import Control.Exception qualified as Exception
import Control.Monad.Catch qualified as Catch
import Control.Exception.Safe.Checked (Throws)
import Control.Exception.Safe.Checked qualified as Checked
import Control.Monad.Base
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource as Resource

import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as C8
import Data.Coerce
import Data.Proxy
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.Traversable
import Data.Void
import Foreign (Storable(..))
import Foreign.C.Types
import Foreign.Marshal.Array
import Foreign.Ptr (Ptr, nullPtr)
import Prettyprinter

import Data.Emacs.Module.Args
import Data.Emacs.Module.Env.Functions
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env qualified as Raw
import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType, exportToEmacs)
import Data.Emacs.Module.Raw.Value (RawValue, GlobalRef(..))
import Data.Emacs.Module.SymbolName (SymbolName, useSymbolNameAsCString)
import Data.Emacs.Module.SymbolName.TH
import Data.Emacs.Module.Value.Internal
import Emacs.Module.Assert
import Emacs.Module.Errors
import Emacs.Module.Monad.Class

data Environment = Environment
  { Environment -> Env
eEnv           :: !Env
  , Environment -> NonNullPtr RawValue
eErrorSym      :: !(NonNullPtr RawValue)
  , Environment -> NonNullPtr RawValue
eErrorData     :: !(NonNullPtr RawValue)
  , Environment -> InternalState
eResourceState :: !Resource.InternalState
  }

-- | Concrete monad for interacting with Emacs. It provides:
--
-- 1. Ability to call Emacs C functions and automatically rethrows any
--    errors (non-local exits) from elisp as Haskell exceptions.
-- 2. Tracks ownership of any produced Emacs values and communicates
--    that to Emacs, so that GC on Emacs side will not make any
--    values in Haskell invalid (funnily enough, this can happen!).
--
-- Parameter 's' serves to make ownership-tracking capabilities possible.
-- It's use is the same as in 'Control.Monad.ST' monad. That is, it creates
-- local threads so that no produced Emacs values can leave past 'runEmacsM'.
newtype EmacsM s a = EmacsM { EmacsM s a -> ReaderT Environment IO a
unEmacsM :: ReaderT Environment IO a }
  deriving
    ( a -> EmacsM s b -> EmacsM s a
(a -> b) -> EmacsM s a -> EmacsM s b
(forall a b. (a -> b) -> EmacsM s a -> EmacsM s b)
-> (forall a b. a -> EmacsM s b -> EmacsM s a)
-> Functor (EmacsM s)
forall a b. a -> EmacsM s b -> EmacsM s a
forall a b. (a -> b) -> EmacsM s a -> EmacsM s b
forall s a b. a -> EmacsM s b -> EmacsM s a
forall s a b. (a -> b) -> EmacsM s a -> EmacsM s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EmacsM s b -> EmacsM s a
$c<$ :: forall s a b. a -> EmacsM s b -> EmacsM s a
fmap :: (a -> b) -> EmacsM s a -> EmacsM s b
$cfmap :: forall s a b. (a -> b) -> EmacsM s a -> EmacsM s b
Functor
    , Functor (EmacsM s)
a -> EmacsM s a
Functor (EmacsM s)
-> (forall a. a -> EmacsM s a)
-> (forall a b. EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b)
-> (forall a b c.
    (a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c)
-> (forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b)
-> (forall a b. EmacsM s a -> EmacsM s b -> EmacsM s a)
-> Applicative (EmacsM s)
EmacsM s a -> EmacsM s b -> EmacsM s b
EmacsM s a -> EmacsM s b -> EmacsM s a
EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
forall s. Functor (EmacsM s)
forall a. a -> EmacsM s a
forall s a. a -> EmacsM s a
forall a b. EmacsM s a -> EmacsM s b -> EmacsM s a
forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall a b. EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s a
forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall s a b. EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
forall a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
forall s a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EmacsM s a -> EmacsM s b -> EmacsM s a
$c<* :: forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s a
*> :: EmacsM s a -> EmacsM s b -> EmacsM s b
$c*> :: forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s b
liftA2 :: (a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
$cliftA2 :: forall s a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
<*> :: EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
$c<*> :: forall s a b. EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
pure :: a -> EmacsM s a
$cpure :: forall s a. a -> EmacsM s a
$cp1Applicative :: forall s. Functor (EmacsM s)
Applicative
    , Applicative (EmacsM s)
a -> EmacsM s a
Applicative (EmacsM s)
-> (forall a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b)
-> (forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b)
-> (forall a. a -> EmacsM s a)
-> Monad (EmacsM s)
EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
EmacsM s a -> EmacsM s b -> EmacsM s b
forall s. Applicative (EmacsM s)
forall a. a -> EmacsM s a
forall s a. a -> EmacsM s a
forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall s a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EmacsM s a
$creturn :: forall s a. a -> EmacsM s a
>> :: EmacsM s a -> EmacsM s b -> EmacsM s b
$c>> :: forall s a b. EmacsM s a -> EmacsM s b -> EmacsM s b
>>= :: EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
$c>>= :: forall s a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
$cp1Monad :: forall s. Applicative (EmacsM s)
Monad
    , Monad (EmacsM s)
Monad (EmacsM s)
-> (forall a. IO a -> EmacsM s a) -> MonadIO (EmacsM s)
IO a -> EmacsM s a
forall s. Monad (EmacsM s)
forall a. IO a -> EmacsM s a
forall s a. IO a -> EmacsM s a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> EmacsM s a
$cliftIO :: forall s a. IO a -> EmacsM s a
$cp1MonadIO :: forall s. Monad (EmacsM s)
MonadIO
    , Monad (EmacsM s)
e -> EmacsM s a
Monad (EmacsM s)
-> (forall e a. Exception e => e -> EmacsM s a)
-> MonadThrow (EmacsM s)
forall s. Monad (EmacsM s)
forall e a. Exception e => e -> EmacsM s a
forall s e a. Exception e => e -> EmacsM s a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> EmacsM s a
$cthrowM :: forall s e a. Exception e => e -> EmacsM s a
$cp1MonadThrow :: forall s. Monad (EmacsM s)
Catch.MonadThrow
    , MonadThrow (EmacsM s)
MonadThrow (EmacsM s)
-> (forall e a.
    Exception e =>
    EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a)
-> MonadCatch (EmacsM s)
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
forall s. MonadThrow (EmacsM s)
forall e a.
Exception e =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
forall s e a.
Exception e =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
$ccatch :: forall s e a.
Exception e =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
$cp1MonadCatch :: forall s. MonadThrow (EmacsM s)
Catch.MonadCatch
    , MonadCatch (EmacsM s)
MonadCatch (EmacsM s)
-> (forall b.
    ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b)
-> (forall b.
    ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b)
-> (forall a b c.
    EmacsM s a
    -> (a -> ExitCase b -> EmacsM s c)
    -> (a -> EmacsM s b)
    -> EmacsM s (b, c))
-> MonadMask (EmacsM s)
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
forall s. MonadCatch (EmacsM s)
forall b.
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
forall s b.
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
forall a b c.
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
forall s a b c.
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
$cgeneralBracket :: forall s a b c.
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
uninterruptibleMask :: ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cuninterruptibleMask :: forall s b.
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
mask :: ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cmask :: forall s b.
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cp1MonadMask :: forall s. MonadCatch (EmacsM s)
Catch.MonadMask
    , MonadBase IO
    , Monad (EmacsM s)
Monad (EmacsM s)
-> (forall a. (a -> EmacsM s a) -> EmacsM s a)
-> MonadFix (EmacsM s)
(a -> EmacsM s a) -> EmacsM s a
forall s. Monad (EmacsM s)
forall a. (a -> EmacsM s a) -> EmacsM s a
forall s a. (a -> EmacsM s a) -> EmacsM s a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> EmacsM s a) -> EmacsM s a
$cmfix :: forall s a. (a -> EmacsM s a) -> EmacsM s a
$cp1MonadFix :: forall s. Monad (EmacsM s)
MonadFix
    )

instance MonadResource (EmacsM s) where
  liftResourceT :: ResourceT IO a -> EmacsM s a
liftResourceT ResourceT IO a
action = ReaderT Environment IO a -> EmacsM s a
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO a -> EmacsM s a)
-> ReaderT Environment IO a -> EmacsM s a
forall a b. (a -> b) -> a -> b
$ do
    InternalState
resState <- (Environment -> InternalState)
-> ReaderT Environment IO InternalState
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Environment -> InternalState
eResourceState
    IO a -> ReaderT Environment IO a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> ReaderT Environment IO a)
-> IO a -> ReaderT Environment IO a
forall a b. (a -> b) -> a -> b
$ ResourceT IO a -> InternalState -> IO a
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState ResourceT IO a
action InternalState
resState

instance MonadBaseControl IO (EmacsM s) where
  type StM (EmacsM s) a = StM (ReaderT Environment IO) a
  {-# INLINE liftBaseWith #-}
  liftBaseWith :: (RunInBase (EmacsM s) IO -> IO a) -> EmacsM s a
liftBaseWith RunInBase (EmacsM s) IO -> IO a
f = ReaderT Environment IO a -> EmacsM s a
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM ((RunInBase (ReaderT Environment IO) IO -> IO a)
-> ReaderT Environment IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase (ReaderT Environment IO) IO
runInBase -> RunInBase (EmacsM s) IO -> IO a
f (ReaderT Environment IO a -> IO a
RunInBase (ReaderT Environment IO) IO
runInBase (ReaderT Environment IO a -> IO a)
-> (EmacsM s a -> ReaderT Environment IO a) -> EmacsM s a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsM s a -> ReaderT Environment IO a
forall s a. EmacsM s a -> ReaderT Environment IO a
unEmacsM)))
  {-# INLINE restoreM #-}
  restoreM :: StM (EmacsM s) a -> EmacsM s a
restoreM StM (EmacsM s) a
x = ReaderT Environment IO a -> EmacsM s a
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM (StM (ReaderT Environment IO) a -> ReaderT Environment IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM (ReaderT Environment IO) a
StM (EmacsM s) a
x)

-- | Execute emacs interaction session using an environment supplied by Emacs.
runEmacsM
  :: Env
  -> (forall s. EmacsM s a)
  -> IO a
runEmacsM :: Env -> (forall s. EmacsM s a) -> IO a
runEmacsM Env
env (EmacsM action) =
  (NonNullPtr RawValue -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr RawValue -> IO a) -> IO a)
-> (NonNullPtr RawValue -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NonNullPtr RawValue
pErr ->
    (NonNullPtr RawValue -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr RawValue -> IO a) -> IO a)
-> (NonNullPtr RawValue -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NonNullPtr RawValue
pData ->
      IO InternalState
-> (InternalState -> IO ()) -> (InternalState -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
        IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
Resource.createInternalState
        InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
Resource.closeInternalState
        (\InternalState
eResourceState ->
          ReaderT Environment IO a -> Environment -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Environment IO a
action Environment :: Env
-> NonNullPtr RawValue
-> NonNullPtr RawValue
-> InternalState
-> Environment
Environment
            { eEnv :: Env
eEnv       = Env
env
            , eErrorSym :: NonNullPtr RawValue
eErrorSym  = NonNullPtr RawValue
pErr
            , eErrorData :: NonNullPtr RawValue
eErrorData = NonNullPtr RawValue
pData
            , InternalState
eResourceState :: InternalState
eResourceState :: InternalState
eResourceState
            })

{-# INLINE getRawValue #-}
getRawValue :: Value s -> RawValue
getRawValue :: Value s -> RawValue
getRawValue = GlobalRef -> RawValue
unGlobalRef (GlobalRef -> RawValue)
-> (Value s -> GlobalRef) -> Value s -> RawValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> GlobalRef
forall s. Value s -> GlobalRef
valuePayload

{-# INLINE liftIO' #-}
liftIO' :: (Env -> IO a) -> EmacsM s a
liftIO' :: (Env -> IO a) -> EmacsM s a
liftIO' Env -> IO a
f = ReaderT Environment IO a -> EmacsM s a
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO a -> EmacsM s a)
-> ReaderT Environment IO a -> EmacsM s a
forall a b. (a -> b) -> a -> b
$ (Environment -> Env) -> ReaderT Environment IO Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Environment -> Env
eEnv ReaderT Environment IO Env
-> (Env -> ReaderT Environment IO a) -> ReaderT Environment IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> ReaderT Environment IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT Environment IO a)
-> (Env -> IO a) -> Env -> ReaderT Environment IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> IO a
f

{-# INLINABLE makeValue #-}
-- | Protect a raw value (i.e. a plain pointer) from Emacs GC.
--
-- Users writing emacs extersions will likely have no need to
-- call this function directly.
makeValue
  :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
  => RawValue
  -> EmacsM s (Value s)
makeValue :: RawValue -> EmacsM s (Value s)
makeValue RawValue
raw = do
  Env
env <- ReaderT Environment IO Env -> EmacsM s Env
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO Env -> EmacsM s Env)
-> ReaderT Environment IO Env -> EmacsM s Env
forall a b. (a -> b) -> a -> b
$ (Environment -> Env) -> ReaderT Environment IO Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Environment -> Env
eEnv
  GlobalRef
valuePayload <-
    Doc Void -> EmacsM s GlobalRef -> EmacsM s GlobalRef
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"makeGlobalRef failed" (EmacsM s GlobalRef -> EmacsM s GlobalRef)
-> EmacsM s GlobalRef -> EmacsM s GlobalRef
forall a b. (a -> b) -> a -> b
$
      Env -> RawValue -> EmacsM s GlobalRef
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m GlobalRef
Raw.makeGlobalRef Env
env RawValue
raw
  ReleaseKey
valueReleaseHandle <- IO () -> EmacsM s ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (Env -> GlobalRef -> IO ()
forall (m :: * -> *). MonadIO m => Env -> GlobalRef -> m ()
Raw.freeGlobalRef Env
env GlobalRef
valuePayload)
  Value s -> EmacsM s (Value s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value :: forall s. GlobalRef -> ReleaseKey -> Value s
Value{GlobalRef
valuePayload :: GlobalRef
valuePayload :: GlobalRef
valuePayload, ReleaseKey
valueReleaseHandle :: ReleaseKey
valueReleaseHandle :: ReleaseKey
valueReleaseHandle}

{-# INLINABLE unpackEnumFuncallExit #-}
unpackEnumFuncallExit
  :: (MonadThrow m, Throws EmacsInternalError, WithCallStack)
  => Raw.EnumFuncallExit -> m (FuncallExit ())
unpackEnumFuncallExit :: EnumFuncallExit -> m (FuncallExit ())
unpackEnumFuncallExit (Raw.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 -> m (FuncallExit ())
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsInternalError -> m (FuncallExit ()))
-> EmacsInternalError -> m (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 a ann. Pretty a => a -> Doc ann
pretty Int32
x
    Just FuncallExit ()
y -> FuncallExit () -> m (FuncallExit ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure FuncallExit ()
y

nonLocalExitGet'
  :: (WithCallStack, Throws EmacsInternalError)
  => EmacsM s (FuncallExit (RawValue, RawValue))
nonLocalExitGet' :: EmacsM s (FuncallExit (RawValue, RawValue))
nonLocalExitGet' = do
  Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonNullPtr RawValue
eErrorSym :: NonNullPtr RawValue
eErrorSym :: Environment -> NonNullPtr RawValue
eErrorSym, NonNullPtr RawValue
eErrorData :: NonNullPtr RawValue
eErrorData :: Environment -> NonNullPtr RawValue
eErrorData} <- ReaderT Environment IO Environment -> EmacsM s Environment
forall s a. ReaderT Environment IO a -> EmacsM s a
EmacsM ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (FuncallExit (RawValue, RawValue))
-> EmacsM s (FuncallExit (RawValue, RawValue))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FuncallExit (RawValue, RawValue))
 -> EmacsM s (FuncallExit (RawValue, RawValue)))
-> IO (FuncallExit (RawValue, RawValue))
-> EmacsM s (FuncallExit (RawValue, RawValue))
forall a b. (a -> b) -> a -> b
$ do
    FuncallExit ()
x <- EnumFuncallExit -> IO (FuncallExit ())
forall (m :: * -> *).
(MonadThrow m, Throws EmacsInternalError, WithCallStack) =>
EnumFuncallExit -> m (FuncallExit ())
unpackEnumFuncallExit (EnumFuncallExit -> IO (FuncallExit ()))
-> IO EnumFuncallExit -> IO (FuncallExit ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> NonNullPtr RawValue -> NonNullPtr RawValue -> IO EnumFuncallExit
forall (m :: * -> *).
MonadIO m =>
Env
-> NonNullPtr RawValue -> NonNullPtr RawValue -> m EnumFuncallExit
Raw.nonLocalExitGet Env
eEnv NonNullPtr RawValue
eErrorSym NonNullPtr RawValue
eErrorData
    FuncallExit ()
-> (() -> IO (RawValue, RawValue))
-> IO (FuncallExit (RawValue, RawValue))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FuncallExit ()
x ((() -> IO (RawValue, RawValue))
 -> IO (FuncallExit (RawValue, RawValue)))
-> (() -> IO (RawValue, RawValue))
-> IO (FuncallExit (RawValue, RawValue))
forall a b. (a -> b) -> a -> b
$ \()
_ ->
      (,) (RawValue -> RawValue -> (RawValue, RawValue))
-> IO RawValue -> IO (RawValue -> (RawValue, RawValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr RawValue -> IO RawValue
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr RawValue -> Ptr RawValue
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr RawValue
eErrorSym) IO (RawValue -> (RawValue, RawValue))
-> IO RawValue -> IO (RawValue, RawValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr RawValue -> IO RawValue
forall a. Storable a => Ptr a -> IO a
peek (NonNullPtr RawValue -> Ptr RawValue
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr RawValue
eErrorData)

{-# INLINE nonLocalExitClear' #-}
nonLocalExitClear' :: WithCallStack => EmacsM s ()
nonLocalExitClear' :: EmacsM s ()
nonLocalExitClear' = (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Raw.nonLocalExitClear

{-# INLINE nonLocalExitCheck' #-}
nonLocalExitCheck'
  :: (WithCallStack, Throws EmacsInternalError)
  => EmacsM s (FuncallExit ())
nonLocalExitCheck' :: EmacsM s (FuncallExit ())
nonLocalExitCheck' = (Env -> IO (FuncallExit ())) -> EmacsM s (FuncallExit ())
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' (EnumFuncallExit -> IO (FuncallExit ())
forall (m :: * -> *).
(MonadThrow m, Throws EmacsInternalError, WithCallStack) =>
EnumFuncallExit -> m (FuncallExit ())
unpackEnumFuncallExit (EnumFuncallExit -> IO (FuncallExit ()))
-> (Env -> IO EnumFuncallExit) -> Env -> IO (FuncallExit ())
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Env -> IO EnumFuncallExit
forall (m :: * -> *). MonadIO m => Env -> m EnumFuncallExit
Raw.nonLocalExitCheck)


checkExitAndRethrowInHaskell
  :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
  => Doc Void -- ^ Error message
  -> EmacsM s ()
checkExitAndRethrowInHaskell :: Doc Void -> EmacsM s ()
checkExitAndRethrowInHaskell Doc Void
errMsg = do
  FuncallExit (RawValue, RawValue)
x <- EmacsM s (FuncallExit (RawValue, RawValue))
forall s.
(WithCallStack, Throws EmacsInternalError) =>
EmacsM s (FuncallExit (RawValue, RawValue))
nonLocalExitGet'
  case FuncallExit (RawValue, RawValue)
x of
    FuncallExit (RawValue, RawValue)
FuncallExitReturn            -> () -> EmacsM s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    FuncallExitSignal (RawValue
sym, RawValue
dat) -> do
      EmacsM s ()
forall s. WithCallStack => EmacsM s ()
nonLocalExitClear'
      RawValue
dat'      <- SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked [esym|cons|] [RawValue
sym, RawValue
dat]
      RawValue
formatted <- SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked [esym|prin1-to-string|] [RawValue
dat']
      FuncallExit ()
formatRes <- EmacsM s (FuncallExit ())
forall s.
(WithCallStack, Throws EmacsInternalError) =>
EmacsM s (FuncallExit ())
nonLocalExitCheck'
      case FuncallExit ()
formatRes of
        FuncallExitSignal{} -> do
          EmacsM s ()
forall s. WithCallStack => EmacsM s ()
nonLocalExitClear'
          EmacsInternalError -> EmacsM s ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsInternalError -> EmacsM s ())
-> EmacsInternalError -> EmacsM s ()
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
"Failed to format Emacs error data while processing following error:" 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
<> Doc Void
errMsg
        FuncallExitThrow{}  -> do
          EmacsM s ()
forall s. WithCallStack => EmacsM s ()
nonLocalExitClear'
          EmacsInternalError -> EmacsM s ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsInternalError -> EmacsM s ())
-> EmacsInternalError -> EmacsM s ()
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
"Failed to format Emacs error data while processing following error:" 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
<> Doc Void
errMsg
        FuncallExit ()
FuncallExitReturn   -> do
          Text
formatted' <- RawValue -> EmacsM s Text
forall s.
(WithCallStack, Throws EmacsInternalError) =>
RawValue -> EmacsM s Text
extractTextUtf8Unchecked RawValue
formatted
          EmacsError -> EmacsM s ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsError -> EmacsM s ()) -> EmacsError -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$
            WithCallStack => Doc Void -> Doc Void -> EmacsError
Doc Void -> Doc Void -> EmacsError
mkEmacsError Doc Void
errMsg (Doc Void -> EmacsError) -> Doc Void -> EmacsError
forall a b. (a -> b) -> a -> b
$
              Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Text
formatted'
    FuncallExitThrow (RawValue
tag, RawValue
value) ->
      -- NB do not clear local exit flag - we, hopefully, should exit
      -- now by unwinding full Haskell stack and the flag should be
      -- reported all the way to Emacs to show a meaningful error or
      -- do a catch in elisp.
      EmacsThrow -> EmacsM s ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw EmacsThrow :: RawValue -> RawValue -> EmacsThrow
EmacsThrow
        { emacsThrowTag :: RawValue
emacsThrowTag   = RawValue
tag
        , emacsThrowValue :: RawValue
emacsThrowValue = RawValue
value
        }

{-# INLINE checkExitAndRethrowInHaskell' #-}
checkExitAndRethrowInHaskell'
  :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
  => Doc Void -- ^ Error message
  -> EmacsM s a
  -> EmacsM s a
checkExitAndRethrowInHaskell' :: Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
errMsg EmacsM s a
action =
  EmacsM s a
action EmacsM s a -> EmacsM s () -> EmacsM s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Doc Void -> EmacsM s ()
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s ()
checkExitAndRethrowInHaskell Doc Void
errMsg

{-# INLINE internUnchecked #-}
internUnchecked :: SymbolName -> EmacsM s RawValue
internUnchecked :: SymbolName -> EmacsM s RawValue
internUnchecked SymbolName
sym =
  (Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString SymbolName
sym ((CString -> IO RawValue) -> IO RawValue)
-> (CString -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env

{-# INLINE funcallUnchecked #-}
funcallUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
funcallUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
funcallUnchecked SymbolName
name [RawValue]
args = do
  (Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    RawValue
fun <- SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString SymbolName
name ((CString -> IO RawValue) -> IO RawValue)
-> (CString -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env
    [RawValue] -> (Int -> Ptr RawValue -> IO RawValue) -> IO RawValue
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [RawValue]
args ((Int -> Ptr RawValue -> IO RawValue) -> IO RawValue)
-> (Int -> Ptr RawValue -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ \Int
n Ptr RawValue
args' ->
      Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> m RawValue
Raw.funcall Env
env RawValue
fun (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Ptr RawValue -> NonNullPtr RawValue
forall a. WithCallStack => Ptr a -> NonNullPtr a
mkNonNullPtr Ptr RawValue
args')

{-# INLINE funcallPrimitiveUnchecked #-}
funcallPrimitiveUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked SymbolName
name [RawValue]
args =
  (Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    RawValue
fun <- SymbolName -> (CString -> IO RawValue) -> IO RawValue
forall a. SymbolName -> (CString -> IO a) -> IO a
useSymbolNameAsCString SymbolName
name ((CString -> IO RawValue) -> IO RawValue)
-> (CString -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ Env -> CString -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CString -> m RawValue
Raw.intern Env
env
    [RawValue] -> (Int -> Ptr RawValue -> IO RawValue) -> IO RawValue
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [RawValue]
args ((Int -> Ptr RawValue -> IO RawValue) -> IO RawValue)
-> (Int -> Ptr RawValue -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ \Int
n Ptr RawValue
args' ->
      Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> m RawValue
Raw.funcallPrimitive Env
env RawValue
fun (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Ptr RawValue -> NonNullPtr RawValue
forall a. WithCallStack => Ptr a -> NonNullPtr a
mkNonNullPtr Ptr RawValue
args')

{-# INLINE typeOfUnchecked #-}
typeOfUnchecked :: Value s -> EmacsM s RawValue
typeOfUnchecked :: Value s -> EmacsM s RawValue
typeOfUnchecked Value s
x =
  (Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m RawValue
Raw.typeOf Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
x)

extractTextUtf8Unchecked
  :: (WithCallStack, Throws EmacsInternalError)
  => RawValue -> EmacsM s T.Text
extractTextUtf8Unchecked :: RawValue -> EmacsM s Text
extractTextUtf8Unchecked =
  (ByteString -> Text) -> EmacsM s ByteString -> EmacsM s Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode) (EmacsM s ByteString -> EmacsM s Text)
-> (RawValue -> EmacsM s ByteString) -> RawValue -> EmacsM s Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawValue -> EmacsM s ByteString
forall s.
(WithCallStack, Throws EmacsInternalError) =>
RawValue -> EmacsM s ByteString
extractStringUnchecked

extractStringUnchecked
  :: (WithCallStack, Throws EmacsInternalError)
  => RawValue -> EmacsM s BS.ByteString
extractStringUnchecked :: RawValue -> EmacsM s ByteString
extractStringUnchecked RawValue
x =
  (Env -> IO ByteString) -> EmacsM s ByteString
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ByteString) -> EmacsM s ByteString)
-> (Env -> IO ByteString) -> EmacsM s ByteString
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    (NonNullPtr CPtrdiff -> IO ByteString) -> IO ByteString
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr CPtrdiff -> IO ByteString) -> IO ByteString)
-> (NonNullPtr CPtrdiff -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \NonNullPtr CPtrdiff
pSize -> do
      CBoolean
res  <- Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Raw.copyStringContents Env
env RawValue
x CString
forall a. Ptr a
nullPtr NonNullPtr CPtrdiff
pSize
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CBoolean -> Bool
Raw.isTruthy CBoolean
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- Raw.nonLocalExitClear env
        EmacsInternalError -> IO ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsInternalError -> IO ()) -> EmacsInternalError -> IO ()
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."
      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)
      Int -> (NonNullPtr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (NonNullPtr a -> IO b) -> IO b
allocaBytesNonNull Int
size ((NonNullPtr CChar -> IO ByteString) -> IO ByteString)
-> (NonNullPtr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \NonNullPtr CChar
pStr -> do
        CBoolean
copyPerformed <- Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> IO CBoolean
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> m CBoolean
Raw.copyStringContents Env
env RawValue
x (NonNullPtr CChar -> CString
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CChar
pStr) NonNullPtr CPtrdiff
pSize
        if CBoolean -> Bool
Raw.isTruthy CBoolean
copyPerformed
        then
          -- Should subtract 1 from size to avoid NULL terminator at the end.
          CStringLen -> IO ByteString
BS.packCStringLen (NonNullPtr CChar -> CString
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr CChar
pStr, Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        else do
          Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Raw.nonLocalExitClear Env
env
          EmacsInternalError -> IO ByteString
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw (EmacsInternalError -> IO ByteString)
-> EmacsInternalError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
Doc Void -> EmacsInternalError
mkEmacsInternalError Doc Void
"Failed to unpack string"

instance (Throws EmacsThrow, Throws EmacsError, Throws EmacsInternalError) => MonadEmacs EmacsM where

  type EmacsRef    EmacsM = Value
  type EmacsReturn EmacsM = EmacsRef EmacsM

  {-# INLINE produceRef #-}
  produceRef :: EmacsRef EmacsM s -> EmacsM s (EmacsReturn EmacsM s)
produceRef EmacsRef EmacsM s
x = do
    Maybe (IO ())
_ <- ReleaseKey -> EmacsM s (Maybe (IO ()))
forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
Resource.unprotect (ReleaseKey -> EmacsM s (Maybe (IO ())))
-> ReleaseKey -> EmacsM s (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ Value s -> ReleaseKey
forall s. Value s -> ReleaseKey
valueReleaseHandle Value s
EmacsRef EmacsM s
x
    Value s -> EmacsM s (Value s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value s
EmacsRef EmacsM s
x

  {-# INLINE nonLocalExitCheck #-}
  nonLocalExitCheck :: EmacsM s (FuncallExit ())
nonLocalExitCheck = EmacsM s (FuncallExit ())
forall s.
(WithCallStack, Throws EmacsInternalError) =>
EmacsM s (FuncallExit ())
nonLocalExitCheck'

  {-# INLINE nonLocalExitGet #-}
  nonLocalExitGet :: EmacsM s (FuncallExit (EmacsRef EmacsM s, EmacsRef EmacsM s))
nonLocalExitGet = do
    FuncallExit (RawValue, RawValue)
z <- EmacsM s (FuncallExit (RawValue, RawValue))
forall s.
(WithCallStack, Throws EmacsInternalError) =>
EmacsM s (FuncallExit (RawValue, RawValue))
nonLocalExitGet'
    FuncallExit (RawValue, RawValue)
-> ((RawValue, RawValue) -> EmacsM s (Value s, Value s))
-> EmacsM s (FuncallExit (Value s, Value s))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FuncallExit (RawValue, RawValue)
z (((RawValue, RawValue) -> EmacsM s (Value s, Value s))
 -> EmacsM s (FuncallExit (Value s, Value s)))
-> ((RawValue, RawValue) -> EmacsM s (Value s, Value s))
-> EmacsM s (FuncallExit (Value s, Value s))
forall a b. (a -> b) -> a -> b
$ \(RawValue
x, RawValue
y) -> (,) (Value s -> Value s -> (Value s, Value s))
-> EmacsM s (Value s) -> EmacsM s (Value s -> (Value s, Value s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue RawValue
x EmacsM s (Value s -> (Value s, Value s))
-> EmacsM s (Value s) -> EmacsM s (Value s, Value s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue RawValue
y

  nonLocalExitSignal :: EmacsRef EmacsM s -> [EmacsRef EmacsM s] -> EmacsM s ()
nonLocalExitSignal EmacsRef EmacsM s
sym [EmacsRef EmacsM s]
errData = do
    RawValue
errData' <- SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked [esym|list|] ((Value s -> RawValue) -> [Value s] -> [RawValue]
forall a b. (a -> b) -> [a] -> [b]
map Value s -> RawValue
forall s. Value s -> RawValue
getRawValue [Value s]
[EmacsRef EmacsM s]
errData)
    (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> RawValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> RawValue -> m ()
Raw.nonLocalExitSignal Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
sym) RawValue
errData'

  {-# INLINE nonLocalExitThrow #-}
  nonLocalExitThrow :: EmacsRef EmacsM s -> EmacsRef EmacsM s -> EmacsM s ()
nonLocalExitThrow EmacsRef EmacsM s
tag EmacsRef EmacsM s
errData = do
    (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> RawValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> RawValue -> m ()
Raw.nonLocalExitThrow Env
env RawValue
tag' RawValue
errData'
    EmacsThrow -> EmacsM s ()
forall (m :: * -> *) e a.
(MonadThrow m, Exception e, Throws e) =>
e -> m a
Checked.throw EmacsThrow :: RawValue -> RawValue -> EmacsThrow
EmacsThrow
      { emacsThrowTag :: RawValue
emacsThrowTag   = RawValue
tag'
      , emacsThrowValue :: RawValue
emacsThrowValue = RawValue
errData'
      }
    where
      tag' :: RawValue
tag'     = Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
tag
      errData' :: RawValue
errData' = Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
errData

  {-# INLINE nonLocalExitClear #-}
  nonLocalExitClear :: EmacsM s ()
nonLocalExitClear = EmacsM s ()
forall s. WithCallStack => EmacsM s ()
nonLocalExitClear'

  -- {-# INLINE makeGlobalRef #-}
  -- makeGlobalRef x =
  --   checkExitAndRethrowInHaskell' "makeGlobalRef failed" $
  --     liftIO' (\env -> Raw.makeGlobalRef env x)
  --
  -- {-# INLINE freeGlobalRef #-}
  -- freeGlobalRef x =
  --   checkExitAndRethrowInHaskell' "freeGlobalRef failed" $
  --     liftIO' (\env -> Raw.freeGlobalRef env x)

  {-# INLINE freeValue #-}
  freeValue :: WithCallStack => Value s -> EmacsM s ()
  freeValue :: Value s -> EmacsM s ()
freeValue = ReleaseKey -> EmacsM s ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> EmacsM s ())
-> (Value s -> ReleaseKey) -> Value s -> EmacsM s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> ReleaseKey
forall s. Value s -> ReleaseKey
valueReleaseHandle

  {-# INLINE makeFunctionExtra #-}
  makeFunctionExtra
    :: forall req opt rest extra s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)
    => (forall s'. EmacsFunctionExtra req opt rest extra s' EmacsM)
    -> C8.ByteString
    -> Ptr extra
    -> EmacsM s (Value s)
  makeFunctionExtra :: (forall s'. EmacsFunctionExtra req opt rest extra s' EmacsM)
-> ByteString -> Ptr extra -> EmacsM s (Value s)
makeFunctionExtra forall s'. EmacsFunctionExtra req opt rest extra s' EmacsM
emacsFun ByteString
docs Ptr extra
extraPtr =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"makeFunctionExtra failed"
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env ->
        ByteString -> (CString -> IO RawValue) -> IO RawValue
forall a. ByteString -> (CString -> IO a) -> IO a
C8.useAsCString ByteString
docs ((CString -> IO RawValue) -> IO RawValue)
-> (CString -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ \CString
docs' -> do
          RawFunction extra
implementation' <- RawFunctionType extra -> IO (RawFunction extra)
forall a. RawFunctionType a -> IO (RawFunction a)
exportToEmacs RawFunctionType extra
implementation
          Env
-> CPtrdiff
-> CPtrdiff
-> RawFunction extra
-> CString
-> Ptr extra
-> IO RawValue
forall (m :: * -> *) a.
MonadIO m =>
Env
-> CPtrdiff
-> CPtrdiff
-> RawFunction a
-> CString
-> Ptr a
-> m RawValue
Raw.makeFunction Env
env CPtrdiff
minArity CPtrdiff
maxArity RawFunction extra
implementation' CString
docs' Ptr extra
extraPtr)
    where
      (CPtrdiff
minArity, CPtrdiff
maxArity) = Proxy req -> Proxy opt -> Proxy rest -> (CPtrdiff, CPtrdiff)
forall (req :: Nat) (opt :: Nat) (rest :: Bool).
GetArities req opt rest =>
Proxy req -> Proxy opt -> Proxy rest -> (CPtrdiff, CPtrdiff)
arities (Proxy req
forall k (t :: k). Proxy t
Proxy @req) (Proxy opt
forall k (t :: k). Proxy t
Proxy @opt) (Proxy rest
forall k (t :: k). Proxy t
Proxy @rest)

      implementation :: RawFunctionType extra
      implementation :: RawFunctionType extra
implementation Env
env CPtrdiff
nargs Ptr RawValue
argsPtr Ptr extra
extraPtr' =
        Proxy UserError -> (Throws UserError => IO RawValue) -> IO RawValue
forall a e (proxy :: * -> *). proxy e -> (Throws e => a) -> a
Checked.uncheck (Proxy UserError
forall k (t :: k). Proxy t
Proxy @UserError) ((Throws UserError => IO RawValue) -> IO RawValue)
-> (Throws UserError => IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$
          (SomeException -> IO RawValue) -> IO RawValue -> IO RawValue
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> SomeException -> IO RawValue
reportAnyErrorToEmacs Env
env) (IO RawValue -> IO RawValue) -> IO RawValue -> IO RawValue
forall a b. (a -> b) -> a -> b
$
            (EmacsThrow -> IO RawValue)
-> (Throws EmacsThrow => IO RawValue) -> IO RawValue
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> (Throws e => m a) -> m a
Checked.handle (Env -> EmacsThrow -> IO RawValue
reportEmacsThrowToEmacs Env
env) ((Throws EmacsThrow => IO RawValue) -> IO RawValue)
-> (Throws EmacsThrow => IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ do
              GlobalRef
res <- Env -> (forall s. EmacsM s GlobalRef) -> IO GlobalRef
forall a. Env -> (forall s. EmacsM s a) -> IO a
runEmacsM Env
env ((forall s. EmacsM s GlobalRef) -> IO GlobalRef)
-> (forall s. EmacsM s GlobalRef) -> IO GlobalRef
forall a b. (a -> b) -> a -> b
$ do
                Value s
v <- Int
-> Ptr RawValue
-> (RawValue -> EmacsM s (Value s))
-> (EmacsArgs req opt rest (Value s) -> EmacsM s (Value s))
-> EmacsM s (Value s)
forall (req :: Nat) (opt :: Nat) (rest :: Bool) (m :: * -> *) a b.
(EmacsInvocation req opt rest, MonadBase IO m) =>
Int
-> Ptr RawValue
-> (RawValue -> m a)
-> (EmacsArgs req opt rest a -> m b)
-> m b
supplyEmacsArgs (CPtrdiff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CPtrdiff
nargs) Ptr RawValue
argsPtr RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (\EmacsArgs req opt rest (Value s)
args -> EmacsArgs req opt rest (EmacsRef EmacsM s)
-> Ptr extra -> EmacsM s (EmacsReturn EmacsM s)
forall s'. EmacsFunctionExtra req opt rest extra s' EmacsM
emacsFun EmacsArgs req opt rest (Value s)
EmacsArgs req opt rest (EmacsRef EmacsM s)
args Ptr extra
extraPtr')
                GlobalRef -> EmacsM s GlobalRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalRef -> EmacsM s GlobalRef)
-> GlobalRef -> EmacsM s GlobalRef
forall a b. (a -> b) -> a -> b
$! Value s -> GlobalRef
forall s. Value s -> GlobalRef
valuePayload Value s
v
#ifndef MODULE_ASSERTIONS
              Env -> GlobalRef -> IO ()
forall (m :: * -> *). MonadIO m => Env -> GlobalRef -> m ()
Raw.freeGlobalRef Env
env GlobalRef
res
#endif
              RawValue -> IO RawValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawValue -> IO RawValue) -> RawValue -> IO RawValue
forall a b. (a -> b) -> a -> b
$ GlobalRef -> RawValue
unGlobalRef GlobalRef
res

  {-# INLINE funcall #-}
  funcall :: SymbolName -> [EmacsRef EmacsM s] -> EmacsM s (EmacsRef EmacsM s)
funcall SymbolName
name [EmacsRef EmacsM s]
args =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"funcall" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
squotes (SymbolName -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty SymbolName
name) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      (SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallUnchecked SymbolName
name ((Value s -> RawValue) -> [Value s] -> [RawValue]
forall a b. (a -> b) -> [a] -> [b]
map Value s -> RawValue
forall s. Value s -> RawValue
getRawValue [Value s]
[EmacsRef EmacsM s]
args))

  {-# INLINE funcallPrimitive #-}
  funcallPrimitive :: SymbolName -> [EmacsRef EmacsM s] -> EmacsM s (EmacsRef EmacsM s)
funcallPrimitive SymbolName
name [EmacsRef EmacsM s]
args =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"funcall primitive" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
squotes (SymbolName -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty SymbolName
name) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      (SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked SymbolName
name ((Value s -> RawValue) -> [Value s] -> [RawValue]
forall a b. (a -> b) -> [a] -> [b]
map Value s -> RawValue
forall s. Value s -> RawValue
getRawValue [Value s]
[EmacsRef EmacsM s]
args))

  {-# INLINE funcallPrimitive_ #-}
  funcallPrimitive_ :: SymbolName -> [EmacsRef EmacsM s] -> EmacsM s ()
funcallPrimitive_ SymbolName
name [EmacsRef EmacsM s]
args =
    Doc Void -> EmacsM s () -> EmacsM s ()
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"funcall primitive" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
squotes (SymbolName -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty SymbolName
name) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      (EmacsM s RawValue -> EmacsM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (EmacsM s RawValue -> EmacsM s ())
-> EmacsM s RawValue -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ SymbolName -> [RawValue] -> EmacsM s RawValue
forall s. SymbolName -> [RawValue] -> EmacsM s RawValue
funcallPrimitiveUnchecked SymbolName
name ((Value s -> RawValue) -> [Value s] -> [RawValue]
forall a b. (a -> b) -> [a] -> [b]
map Value s -> RawValue
forall s. Value s -> RawValue
getRawValue [Value s]
[EmacsRef EmacsM s]
args))

  {-# INLINE intern #-}
  intern :: SymbolName -> EmacsM s (EmacsRef EmacsM s)
intern SymbolName
sym =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"intern of" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
squotes (SymbolName -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty SymbolName
sym) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      (SymbolName -> EmacsM s RawValue
forall s. SymbolName -> EmacsM s RawValue
internUnchecked SymbolName
sym)

  {-# INLINE typeOf #-}
  typeOf :: EmacsRef EmacsM s -> EmacsM s (EmacsRef EmacsM s)
typeOf EmacsRef EmacsM s
x =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"typeOf failed"
      (Value s -> EmacsM s RawValue
forall s. Value s -> EmacsM s RawValue
typeOfUnchecked Value s
EmacsRef EmacsM s
x)

  {-# INLINE isNotNil #-}
  isNotNil :: EmacsRef EmacsM s -> EmacsM s Bool
isNotNil EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s Bool -> EmacsM s Bool
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"isNotNil failed"
      ((Env -> IO Bool) -> EmacsM s Bool
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO Bool) -> EmacsM s Bool)
-> (Env -> IO Bool) -> EmacsM s Bool
forall a b. (a -> b) -> a -> b
$ \Env
env -> CBoolean -> Bool
Raw.isTruthy (CBoolean -> Bool) -> IO CBoolean -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> RawValue -> IO CBoolean
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m CBoolean
Raw.isNotNil Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x))

  {-# INLINE eq #-}
  eq :: EmacsRef EmacsM s -> EmacsRef EmacsM s -> EmacsM s Bool
eq EmacsRef EmacsM s
x EmacsRef EmacsM s
y =
    Doc Void -> EmacsM s Bool -> EmacsM s Bool
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"eq failed"
      ((Env -> IO Bool) -> EmacsM s Bool
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO Bool) -> EmacsM s Bool)
-> (Env -> IO Bool) -> EmacsM s Bool
forall a b. (a -> b) -> a -> b
$ \Env
env -> CBoolean -> Bool
Raw.isTruthy (CBoolean -> Bool) -> IO CBoolean -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> RawValue -> RawValue -> IO CBoolean
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> RawValue -> m CBoolean
Raw.eq Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x) (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
y))


  {-# INLINE extractWideInteger #-}
  extractWideInteger :: EmacsRef EmacsM s -> EmacsM s Int64
extractWideInteger EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s Int64 -> EmacsM s Int64
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"extractWideInteger failed"
      ((Env -> IO Int64) -> EmacsM s Int64
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO Int64) -> EmacsM s Int64)
-> (Env -> IO Int64) -> EmacsM s Int64
forall a b. (a -> b) -> a -> b
$ \Env
env -> IO CIntMax -> IO Int64
coerce (Env -> RawValue -> IO CIntMax
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m CIntMax
Raw.extractInteger Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x) :: IO CIntMax))

  {-# INLINE makeWideInteger #-}
  makeWideInteger :: Int64 -> EmacsM s (EmacsRef EmacsM s)
makeWideInteger Int64
x =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"makeWideInteger of" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int64 -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Int64
x Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> CIntMax -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CIntMax -> m RawValue
Raw.makeInteger Env
env (Int64 -> CIntMax
CIntMax Int64
x))

  {-# INLINE extractDouble #-}
  extractDouble :: EmacsRef EmacsM s -> EmacsM s Double
extractDouble EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s Double -> EmacsM s Double
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"extractDouble failed"
      ((Env -> IO Double) -> EmacsM s Double
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO Double) -> EmacsM s Double)
-> (Env -> IO Double) -> EmacsM s Double
forall a b. (a -> b) -> a -> b
$ \Env
env -> IO CDouble -> IO Double
coerce (Env -> RawValue -> IO CDouble
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m CDouble
Raw.extractFloat Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x) :: IO CDouble))

  {-# INLINE makeDouble #-}
  makeDouble :: Double -> EmacsM s (EmacsRef EmacsM s)
makeDouble Double
x =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' (Doc Void
"makeDouble" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Double -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Double
x Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"failed")
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> CDouble -> IO RawValue
forall (m :: * -> *). MonadIO m => Env -> CDouble -> m RawValue
Raw.makeFloat Env
env (Double -> CDouble
CDouble Double
x))

  {-# INLINE extractString #-}
  extractString :: EmacsRef EmacsM s -> EmacsM s ByteString
extractString EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s ByteString -> EmacsM s ByteString
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"extractString failed" (EmacsM s ByteString -> EmacsM s ByteString)
-> EmacsM s ByteString -> EmacsM s ByteString
forall a b. (a -> b) -> a -> b
$
      RawValue -> EmacsM s ByteString
forall s.
(WithCallStack, Throws EmacsInternalError) =>
RawValue -> EmacsM s ByteString
extractStringUnchecked (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x)

  {-# INLINE makeString #-}
  makeString :: ByteString -> EmacsM s (EmacsRef EmacsM s)
makeString ByteString
x =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"makeString failed"
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env ->
        ByteString -> (CString -> IO RawValue) -> IO RawValue
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
x ((CString -> IO RawValue) -> IO RawValue)
-> (CString -> IO RawValue) -> IO RawValue
forall a b. (a -> b) -> a -> b
$ \CString
pStr ->
          Env -> CString -> CPtrdiff -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m RawValue
Raw.makeString Env
env CString
pStr (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
x)))

  {-# INLINE extractUserPtr #-}
  extractUserPtr :: EmacsRef EmacsM s -> EmacsM s (Ptr a)
extractUserPtr EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s (Ptr a) -> EmacsM s (Ptr a)
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"extractUserPtr failed" (EmacsM s (Ptr a) -> EmacsM s (Ptr a))
-> EmacsM s (Ptr a) -> EmacsM s (Ptr a)
forall a b. (a -> b) -> a -> b
$
      (Env -> IO (Ptr a)) -> EmacsM s (Ptr a)
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO (Ptr a)) -> EmacsM s (Ptr a))
-> (Env -> IO (Ptr a)) -> EmacsM s (Ptr a)
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> IO (Ptr a)
forall (m :: * -> *) a. MonadIO m => Env -> RawValue -> m (Ptr a)
Raw.getUserPtr Env
env (RawValue -> IO (Ptr a)) -> RawValue -> IO (Ptr a)
forall a b. (a -> b) -> a -> b
$ Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x

  {-# INLINE makeUserPtr #-}
  makeUserPtr :: UserPtrFinaliser a -> Ptr a -> EmacsM s (EmacsRef EmacsM s)
makeUserPtr UserPtrFinaliser a
finaliser Ptr a
ptr =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"makeUserPtr failed"
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> UserPtrFinaliser a -> Ptr a -> IO RawValue
forall (m :: * -> *) a.
MonadIO m =>
Env -> UserPtrFinaliser a -> Ptr a -> m RawValue
Raw.makeUserPtr Env
env UserPtrFinaliser a
finaliser Ptr a
ptr)

  {-# INLINE assignUserPtr #-}
  assignUserPtr :: EmacsRef EmacsM s -> Ptr a -> EmacsM s ()
assignUserPtr EmacsRef EmacsM s
dest Ptr a
ptr =
    Doc Void -> EmacsM s () -> EmacsM s ()
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"assignUserPtr failed" (EmacsM s () -> EmacsM s ()) -> EmacsM s () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$
      (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> Ptr a -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Env -> RawValue -> Ptr a -> m ()
Raw.setUserPtr Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
dest) Ptr a
ptr

  {-# INLINE extractUserPtrFinaliser #-}
  extractUserPtrFinaliser :: EmacsRef EmacsM s -> EmacsM s (UserPtrFinaliser a)
extractUserPtrFinaliser EmacsRef EmacsM s
x =
    Doc Void
-> EmacsM s (UserPtrFinaliser a) -> EmacsM s (UserPtrFinaliser a)
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"extractUserPtrFinaliser failed" (EmacsM s (UserPtrFinaliser a) -> EmacsM s (UserPtrFinaliser a))
-> EmacsM s (UserPtrFinaliser a) -> EmacsM s (UserPtrFinaliser a)
forall a b. (a -> b) -> a -> b
$
      (Env -> IO (UserPtrFinaliser a)) -> EmacsM s (UserPtrFinaliser a)
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO (UserPtrFinaliser a)) -> EmacsM s (UserPtrFinaliser a))
-> (Env -> IO (UserPtrFinaliser a))
-> EmacsM s (UserPtrFinaliser a)
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> IO (UserPtrFinaliser a)
forall (m :: * -> *) a.
MonadIO m =>
Env -> RawValue -> m (UserPtrFinaliser a)
Raw.getUserFinaliser Env
env (RawValue -> IO (UserPtrFinaliser a))
-> RawValue -> IO (UserPtrFinaliser a)
forall a b. (a -> b) -> a -> b
$ Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x

  {-# INLINE assignUserPtrFinaliser #-}
  assignUserPtrFinaliser :: EmacsRef EmacsM s -> UserPtrFinaliser a -> EmacsM s ()
assignUserPtrFinaliser EmacsRef EmacsM s
x UserPtrFinaliser a
finaliser =
    Doc Void -> EmacsM s () -> EmacsM s ()
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"assignUserPtrFinaliser failed" (EmacsM s () -> EmacsM s ()) -> EmacsM s () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$
      (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> UserPtrFinaliser a -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Env -> RawValue -> UserPtrFinaliser a -> m ()
Raw.setUserFinaliser Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x) UserPtrFinaliser a
finaliser

  {-# INLINE vecGet #-}
  vecGet :: EmacsRef EmacsM s -> Int -> EmacsM s (EmacsRef EmacsM s)
vecGet EmacsRef EmacsM s
vec Int
n =
    RawValue -> EmacsM s (Value s)
forall s.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
RawValue -> EmacsM s (Value s)
makeValue (RawValue -> EmacsM s (Value s))
-> EmacsM s RawValue -> EmacsM s (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Doc Void -> EmacsM s RawValue -> EmacsM s RawValue
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"vecGet failed"
      ((Env -> IO RawValue) -> EmacsM s RawValue
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO RawValue) -> EmacsM s RawValue)
-> (Env -> IO RawValue) -> EmacsM s RawValue
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> CPtrdiff -> IO RawValue
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CPtrdiff -> m RawValue
Raw.vecGet Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
vec) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))

  {-# INLINE vecSet #-}
  vecSet :: EmacsRef EmacsM s -> Int -> EmacsRef EmacsM s -> EmacsM s ()
vecSet EmacsRef EmacsM s
vec Int
n EmacsRef EmacsM s
x =
    Doc Void -> EmacsM s () -> EmacsM s ()
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"vecSet failed" (EmacsM s () -> EmacsM s ()) -> EmacsM s () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$
      (Env -> IO ()) -> EmacsM s ()
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> RawValue -> CPtrdiff -> RawValue -> IO ()
forall (m :: * -> *).
MonadIO m =>
Env -> RawValue -> CPtrdiff -> RawValue -> m ()
Raw.vecSet Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
vec) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
x)

  {-# INLINE vecSize  #-}
  vecSize :: EmacsRef EmacsM s -> EmacsM s Int
vecSize EmacsRef EmacsM s
vec =
    Doc Void -> EmacsM s Int -> EmacsM s Int
forall s a.
(WithCallStack, Throws EmacsInternalError, Throws EmacsError,
 Throws EmacsThrow) =>
Doc Void -> EmacsM s a -> EmacsM s a
checkExitAndRethrowInHaskell' Doc Void
"vecSize failed" (EmacsM s Int -> EmacsM s Int) -> EmacsM s Int -> EmacsM s Int
forall a b. (a -> b) -> a -> b
$
      (Env -> IO Int) -> EmacsM s Int
forall a s. (Env -> IO a) -> EmacsM s a
liftIO' ((Env -> IO Int) -> EmacsM s Int)
-> (Env -> IO Int) -> EmacsM s Int
forall a b. (a -> b) -> a -> b
$ \Env
env -> 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
<$> Env -> RawValue -> IO CPtrdiff
forall (m :: * -> *). MonadIO m => Env -> RawValue -> m CPtrdiff
Raw.vecSize Env
env (Value s -> RawValue
forall s. Value s -> RawValue
getRawValue Value s
EmacsRef EmacsM s
vec)