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

{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UnboxedTuples        #-}
{-# LANGUAGE UndecidableInstances #-}

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

import Control.Exception
import Control.Exception qualified as Exception
import Control.Monad.Base
import Control.Monad.Catch qualified as Catch
import Control.Monad.Fix (MonadFix)
import Control.Monad.Interleave
import Control.Monad.Primitive hiding (unsafeInterleave)
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.ByteString qualified as BS
import Data.ByteString.Short (ShortByteString)
import Data.ByteString.Unsafe qualified as BSU
import Data.Coerce
import Data.Emacs.Module.Doc qualified as Doc
import Data.Int
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Data.Void
import Foreign.C.Types
import Foreign.Ptr
import GHC.ForeignPtr
import GHC.Stack (callStack)
import Prettyprinter

import Data.Emacs.Module.Args
import Data.Emacs.Module.Env.Functions
import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput
import Data.Emacs.Module.GetRawValue
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env qualified as Env
import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType)
import Data.Emacs.Module.Raw.Env.Internal qualified as Env
import Data.Emacs.Module.Raw.Value
import Data.Emacs.Module.SymbolName.Internal
import Data.Emacs.Module.Value.Internal
import Emacs.Module.Assert
import Emacs.Module.Errors
import Emacs.Module.Monad.Class
import Emacs.Module.Monad.Common as Common
import Foreign.Ptr.Builder as PtrBuilder

data Environment = Environment
  { Environment -> Env
eEnv           :: Env
  , Environment -> NonLocalState
eNonLocalState :: {-# UNPACK #-} !NonLocalState
  , Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache     :: BuilderCache (RawValue 'Unknown)
  }

-- | 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 :: k) (a :: Type) = EmacsM { forall k (s :: k) a. EmacsM s a -> ReaderT Environment IO a
unEmacsM :: ReaderT Environment IO a }
  deriving
    ( (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 k (s :: k) a b. a -> EmacsM s b -> EmacsM s a
forall k (s :: k) a b. (a -> b) -> EmacsM s a -> EmacsM s b
forall a b. a -> EmacsM s b -> EmacsM s a
forall 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
$cfmap :: forall k (s :: k) a b. (a -> b) -> EmacsM s a -> EmacsM s b
fmap :: forall a b. (a -> b) -> EmacsM s a -> EmacsM s b
$c<$ :: forall k (s :: k) a b. a -> EmacsM s b -> EmacsM s a
<$ :: forall a b. a -> EmacsM s b -> EmacsM s a
Functor
    , Functor (EmacsM s)
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)
forall a. a -> EmacsM s a
forall k (s :: k). Functor (EmacsM s)
forall k (s :: k) a. a -> EmacsM s a
forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s a
forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall k (s :: k) a b.
EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
forall k (s :: k) 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 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 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
$cpure :: forall k (s :: k) a. a -> EmacsM s a
pure :: forall a. a -> EmacsM s a
$c<*> :: forall k (s :: k) a b.
EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
<*> :: forall a b. EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
$cliftA2 :: forall k (s :: k) a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
liftA2 :: forall a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
$c*> :: forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s b
*> :: forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b
$c<* :: forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s a
<* :: forall a b. EmacsM s a -> EmacsM s b -> EmacsM s a
Applicative
    , Applicative (EmacsM s)
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)
forall a. a -> EmacsM s a
forall k (s :: k). Applicative (EmacsM s)
forall k (s :: k) a. a -> EmacsM s a
forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s b
forall k (s :: k) 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 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
$c>>= :: forall k (s :: k) a b.
EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
>>= :: forall a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
$c>> :: forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s b
>> :: forall a b. EmacsM s a -> EmacsM s b -> EmacsM s b
$creturn :: forall k (s :: k) a. a -> EmacsM s a
return :: forall a. a -> EmacsM s a
Monad
    , Monad (EmacsM s)
Monad (EmacsM s) =>
(forall e a. (HasCallStack, Exception e) => e -> EmacsM s a)
-> MonadThrow (EmacsM s)
forall k (s :: k). Monad (EmacsM s)
forall k (s :: k) e a.
(HasCallStack, Exception e) =>
e -> EmacsM s a
forall e a. (HasCallStack, Exception e) => e -> EmacsM s a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall k (s :: k) e a.
(HasCallStack, Exception e) =>
e -> EmacsM s a
throwM :: forall e a. (HasCallStack, Exception e) => e -> EmacsM s a
Catch.MonadThrow
    , MonadThrow (EmacsM s)
MonadThrow (EmacsM s) =>
(forall e a.
 (HasCallStack, Exception e) =>
 EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a)
-> MonadCatch (EmacsM s)
forall k (s :: k). MonadThrow (EmacsM s)
forall k (s :: k) e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
forall e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall k (s :: k) e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
catch :: forall e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
Catch.MonadCatch
    , MonadCatch (EmacsM s)
MonadCatch (EmacsM s) =>
(forall b.
 HasCallStack =>
 ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b)
-> (forall b.
    HasCallStack =>
    ((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b)
-> (forall a b c.
    HasCallStack =>
    EmacsM s a
    -> (a -> ExitCase b -> EmacsM s c)
    -> (a -> EmacsM s b)
    -> EmacsM s (b, c))
-> MonadMask (EmacsM s)
forall b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
forall k (s :: k). MonadCatch (EmacsM s)
forall k (s :: k) b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
forall k (s :: k) a b c.
HasCallStack =>
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
forall a b c.
HasCallStack =>
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall k (s :: k) b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
mask :: forall b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cuninterruptibleMask :: forall k (s :: k) b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cgeneralBracket :: forall k (s :: k) a b c.
HasCallStack =>
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
generalBracket :: forall a b c.
HasCallStack =>
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
Catch.MonadMask
    , Monad (EmacsM s)
Monad (EmacsM s) =>
(forall a. (a -> EmacsM s a) -> EmacsM s a) -> MonadFix (EmacsM s)
forall a. (a -> EmacsM s a) -> EmacsM s a
forall k (s :: k). Monad (EmacsM s)
forall k (s :: k) a. (a -> EmacsM s a) -> EmacsM s a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall k (s :: k) a. (a -> EmacsM s a) -> EmacsM s a
mfix :: forall a. (a -> EmacsM s a) -> EmacsM s a
MonadFix
    , Monad (EmacsM s)
Monad (EmacsM s) =>
(forall a.
 (State# (PrimState (EmacsM s))
  -> (# State# (PrimState (EmacsM s)), a #))
 -> EmacsM s a)
-> PrimMonad (EmacsM s)
forall a.
(State# (PrimState (EmacsM s))
 -> (# State# (PrimState (EmacsM s)), a #))
-> EmacsM s a
forall k (s :: k). Monad (EmacsM s)
forall k (s :: k) a.
(State# (PrimState (EmacsM s))
 -> (# State# (PrimState (EmacsM s)), a #))
-> EmacsM s a
forall (m :: * -> *).
Monad m =>
(forall a.
 (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
$cprimitive :: forall k (s :: k) a.
(State# (PrimState (EmacsM s))
 -> (# State# (PrimState (EmacsM s)), a #))
-> EmacsM s a
primitive :: forall a.
(State# (PrimState (EmacsM s))
 -> (# State# (PrimState (EmacsM s)), a #))
-> EmacsM s a
PrimMonad
    )

instance MonadInterleave (EmacsM s) where
  {-# INLINE unsafeInterleave #-}
  unsafeInterleave :: forall a. EmacsM s a -> EmacsM s a
unsafeInterleave (EmacsM ReaderT Environment IO a
action) = ReaderT Environment IO a -> EmacsM s a
forall k (s :: k) 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
    Environment
env <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO a -> ReaderT Environment IO a
forall α. IO α -> ReaderT Environment IO α
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
$ IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadInterleave m => m a -> m a
unsafeInterleave (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ 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

instance MonadIO (EmacsM s) where
  {-# INLINE liftIO #-}
  liftIO :: forall a. IO a -> EmacsM s a
liftIO = ReaderT Environment IO a -> EmacsM s a
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO a -> EmacsM s a)
-> (IO a -> ReaderT Environment IO a) -> IO a -> EmacsM s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT Environment IO a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Environment m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadBase IO (EmacsM s) where
  {-# INLINE liftBase #-}
  liftBase :: forall α. IO α -> EmacsM s α
liftBase = ReaderT Environment IO α -> EmacsM s α
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO α -> EmacsM s α)
-> (IO α -> ReaderT Environment IO α) -> IO α -> EmacsM s α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> ReaderT Environment IO α
forall (m :: * -> *) a. Monad m => m a -> ReaderT Environment m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadBaseControl IO (EmacsM s) where
  type StM (EmacsM s) a = StM (ReaderT Environment IO) a
  {-# INLINE liftBaseWith #-}
  liftBaseWith :: forall a. (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 k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM ((RunInBase (ReaderT Environment IO) IO -> IO a)
-> ReaderT Environment IO a
forall a.
(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
ReaderT Environment IO a -> IO (StM (ReaderT Environment 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 k (s :: k) a. EmacsM s a -> ReaderT Environment IO a
unEmacsM)))
  {-# INLINE restoreM #-}
  restoreM :: forall a. StM (EmacsM s) a -> EmacsM s a
restoreM = ReaderT Environment IO a -> EmacsM s a
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO a -> EmacsM s a)
-> (a -> ReaderT Environment IO a) -> a -> EmacsM s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT Environment IO a
StM (ReaderT Environment IO) a -> ReaderT Environment IO a
forall a.
StM (ReaderT Environment IO) a -> ReaderT Environment IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM

-- | Execute emacs interaction session using an environment supplied by Emacs.
runEmacsM
  :: WithCallStack
  => Env
  -> (forall s. EmacsM s a)
  -> IO a
runEmacsM :: forall {k} a.
WithCallStack =>
Env -> (forall (s :: k). EmacsM s a) -> IO a
runEmacsM Env
eEnv (EmacsM ReaderT Environment IO a
action) =
  (NonLocalState -> IO a) -> IO a
forall a. (NonLocalState -> IO a) -> IO a
withNonLocalState ((NonLocalState -> IO a) -> IO a)
-> (NonLocalState -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NonLocalState
eNonLocalState ->
    Int -> (BuilderCache (RawValue 'Unknown) -> IO a) -> IO a
forall a b. Storable a => Int -> (BuilderCache a -> IO b) -> IO b
withBuilderCache Int
8 ((BuilderCache (RawValue 'Unknown) -> IO a) -> IO a)
-> (BuilderCache (RawValue 'Unknown) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \BuilderCache (RawValue 'Unknown)
eArgsCache ->
      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
eEnv :: Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache }

{-# INLINE withEnv #-}
withEnv :: (Env -> IO a) -> EmacsM s a
withEnv :: forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv Env -> IO a
f = ReaderT Environment IO a -> EmacsM s a
forall k (s :: k) 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
  Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> ReaderT Environment IO a
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (Env -> IO a
f Env
eEnv)

{-# INLINE withEnvCache #-}
withEnvCache :: (Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache :: forall {k} (b :: Pinning) a (s :: k).
(Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache Env -> BuilderCache (RawValue b) -> IO a
f = ReaderT Environment IO a -> EmacsM s a
forall k (s :: k) 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
  Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> ReaderT Environment IO a
forall α. IO α -> ReaderT Environment IO α
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
$ Env -> BuilderCache (RawValue b) -> IO a
f Env
eEnv (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue b)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache)

handleResult :: EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult :: forall a. EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult = \case
  EmacsSuccess    a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  EmacsExitSignal EmacsSignal
e -> EmacsSignal -> IO a
forall e a. Exception e => e -> IO a
throwIO EmacsSignal
e
  EmacsExitThrow  EmacsThrow
e -> EmacsThrow -> IO a
forall e a. Exception e => e -> IO a
throwIO EmacsThrow
e

handleResultNoThrow :: EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow :: forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow = \case
  EmacsSuccess    a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  EmacsExitSignal EmacsSignal
e -> EmacsSignal -> IO a
forall e a. Exception e => e -> IO a
throwIO EmacsSignal
e
  EmacsExitThrow  Void
e -> Void -> IO a
forall a. Void -> a
absurd Void
e

instance MonadEmacs EmacsM Value where

  {-# INLINE makeGlobalRef #-}
  makeGlobalRef :: WithCallStack => Value s -> EmacsM s (RawValue 'Pinned)
  makeGlobalRef :: forall k (s :: k).
WithCallStack =>
Value s -> EmacsM s (RawValue 'Pinned)
makeGlobalRef Value s
x = (Env -> IO (RawValue 'Pinned)) -> EmacsM s (RawValue 'Pinned)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (RawValue 'Pinned)) -> EmacsM s (RawValue 'Pinned))
-> (Env -> IO (RawValue 'Pinned)) -> EmacsM s (RawValue 'Pinned)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Pinned) -> IO (RawValue 'Pinned)
forall a. IO a -> IO a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (RawValue 'Pinned) -> IO (RawValue 'Pinned))
-> IO (RawValue 'Pinned) -> IO (RawValue 'Pinned)
forall a b. (a -> b) -> a -> b
$ Env -> RawValue 'Regular -> IO (RawValue 'Pinned)
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Pinned)
Env.makeGlobalRef Env
env (RawValue 'Regular -> IO (RawValue 'Pinned))
-> RawValue 'Regular -> IO (RawValue 'Pinned)
forall a b. (a -> b) -> a -> b
$ Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x

  {-# INLINE freeGlobalRef #-}
  freeGlobalRef :: WithCallStack => RawValue 'Pinned -> EmacsM s ()
  freeGlobalRef :: forall k (s :: k). WithCallStack => RawValue 'Pinned -> EmacsM s ()
freeGlobalRef RawValue 'Pinned
x = (Env -> IO ()) -> EmacsM s ()
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO () -> IO ()
forall a. IO a -> IO a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Env -> RawValue 'Pinned -> IO ()
forall (m :: * -> *). MonadIO m => Env -> RawValue 'Pinned -> m ()
Env.freeGlobalRef Env
env RawValue 'Pinned
x

  nonLocalExitCheck
    :: WithCallStack
    => EmacsM s (FuncallExit ())
  nonLocalExitCheck :: forall k (s :: k). WithCallStack => EmacsM s (FuncallExit ())
nonLocalExitCheck = (Env -> IO (FuncallExit ())) -> EmacsM s (FuncallExit ())
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (FuncallExit ())) -> EmacsM s (FuncallExit ()))
-> (Env -> IO (FuncallExit ())) -> EmacsM s (FuncallExit ())
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    Env -> IO EnumFuncallExit
forall (m :: * -> *). MonadIO m => Env -> m EnumFuncallExit
Env.nonLocalExitCheck Env
env IO EnumFuncallExit
-> (EnumFuncallExit -> IO (FuncallExit ())) -> IO (FuncallExit ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WithCallStack => EnumFuncallExit -> IO (FuncallExit ())
EnumFuncallExit -> IO (FuncallExit ())
Common.unpackEnumFuncallExit

  nonLocalExitGet
    :: WithCallStack
    => EmacsM s (FuncallExit (Value s, Value s))
  nonLocalExitGet :: forall k (s :: k).
WithCallStack =>
EmacsM s (FuncallExit (Value s, Value s))
nonLocalExitGet = ReaderT Environment IO (FuncallExit (Value s, Value s))
-> EmacsM s (FuncallExit (Value s, Value s))
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (FuncallExit (Value s, Value s))
 -> EmacsM s (FuncallExit (Value s, Value s)))
-> ReaderT Environment IO (FuncallExit (Value s, Value s))
-> EmacsM s (FuncallExit (Value s, Value s))
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (FuncallExit (Value s, Value s))
-> ReaderT Environment IO (FuncallExit (Value s, Value s))
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (FuncallExit (Value s, Value s))
 -> ReaderT Environment IO (FuncallExit (Value s, Value s)))
-> IO (FuncallExit (Value s, Value s))
-> ReaderT Environment IO (FuncallExit (Value s, Value s))
forall a b. (a -> b) -> a -> b
$ do
      FuncallExit (RawValue 'Regular, RawValue 'Regular)
res <- WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Common.nonLocalExitGet Env
eEnv NonLocalState
eNonLocalState
      FuncallExit (Value s, Value s)
-> IO (FuncallExit (Value s, Value s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuncallExit (Value s, Value s)
 -> IO (FuncallExit (Value s, Value s)))
-> FuncallExit (Value s, Value s)
-> IO (FuncallExit (Value s, Value s))
forall a b. (a -> b) -> a -> b
$ FuncallExit (RawValue 'Regular, RawValue 'Regular)
-> FuncallExit (Value s, Value s)
forall a b. Coercible a b => a -> b
coerce FuncallExit (RawValue 'Regular, RawValue 'Regular)
res

  nonLocalExitSignal
    :: (WithCallStack, Foldable f)
    => Value s     -- ^ Error symbol
    -> f (Value s) -- ^ Error data, will be converted to a list as Emacs API expects.
    -> EmacsM s ()
  nonLocalExitSignal :: forall k (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
Value s -> f (Value s) -> EmacsM s ()
nonLocalExitSignal Value s
sym f (Value s)
errData = (Env -> BuilderCache (RawValue Any) -> IO ()) -> EmacsM s ()
forall {k} (b :: Pinning) a (s :: k).
(Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache ((Env -> BuilderCache (RawValue Any) -> IO ()) -> EmacsM s ())
-> (Env -> BuilderCache (RawValue Any) -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env BuilderCache (RawValue Any)
cache ->
    EmacsSignal -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO (EmacsSignal -> IO ()) -> IO EmacsSignal -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> CallStack
-> RawValue 'Unknown
-> Builder (RawValue 'Regular)
-> IO EmacsSignal
forall (a :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> CallStack
-> RawValue 'Unknown
-> Builder (RawValue 'Regular)
-> IO EmacsSignal
Common.nonLocalExitSignal BuilderCache (RawValue Any)
cache Env
env CallStack
HasCallStack => CallStack
callStack (Value s -> RawValue 'Unknown
forall a b. Coercible a b => a -> b
coerce Value s
sym) Builder (RawValue 'Regular)
errData'
    where
      errData' :: Builder (RawValue 'Regular)
errData' =
        (Value s -> Builder (RawValue 'Regular))
-> f (Value s) -> Builder (RawValue 'Regular)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((RawValue 'Regular -> Builder (RawValue 'Regular))
-> Value s -> Builder (RawValue 'Regular)
forall a b. Coercible a b => a -> b
coerce (RawValue 'Regular -> Builder (RawValue 'Regular)
forall a. Storable a => a -> Builder a
PtrBuilder.storable :: RawValue 'Regular -> PtrBuilder.Builder (RawValue 'Regular))) f (Value s)
errData

  nonLocalExitThrow
    :: WithCallStack
    => Value s -- ^ Tag
    -> Value s -- ^ Data
    -> EmacsM s ()
  nonLocalExitThrow :: forall k (s :: k).
WithCallStack =>
Value s -> Value s -> EmacsM s ()
nonLocalExitThrow Value s
tag Value s
errData = (Env -> IO ()) -> EmacsM s ()
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO ()) -> EmacsM s ()) -> (Env -> IO ()) -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    Env -> RawValue 'Regular -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Env.nonLocalExitThrow Env
env RawValue 'Regular
tag' RawValue 'Regular
errData'
    EmacsThrow -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO EmacsThrow
      { emacsThrowTag :: RawValue 'Regular
emacsThrowTag    = RawValue 'Regular
tag'
      , emacsThrowValue :: RawValue 'Regular
emacsThrowValue  = RawValue 'Regular
errData'
      , emacsThrowOrigin :: CallStack
emacsThrowOrigin = CallStack
HasCallStack => CallStack
callStack
      }
    where
      tag' :: RawValue 'Regular
tag'     = Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
tag
      errData' :: RawValue 'Regular
errData' = Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
errData

  nonLocalExitClear :: WithCallStack => EmacsM s ()
  nonLocalExitClear :: forall k (s :: k). WithCallStack => EmacsM s ()
nonLocalExitClear = (Env -> IO ()) -> EmacsM s ()
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv Env -> IO ()
forall (m :: * -> *). MonadIO m => Env -> m ()
Env.nonLocalExitClear

  {-# INLINE makeFunction #-}
  makeFunction
    :: forall req opt rest s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)
    => (forall s'. EmacsFunction req opt rest EmacsM Value s')
    -> Doc.Doc
    -> EmacsM s (Value s)
  makeFunction :: forall {k} {k} (req :: Nat) (opt :: Nat) (rest :: Bool) (s :: k).
(WithCallStack, EmacsInvocation req opt rest,
 GetArities req opt rest) =>
(forall (s' :: k). EmacsFunction req opt rest EmacsM Value s')
-> Doc -> EmacsM s (Value s)
makeFunction forall (s' :: k). EmacsFunction req opt rest EmacsM Value s'
emacsFun Doc
doc = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    RawFunction 'Unknown ()
impl' <- IO (RawFunction 'Unknown ()) -> IO (RawFunction 'Unknown ())
forall a. IO a -> IO a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (RawFunction 'Unknown ()) -> IO (RawFunction 'Unknown ()))
-> IO (RawFunction 'Unknown ()) -> IO (RawFunction 'Unknown ())
forall a b. (a -> b) -> a -> b
$ RawFunctionType 'Unknown () -> IO (RawFunction 'Unknown ())
forall (o :: Pinning) a.
RawFunctionType o a -> IO (RawFunction o a)
Env.exportToEmacs RawFunctionType 'Unknown ()
impl
    Doc -> (CString -> IO (Value s)) -> IO (Value s)
forall a. Doc -> (CString -> IO a) -> IO a
Doc.useDocAsCString Doc
doc ((CString -> IO (Value s)) -> IO (Value s))
-> (CString -> IO (Value s)) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ \CString
doc' -> do
      RawValue 'Regular
func <- Env
-> CPtrdiff
-> CPtrdiff
-> RawFunction 'Unknown ()
-> CString
-> Ptr ()
-> IO (RawValue 'Regular)
forall (m :: * -> *) (o :: Pinning) a.
MonadIO m =>
Env
-> CPtrdiff
-> CPtrdiff
-> RawFunction o a
-> CString
-> Ptr a
-> m (RawValue 'Regular)
Env.makeFunction Env
env CPtrdiff
minArity CPtrdiff
maxArity RawFunction 'Unknown ()
impl' CString
doc' (FunPtr (RawFunctionType 'Unknown ()) -> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr (RawFunction 'Unknown () -> FunPtr (RawFunctionType 'Unknown ())
forall (o :: Pinning) a.
RawFunction o a -> FunPtr (RawFunctionType o a)
Env.unRawFunction RawFunction 'Unknown ()
impl'))
      Env -> RawValue 'Regular -> FinalizerPtr Any -> IO ()
forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> FinalizerPtr a -> m ()
Env.setFunctionFinalizer Env
env RawValue 'Regular
func FinalizerPtr Any
forall a. FinalizerPtr a
Env.freeHaskellFunPtrWrapped
      Value s -> IO (Value s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value s -> IO (Value s)) -> Value s -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ RawValue 'Regular -> Value s
forall k (s :: k). RawValue 'Regular -> Value s
Value RawValue 'Regular
func
    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 (forall {k} (t :: k). Proxy t
forall (t :: Nat). Proxy t
Proxy @req) (forall {k} (t :: k). Proxy t
forall (t :: Nat). Proxy t
Proxy @opt) (forall (t :: Bool). Proxy t
forall {k} (t :: k). Proxy t
Proxy @rest)

      impl :: RawFunctionType 'Unknown ()
      impl :: RawFunctionType 'Unknown ()
impl Ptr Environment
envPtr CPtrdiff
nargs Ptr (RawValue 'Regular)
argsPtr Ptr ()
_extraPtr = do
        let env :: Env
env = Ptr Environment -> Env
Env.fromPtr Ptr Environment
envPtr
        (SomeException -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> SomeException -> IO (RawValue 'Unknown)
reportAnyErrorToEmacs Env
env) (IO (RawValue 'Unknown) -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$
          (EmacsSignal -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> EmacsSignal -> IO (RawValue 'Unknown)
reportEmacsSignalToEmacs Env
env) (IO (RawValue 'Unknown) -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$
            (EmacsThrow -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> EmacsThrow -> IO (RawValue 'Unknown)
reportEmacsThrowToEmacs Env
env) (IO (RawValue 'Unknown) -> IO (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> IO (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$
              Env
-> (forall {s :: Any}. EmacsM s (RawValue 'Unknown))
-> IO (RawValue 'Unknown)
forall {k} a.
WithCallStack =>
Env -> (forall (s :: k). EmacsM s a) -> IO a
runEmacsM Env
env ((forall {s :: Any}. EmacsM s (RawValue 'Unknown))
 -> IO (RawValue 'Unknown))
-> (forall {s :: Any}. EmacsM s (RawValue 'Unknown))
-> IO (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$ do
                RawValue 'Unknown
res <- EmacsM Any (Value Any) -> EmacsM s (RawValue 'Unknown)
forall a b. Coercible a b => a -> b
coerce (Int
-> Ptr (RawValue 'Regular)
-> (RawValue 'Regular -> EmacsM Any (Value Any))
-> (EmacsArgs req opt rest (Value Any) -> EmacsM Any (Value Any))
-> EmacsM Any (Value Any)
forall (req :: Nat) (opt :: Nat) (rest :: Bool) (m :: * -> *) a b.
(EmacsInvocation req opt rest, MonadBase IO m) =>
Int
-> Ptr (RawValue 'Regular)
-> (RawValue 'Regular -> m a)
-> (EmacsArgs req opt rest a -> m b)
-> m b
forall (m :: * -> *) a b.
MonadBase IO m =>
Int
-> Ptr (RawValue 'Regular)
-> (RawValue 'Regular -> 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 'Regular)
argsPtr (Value Any -> EmacsM Any (Value Any)
forall a. a -> EmacsM Any a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Any -> EmacsM Any (Value Any))
-> (RawValue 'Regular -> Value Any)
-> RawValue 'Regular
-> EmacsM Any (Value Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawValue 'Regular -> Value Any
forall k (s :: k). RawValue 'Regular -> Value s
Value) EmacsArgs req opt rest (Value Any) -> EmacsM Any (Value Any)
forall (s' :: k). EmacsFunction req opt rest EmacsM Value s'
emacsFun)
                -- Force since value may contain exceptions.
                IO (RawValue 'Unknown) -> EmacsM s (RawValue 'Unknown)
forall a. IO a -> EmacsM s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RawValue 'Unknown) -> EmacsM s (RawValue 'Unknown))
-> IO (RawValue 'Unknown) -> EmacsM s (RawValue 'Unknown)
forall a b. (a -> b) -> a -> b
$ RawValue 'Unknown -> IO (RawValue 'Unknown)
forall a. a -> IO a
evaluate RawValue 'Unknown
res

  {-# INLINE funcall #-}
  funcall
    :: (WithCallStack, Foldable f)
    => Value s
    -> f (Value s)
    -> EmacsM s (Value s)
  funcall :: forall k (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
Value s -> f (Value s) -> EmacsM s (Value s)
funcall Value s
func f (Value s)
args = ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (Value s) -> EmacsM s (Value s))
-> ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Value s) -> ReaderT Environment IO (Value s)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Value s) -> ReaderT Environment IO (Value s))
-> IO (Value s) -> ReaderT Environment IO (Value s)
forall a b. (a -> b) -> a -> b
$
          IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
    -> IO (RawValue 'Regular))
-> EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
-> IO (Value s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall a. EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult
      (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
 -> IO (Value s))
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
-> IO (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> RawValue 'Regular
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
Common.checkNonLocalExitFull (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState
      (RawValue 'Regular
 -> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)))
-> IO (RawValue 'Regular)
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BuilderCache (RawValue 'Regular)
-> Builder (RawValue 'Regular)
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (BuilderCache (RawValue 'Unknown)
-> BuilderCache (RawValue 'Regular)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) ((Value s -> Builder (RawValue 'Regular))
-> f (Value s) -> Builder (RawValue 'Regular)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RawValue 'Regular -> Builder (RawValue 'Regular)
forall a. Storable a => a -> Builder a
PtrBuilder.storable (RawValue 'Regular -> Builder (RawValue 'Regular))
-> (Value s -> RawValue 'Regular)
-> Value s
-> Builder (RawValue 'Regular)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) ((Int -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
 -> IO (RawValue 'Regular))
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
             Env
-> RawValue 'Regular
-> CPtrdiff
-> NonNullPtr (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcall Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args')


  {-# INLINE funcallPrimitive #-}
  funcallPrimitive
    :: (WithCallStack, Foldable f)
    => Value s
    -> f (Value s)
    -> EmacsM s (Value s)
  funcallPrimitive :: forall k (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
Value s -> f (Value s) -> EmacsM s (Value s)
funcallPrimitive Value s
func f (Value s)
args = ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (Value s) -> EmacsM s (Value s))
-> ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Value s) -> ReaderT Environment IO (Value s)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Value s) -> ReaderT Environment IO (Value s))
-> IO (Value s) -> ReaderT Environment IO (Value s)
forall a b. (a -> b) -> a -> b
$
          IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
    -> IO (RawValue 'Regular))
-> EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
-> IO (Value s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall a. EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult
      (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)
 -> IO (Value s))
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
-> IO (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> RawValue 'Regular
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
Common.checkNonLocalExitFull (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState
      (RawValue 'Regular
 -> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular)))
-> IO (RawValue 'Regular)
-> IO (EmacsRes EmacsSignal EmacsThrow (RawValue 'Regular))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BuilderCache (RawValue 'Regular)
-> Builder (RawValue 'Regular)
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (BuilderCache (RawValue 'Unknown)
-> BuilderCache (RawValue 'Regular)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) ((Value s -> Builder (RawValue 'Regular))
-> f (Value s) -> Builder (RawValue 'Regular)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RawValue 'Regular -> Builder (RawValue 'Regular)
forall a. Storable a => a -> Builder a
PtrBuilder.storable (RawValue 'Regular -> Builder (RawValue 'Regular))
-> (Value s -> RawValue 'Regular)
-> Value s
-> Builder (RawValue 'Regular)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) ((Int -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
 -> IO (RawValue 'Regular))
-> (Int
    -> NonNullPtr (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
            Env
-> RawValue 'Regular
-> CPtrdiff
-> NonNullPtr (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcallPrimitive Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args')

  {-# INLINE funcallPrimitiveUnchecked #-}
  funcallPrimitiveUnchecked
    :: (WithCallStack, Foldable f)
    => Value s
    -> f (Value s)
    -> EmacsM s (Value s)
  funcallPrimitiveUnchecked :: forall k (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
Value s -> f (Value s) -> EmacsM s (Value s)
funcallPrimitiveUnchecked Value s
func f (Value s)
args =
    (Env -> BuilderCache (RawValue 'Regular) -> IO (Value s))
-> EmacsM s (Value s)
forall {k} (b :: Pinning) a (s :: k).
(Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache ((Env -> BuilderCache (RawValue 'Regular) -> IO (Value s))
 -> EmacsM s (Value s))
-> (Env -> BuilderCache (RawValue 'Regular) -> IO (Value s))
-> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env BuilderCache (RawValue 'Regular)
cache ->
      BuilderCache (RawValue 'Regular)
-> Builder (RawValue 'Regular)
-> (Int -> NonNullPtr (RawValue 'Regular) -> IO (Value s))
-> IO (Value s)
forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull BuilderCache (RawValue 'Regular)
cache ((Value s -> Builder (RawValue 'Regular))
-> f (Value s) -> Builder (RawValue 'Regular)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RawValue 'Regular -> Builder (RawValue 'Regular)
forall a. Storable a => a -> Builder a
PtrBuilder.storable (RawValue 'Regular -> Builder (RawValue 'Regular))
-> (Value s -> RawValue 'Regular)
-> Value s
-> Builder (RawValue 'Regular)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) ((Int -> NonNullPtr (RawValue 'Regular) -> IO (Value s))
 -> IO (Value s))
-> (Int -> NonNullPtr (RawValue 'Regular) -> IO (Value s))
-> IO (Value s)
forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
        IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcallPrimitive @IO Env
env (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) NonNullPtr (RawValue 'Regular)
args'

  intern
    :: WithCallStack
    => SymbolName
    -> EmacsM s (Value s)
  intern :: forall k (s :: k).
WithCallStack =>
SymbolName -> EmacsM s (Value s)
intern SymbolName
sym = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Unknown) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Unknown) -> IO (Value s))
-> IO (RawValue 'Unknown) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
sym

  typeOf
    :: WithCallStack
    => Value s -> EmacsM s (Value s)
  typeOf :: forall k (s :: k). WithCallStack => Value s -> EmacsM s (Value s)
typeOf Value s
x = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Regular)
Env.typeOf @IO Env
env (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  {-# INLINE isNotNil #-}
  isNotNil :: WithCallStack => Value s -> EmacsM s Bool
  isNotNil :: forall k (s :: k). WithCallStack => Value s -> EmacsM s Bool
isNotNil Value s
x = (Env -> IO Bool) -> EmacsM s Bool
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO Bool) -> EmacsM s Bool)
-> (Env -> IO Bool) -> EmacsM s Bool
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    CBoolean -> Bool
Env.isTruthy (CBoolean -> Bool) -> IO CBoolean -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> RawValue 'Regular -> IO CBoolean
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CBoolean
Env.isNotNil Env
env (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  eq :: Value s -> Value s -> EmacsM s Bool
  eq :: forall {k} (s :: k). Value s -> Value s -> EmacsM s Bool
eq Value s
x Value s
y = (Env -> IO Bool) -> EmacsM s Bool
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO Bool) -> EmacsM s Bool)
-> (Env -> IO Bool) -> EmacsM s Bool
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    CBoolean -> Bool
Env.isTruthy (CBoolean -> Bool) -> IO CBoolean -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> RawValue 'Regular -> RawValue 'Regular -> IO CBoolean
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m CBoolean
Env.eq Env
env (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x) (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
y)

  extractWideInteger :: WithCallStack => Value s -> EmacsM s Int64
  extractWideInteger :: forall k (s :: k). WithCallStack => Value s -> EmacsM s Int64
extractWideInteger Value s
x = ReaderT Environment IO Int64 -> EmacsM s Int64
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO Int64 -> EmacsM s Int64)
-> ReaderT Environment IO Int64 -> EmacsM s Int64
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Int64 -> ReaderT Environment IO Int64
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      (IO Int64 -> ReaderT Environment IO Int64)
-> IO Int64 -> ReaderT Environment IO Int64
forall a b. (a -> b) -> a -> b
$   EmacsRes EmacsSignal Void Int64 -> IO Int64
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void Int64 -> IO Int64)
-> IO (EmacsRes EmacsSignal Void Int64) -> IO Int64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> Int64
-> IO (EmacsRes EmacsSignal Void Int64)
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"ExtractInteger" (Int64 -> IO (EmacsRes EmacsSignal Void Int64))
-> (CIntMax -> Int64)
-> CIntMax
-> IO (EmacsRes EmacsSignal Void Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIntMax -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      (CIntMax -> IO (EmacsRes EmacsSignal Void Int64))
-> IO CIntMax -> IO (EmacsRes EmacsSignal Void Int64)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> IO CIntMax
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CIntMax
Env.extractInteger Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  makeWideInteger :: WithCallStack => Int64 -> EmacsM s (Value s)
  makeWideInteger :: forall k (s :: k). WithCallStack => Int64 -> EmacsM s (Value s)
makeWideInteger Int64
x = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CIntMax -> m (RawValue 'Regular)
Env.makeInteger @IO Env
env (Int64 -> CIntMax
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x)

  extractDouble :: WithCallStack => Value s -> EmacsM s Double
  extractDouble :: forall k (s :: k). WithCallStack => Value s -> EmacsM s Double
extractDouble Value s
x = ReaderT Environment IO Double -> EmacsM s Double
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO Double -> EmacsM s Double)
-> ReaderT Environment IO Double -> EmacsM s Double
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Double -> ReaderT Environment IO Double
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      (IO Double -> ReaderT Environment IO Double)
-> IO Double -> ReaderT Environment IO Double
forall a b. (a -> b) -> a -> b
$   EmacsRes EmacsSignal Void Double -> IO Double
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void Double -> IO Double)
-> IO (EmacsRes EmacsSignal Void Double) -> IO Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> Double
-> IO (EmacsRes EmacsSignal Void Double)
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"ExtractFloat" (Double -> IO (EmacsRes EmacsSignal Void Double))
-> (CDouble -> Double)
-> CDouble
-> IO (EmacsRes EmacsSignal Void Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(CDouble Double
y) -> Double
y)
      (CDouble -> IO (EmacsRes EmacsSignal Void Double))
-> IO CDouble -> IO (EmacsRes EmacsSignal Void Double)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> IO CDouble
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CDouble
Env.extractFloat Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  makeDouble :: WithCallStack => Double -> EmacsM s (Value s)
  makeDouble :: forall k (s :: k). WithCallStack => Double -> EmacsM s (Value s)
makeDouble Double
x = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CDouble -> m (RawValue 'Regular)
Env.makeFloat @IO Env
env (Double -> CDouble
CDouble Double
x)

  extractText :: WithCallStack => Value s -> EmacsM s Text
  extractText :: forall k (s :: k). WithCallStack => Value s -> EmacsM s Text
extractText Value s
x = ReaderT Environment IO Text -> EmacsM s Text
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO Text -> EmacsM s Text)
-> ReaderT Environment IO Text -> EmacsM s Text
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Text -> ReaderT Environment IO Text
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      (IO Text -> ReaderT Environment IO Text)
-> IO Text -> ReaderT Environment IO Text
forall a b. (a -> b) -> a -> b
$   EmacsRes EmacsSignal Void Text -> IO Text
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void Text -> IO Text)
-> IO (EmacsRes EmacsSignal Void Text) -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> RawValue 'Regular
-> IO (EmacsRes EmacsSignal Void Text)
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void Text)
Common.extractText (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  extractShortByteString :: WithCallStack => Value s -> EmacsM s ShortByteString
  extractShortByteString :: forall k (s :: k).
WithCallStack =>
Value s -> EmacsM s ShortByteString
extractShortByteString Value s
x = ReaderT Environment IO ShortByteString -> EmacsM s ShortByteString
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO ShortByteString
 -> EmacsM s ShortByteString)
-> ReaderT Environment IO ShortByteString
-> EmacsM s ShortByteString
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO ShortByteString -> ReaderT Environment IO ShortByteString
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      (IO ShortByteString -> ReaderT Environment IO ShortByteString)
-> IO ShortByteString -> ReaderT Environment IO ShortByteString
forall a b. (a -> b) -> a -> b
$   EmacsRes EmacsSignal Void ShortByteString -> IO ShortByteString
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void ShortByteString -> IO ShortByteString)
-> IO (EmacsRes EmacsSignal Void ShortByteString)
-> IO ShortByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> RawValue 'Regular
-> IO (EmacsRes EmacsSignal Void ShortByteString)
forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void ShortByteString)
Common.extractShortByteString (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  makeString :: WithCallStack => BS.ByteString -> EmacsM s (Value s)
  makeString :: forall k (s :: k).
WithCallStack =>
ByteString -> EmacsM s (Value s)
makeString ByteString
x = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    ByteString -> (CStringLen -> IO (Value s)) -> IO (Value s)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
x ((CStringLen -> IO (Value s)) -> IO (Value s))
-> (CStringLen -> IO (Value s)) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ \(CString
pStr, Int
len) ->
      IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m (RawValue 'Regular)
Env.makeString @IO Env
env CString
pStr (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

  makeBinaryString :: WithCallStack => BS.ByteString -> EmacsM s (Value s)
  makeBinaryString :: forall k (s :: k).
WithCallStack =>
ByteString -> EmacsM s (Value s)
makeBinaryString ByteString
x = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    ByteString -> (CStringLen -> IO (Value s)) -> IO (Value s)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
x ((CStringLen -> IO (Value s)) -> IO (Value s))
-> (CStringLen -> IO (Value s)) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ \(CString
pStr, Int
len) ->
      IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m (RawValue 'Regular)
Env.makeUnibyteString @IO Env
env CString
pStr (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

  extractUserPtr :: WithCallStack => Value s -> EmacsM s (Ptr a)
  extractUserPtr :: forall k (s :: k) a. WithCallStack => Value s -> EmacsM s (Ptr a)
extractUserPtr Value s
x = ReaderT Environment IO (Ptr a) -> EmacsM s (Ptr a)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (Ptr a) -> EmacsM s (Ptr a))
-> ReaderT Environment IO (Ptr a) -> EmacsM s (Ptr a)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Ptr a) -> ReaderT Environment IO (Ptr a)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      (IO (Ptr a) -> ReaderT Environment IO (Ptr a))
-> IO (Ptr a) -> ReaderT Environment IO (Ptr a)
forall a b. (a -> b) -> a -> b
$   EmacsRes EmacsSignal Void (Ptr a) -> IO (Ptr a)
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void (Ptr a) -> IO (Ptr a))
-> IO (EmacsRes EmacsSignal Void (Ptr a)) -> IO (Ptr a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> Ptr a
-> IO (EmacsRes EmacsSignal Void (Ptr a))
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"GetUserPtr"
      (Ptr a -> IO (EmacsRes EmacsSignal Void (Ptr a)))
-> IO (Ptr a) -> IO (EmacsRes EmacsSignal Void (Ptr a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> IO (Ptr a)
forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> m (Ptr a)
Env.getUserPtr Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  makeUserPtr
    :: WithCallStack
    => FinalizerPtr a
    -> Ptr a
    -> EmacsM s (Value s)
  makeUserPtr :: forall k a (s :: k).
WithCallStack =>
FinalizerPtr a -> Ptr a -> EmacsM s (Value s)
makeUserPtr FinalizerPtr a
fin Ptr a
ptr = (Env -> IO (Value s)) -> EmacsM s (Value s)
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO (Value s)) -> EmacsM s (Value s))
-> (Env -> IO (Value s)) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
Env -> FinalizerPtr a -> Ptr a -> m (RawValue 'Regular)
Env.makeUserPtr @IO Env
env FinalizerPtr a
fin Ptr a
ptr

  assignUserPtr :: WithCallStack => Value s -> Ptr a -> EmacsM s ()
  assignUserPtr :: forall k (s :: k) a.
WithCallStack =>
Value s -> Ptr a -> EmacsM s ()
assignUserPtr Value s
dest Ptr a
ptr = ReaderT Environment IO () -> EmacsM s ()
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO () -> EmacsM s ())
-> ReaderT Environment IO () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    -- callWithResultMayFailSignalWaitSideEffect (SetUserPtr (getRawValue dest) ptr)
    IO () -> ReaderT Environment IO ()
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ReaderT Environment IO ())
-> IO () -> ReaderT Environment IO ()
forall a b. (a -> b) -> a -> b
$
          EmacsRes EmacsSignal Void () -> IO ()
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void () -> IO ())
-> IO (EmacsRes EmacsSignal Void ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> ()
-> IO (EmacsRes EmacsSignal Void ())
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"SetUserPtr"
      (() -> IO (EmacsRes EmacsSignal Void ()))
-> IO () -> IO (EmacsRes EmacsSignal Void ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> Ptr a -> IO ()
forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> Ptr a -> m ()
Env.setUserPtr Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
dest) Ptr a
ptr

  extractUserPtrFinaliser
    :: WithCallStack => Value s -> EmacsM s (FinalizerPtr a)
  extractUserPtrFinaliser :: forall k (s :: k) a.
WithCallStack =>
Value s -> EmacsM s (FinalizerPtr a)
extractUserPtrFinaliser Value s
x = ReaderT Environment IO (FinalizerPtr a)
-> EmacsM s (FinalizerPtr a)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (FinalizerPtr a)
 -> EmacsM s (FinalizerPtr a))
-> ReaderT Environment IO (FinalizerPtr a)
-> EmacsM s (FinalizerPtr a)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (FinalizerPtr a) -> ReaderT Environment IO (FinalizerPtr a)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (FinalizerPtr a) -> ReaderT Environment IO (FinalizerPtr a))
-> IO (FinalizerPtr a) -> ReaderT Environment IO (FinalizerPtr a)
forall a b. (a -> b) -> a -> b
$
          EmacsRes EmacsSignal Void (FinalizerPtr a) -> IO (FinalizerPtr a)
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void (FinalizerPtr a) -> IO (FinalizerPtr a))
-> IO (EmacsRes EmacsSignal Void (FinalizerPtr a))
-> IO (FinalizerPtr a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> FinalizerPtr a
-> IO (EmacsRes EmacsSignal Void (FinalizerPtr a))
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"GetUserPtrFinaliser"
      (FinalizerPtr a -> IO (EmacsRes EmacsSignal Void (FinalizerPtr a)))
-> IO (FinalizerPtr a)
-> IO (EmacsRes EmacsSignal Void (FinalizerPtr a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> IO (FinalizerPtr a)
forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> m (FinalizerPtr a)
Env.getUserFinaliser Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  assignUserPtrFinaliser
    :: WithCallStack => Value s -> FinalizerPtr a -> EmacsM s ()
  assignUserPtrFinaliser :: forall k (s :: k) a.
WithCallStack =>
Value s -> FinalizerPtr a -> EmacsM s ()
assignUserPtrFinaliser Value s
x FinalizerPtr a
fin = ReaderT Environment IO () -> EmacsM s ()
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO () -> EmacsM s ())
-> ReaderT Environment IO () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> ReaderT Environment IO ()
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ReaderT Environment IO ())
-> IO () -> ReaderT Environment IO ()
forall a b. (a -> b) -> a -> b
$
          EmacsRes EmacsSignal Void () -> IO ()
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void () -> IO ())
-> IO (EmacsRes EmacsSignal Void ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> ()
-> IO (EmacsRes EmacsSignal Void ())
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"SetUserPtrFinaliser"
      (() -> IO (EmacsRes EmacsSignal Void ()))
-> IO () -> IO (EmacsRes EmacsSignal Void ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> FinalizerPtr a -> IO ()
forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> FinalizerPtr a -> m ()
Env.setUserFinaliser Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x) FinalizerPtr a
fin

  vecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)
  vecGet :: forall k (s :: k).
WithCallStack =>
Value s -> Int -> EmacsM s (Value s)
vecGet Value s
vec Int
n = ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (Value s) -> EmacsM s (Value s))
-> ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Value s) -> ReaderT Environment IO (Value s)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Value s) -> ReaderT Environment IO (Value s))
-> IO (Value s) -> ReaderT Environment IO (Value s)
forall a b. (a -> b) -> a -> b
$
          IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> (EmacsRes EmacsSignal Void (RawValue 'Regular)
    -> IO (RawValue 'Regular))
-> EmacsRes EmacsSignal Void (RawValue 'Regular)
-> IO (Value s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsRes EmacsSignal Void (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void (RawValue 'Regular) -> IO (Value s))
-> IO (EmacsRes EmacsSignal Void (RawValue 'Regular))
-> IO (Value s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> RawValue 'Regular
-> IO (EmacsRes EmacsSignal Void (RawValue 'Regular))
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecGet"
      (RawValue 'Regular
 -> IO (EmacsRes EmacsSignal Void (RawValue 'Regular)))
-> IO (RawValue 'Regular)
-> IO (EmacsRes EmacsSignal Void (RawValue 'Regular))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> CPtrdiff -> IO (RawValue 'Regular)
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CPtrdiff -> m (RawValue 'Regular)
Env.vecGet Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

  unsafeVecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)
  unsafeVecGet :: forall k (s :: k).
WithCallStack =>
Value s -> Int -> EmacsM s (Value s)
unsafeVecGet Value s
vec Int
n = ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO (Value s) -> EmacsM s (Value s))
-> ReaderT Environment IO (Value s) -> EmacsM s (Value s)
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Value s) -> ReaderT Environment IO (Value s)
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Value s) -> ReaderT Environment IO (Value s))
-> IO (Value s) -> ReaderT Environment IO (Value s)
forall a b. (a -> b) -> a -> b
$
      IO (RawValue 'Regular) -> IO (Value s)
forall a b. Coercible a b => a -> b
coerce (IO (RawValue 'Regular) -> IO (Value s))
-> IO (RawValue 'Regular) -> IO (Value s)
forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CPtrdiff -> m (RawValue 'Regular)
Env.vecGet @IO Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

  vecSet
    :: WithCallStack
    => Value s -- ^ Vector
    -> Int     -- ^ Index
    -> Value s -- ^ New value
    -> EmacsM s ()
  vecSet :: forall k (s :: k).
WithCallStack =>
Value s -> Int -> Value s -> EmacsM s ()
vecSet Value s
vec Int
n Value s
x = ReaderT Environment IO () -> EmacsM s ()
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO () -> EmacsM s ())
-> ReaderT Environment IO () -> EmacsM s ()
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> ReaderT Environment IO ()
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> ReaderT Environment IO ())
-> IO () -> ReaderT Environment IO ()
forall a b. (a -> b) -> a -> b
$
          EmacsRes EmacsSignal Void () -> IO ()
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void () -> IO ())
-> IO (EmacsRes EmacsSignal Void ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> ()
-> IO (EmacsRes EmacsSignal Void ())
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecSet"
      (() -> IO (EmacsRes EmacsSignal Void ()))
-> IO () -> IO (EmacsRes EmacsSignal Void ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> CPtrdiff -> RawValue 'Regular -> IO ()
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> CPtrdiff -> RawValue p2 -> m ()
Env.vecSet Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x)

  vecSize :: WithCallStack => Value s -> EmacsM s Int
  vecSize :: forall k (s :: k). WithCallStack => Value s -> EmacsM s Int
vecSize Value s
vec = ReaderT Environment IO Int -> EmacsM s Int
forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (ReaderT Environment IO Int -> EmacsM s Int)
-> ReaderT Environment IO Int -> EmacsM s Int
forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Environment -> Env
eEnv :: Env
eEnv, NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache} <- ReaderT Environment IO Environment
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Int -> ReaderT Environment IO Int
forall α. IO α -> ReaderT Environment IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Int -> ReaderT Environment IO Int)
-> IO Int -> ReaderT Environment IO Int
forall a b. (a -> b) -> a -> b
$
          EmacsRes EmacsSignal Void Int -> IO Int
forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      (EmacsRes EmacsSignal Void Int -> IO Int)
-> IO (EmacsRes EmacsSignal Void Int) -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuilderCache (RawValue Any)
-> Env
-> NonLocalState
-> Text
-> Int
-> IO (EmacsRes EmacsSignal Void Int)
forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (BuilderCache (RawValue 'Unknown) -> BuilderCache (RawValue Any)
forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecSize" (Int -> IO (EmacsRes EmacsSignal Void Int))
-> (CPtrdiff -> Int)
-> CPtrdiff
-> IO (EmacsRes EmacsSignal Void Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPtrdiff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      (CPtrdiff -> IO (EmacsRes EmacsSignal Void Int))
-> IO CPtrdiff -> IO (EmacsRes EmacsSignal Void Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> RawValue 'Regular -> IO CPtrdiff
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CPtrdiff
Env.vecSize Env
eEnv (Value s -> RawValue 'Regular
forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec)

  processInput :: WithCallStack => EmacsM s ProcessInput.Result
  processInput :: forall k (s :: k). WithCallStack => EmacsM s Result
processInput =
    (Env -> IO Result) -> EmacsM s Result
forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv ((Env -> IO Result) -> EmacsM s Result)
-> (Env -> IO Result) -> EmacsM s Result
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
      Env.EnumProcessInputResult (CInt Int32
x) <- Env -> IO EnumProcessInputResult
forall (m :: * -> *). MonadIO m => Env -> m EnumProcessInputResult
Env.processInput Env
env
      case Int32 -> Maybe Result
forall a. (Eq a, Num a) => a -> Maybe Result
ProcessInput.resultFromNum Int32
x of
        Maybe Result
Nothing ->
          EmacsInternalError -> IO Result
forall e a. Exception e => e -> IO a
throwIO (EmacsInternalError -> IO Result)
-> EmacsInternalError -> IO Result
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_process_input_result" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int32 -> Doc Void
forall ann. Int32 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int32
x
        Just Result
y  -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
y