----------------------------------------------------------------------------
-- |
-- 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 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
<$ :: forall a b. a -> EmacsM s b -> EmacsM s a
$c<$ :: forall k (s :: k) a b. a -> EmacsM s b -> EmacsM s a
fmap :: forall a b. (a -> b) -> EmacsM s a -> EmacsM s b
$cfmap :: forall k (s :: k) a b. (a -> b) -> EmacsM s a -> EmacsM s b
Functor
    , 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
<* :: forall a b. EmacsM s a -> EmacsM s b -> EmacsM s a
$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 b
$c*> :: forall k (s :: k) a b. EmacsM s a -> EmacsM s b -> EmacsM s b
liftA2 :: forall a b c.
(a -> b -> c) -> EmacsM s a -> EmacsM s b -> EmacsM s c
$cliftA2 :: 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 -> b) -> EmacsM s a -> EmacsM s b
$c<*> :: forall k (s :: k) a b.
EmacsM s (a -> b) -> EmacsM s a -> EmacsM s b
pure :: forall a. a -> EmacsM s a
$cpure :: forall k (s :: k) a. a -> EmacsM s a
Applicative
    , 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
return :: forall a. a -> EmacsM s a
$creturn :: forall k (s :: k) a. a -> EmacsM s a
>> :: 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 b
>>= :: forall a b. EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
$c>>= :: forall k (s :: k) a b.
EmacsM s a -> (a -> EmacsM s b) -> EmacsM s b
Monad
    , 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
throwM :: forall e a. (HasCallStack, Exception e) => e -> EmacsM s a
$cthrowM :: forall k (s :: k) e a.
(HasCallStack, Exception e) =>
e -> EmacsM s a
Catch.MonadThrow
    , 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
catch :: forall e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
$ccatch :: forall k (s :: k) e a.
(HasCallStack, Exception e) =>
EmacsM s a -> (e -> EmacsM s a) -> EmacsM s a
Catch.MonadCatch
    , 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
generalBracket :: forall a b c.
HasCallStack =>
EmacsM s a
-> (a -> ExitCase b -> EmacsM s c)
-> (a -> EmacsM s b)
-> EmacsM s (b, c)
$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)
uninterruptibleMask :: 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
mask :: forall b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
$cmask :: forall k (s :: k) b.
HasCallStack =>
((forall a. EmacsM s a -> EmacsM s a) -> EmacsM s b) -> EmacsM s b
Catch.MonadMask
    , 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
mfix :: forall a. (a -> EmacsM s a) -> EmacsM s a
$cmfix :: forall k (s :: k) a. (a -> EmacsM s a) -> EmacsM s a
MonadFix
    , 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
primitive :: forall a.
(State# (PrimState (EmacsM s))
 -> (# State# (PrimState (EmacsM s)), a #))
-> EmacsM s a
$cprimitive :: forall k (s :: k) 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) = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadInterleave m => m a -> m a
unsafeInterleave forall a b. (a -> b) -> a -> b
$ 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM (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 (RunInBase (ReaderT Environment IO) IO
runInBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
  forall a. (NonLocalState -> IO a) -> IO a
withNonLocalState forall a b. (a -> b) -> a -> b
$ \NonLocalState
eNonLocalState ->
    forall a b. Storable a => Int -> (BuilderCache a -> IO b) -> IO b
withBuilderCache Int
8 forall a b. (a -> b) -> a -> b
$ \BuilderCache (RawValue 'Unknown)
eArgsCache ->
      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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
  Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
  Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ Env -> BuilderCache (RawValue b) -> IO a
f Env
eEnv (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  EmacsExitSignal EmacsSignal
e -> forall e a. Exception e => e -> IO a
throwIO EmacsSignal
e
  EmacsExitThrow  EmacsThrow
e -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  EmacsExitSignal EmacsSignal
e -> forall e a. Exception e => e -> IO a
throwIO EmacsSignal
e
  EmacsExitThrow  Void
e -> 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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Pinned)
Env.makeGlobalRef Env
env forall a b. (a -> b) -> a -> b
$ 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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ 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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    forall (m :: * -> *). MonadIO m => Env -> m EnumFuncallExit
Env.nonLocalExitCheck Env
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WithCallStack => 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ do
      FuncallExit (RawValue 'Regular, RawValue 'Regular)
res <- WithCallStack =>
Env
-> NonLocalState
-> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
Common.nonLocalExitGet Env
eEnv NonLocalState
eNonLocalState
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ coerce :: 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 = forall {k} (b :: Pinning) a (s :: k).
(Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache forall a b. (a -> b) -> a -> b
$ \Env
env BuilderCache (RawValue Any)
cache ->
    forall e a. Exception e => e -> IO a
Exception.throwIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (a :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> CallStack
-> RawValue 'Unknown
-> Builder (RawValue 'Regular)
-> IO EmacsSignal
Common.nonLocalExitSignal BuilderCache (RawValue Any)
cache Env
env HasCallStack => CallStack
callStack (coerce :: forall a b. Coercible a b => a -> b
coerce Value s
sym) Builder (RawValue 'Regular)
errData'
    where
      errData' :: Builder (RawValue 'Regular)
errData' =
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (coerce :: forall a b. Coercible a b => a -> b
coerce (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m ()
Env.nonLocalExitThrow Env
env RawValue 'Regular
tag' RawValue 'Regular
errData'
    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 = HasCallStack => CallStack
callStack
      }
    where
      tag' :: RawValue 'Regular
tag'     = forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
tag
      errData' :: RawValue 'Regular
errData' = forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
errData

  nonLocalExitClear :: WithCallStack => EmacsM s ()
  nonLocalExitClear :: forall k (s :: k). WithCallStack => EmacsM s ()
nonLocalExitClear = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv 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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env -> do
    RawFunction 'Unknown ()
impl' <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall (o :: Pinning) a.
RawFunctionType o a -> IO (RawFunction o a)
Env.exportToEmacs RawFunctionType 'Unknown ()
impl
    forall a. Doc -> (CString -> IO a) -> IO a
Doc.useDocAsCString Doc
doc forall a b. (a -> b) -> a -> b
$ \CString
doc' -> do
      RawValue 'Regular
func <- 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' (forall a b. FunPtr a -> Ptr b
castFunPtrToPtr (forall (o :: Pinning) a.
RawFunction o a -> FunPtr (RawFunctionType o a)
Env.unRawFunction RawFunction 'Unknown ()
impl'))
      forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> FinalizerPtr a -> m ()
Env.setFunctionFinalizer Env
env RawValue 'Regular
func forall a. FinalizerPtr a
Env.freeHaskellFunPtrWrapped
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (s :: k). RawValue 'Regular -> Value s
Value RawValue 'Regular
func
    where
      (CPtrdiff
minArity, CPtrdiff
maxArity) = 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
Proxy @req) (forall {k} (t :: k). Proxy t
Proxy @opt) (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
        forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> SomeException -> IO (RawValue 'Unknown)
reportAnyErrorToEmacs Env
env) forall a b. (a -> b) -> a -> b
$
          forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> EmacsSignal -> IO (RawValue 'Unknown)
reportEmacsSignalToEmacs Env
env) forall a b. (a -> b) -> a -> b
$
            forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle (Env -> EmacsThrow -> IO (RawValue 'Unknown)
reportEmacsThrowToEmacs Env
env) forall a b. (a -> b) -> a -> b
$
              forall {k} a.
WithCallStack =>
Env -> (forall (s :: k). EmacsM s a) -> IO a
runEmacsM Env
env forall a b. (a -> b) -> a -> b
$ do
                RawValue 'Unknown
res <- coerce :: forall a b. Coercible a b => a -> b
coerce (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
supplyEmacsArgs (forall a b. (Integral a, Num b) => a -> b
fromIntegral CPtrdiff
nargs) Ptr (RawValue 'Regular)
argsPtr (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (s :: k). RawValue 'Regular -> Value s
Value) forall (s' :: k). EmacsFunction req opt rest EmacsM Value s'
emacsFun)
                -- Force since value may contain exceptions.
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
Common.checkNonLocalExitFull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Storable a => a -> Builder a
PtrBuilder.storable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
             forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcall Env
eEnv (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EmacsRes EmacsSignal EmacsThrow a -> IO a
handleResult
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> a
-> IO (EmacsRes EmacsSignal EmacsThrow a)
Common.checkNonLocalExitFull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Storable a => a -> Builder a
PtrBuilder.storable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
            forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Env.funcallPrimitive Env
eEnv (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (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 =
    forall {k} (b :: Pinning) a (s :: k).
(Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
withEnvCache forall a b. (a -> b) -> a -> b
$ \Env
env BuilderCache (RawValue 'Regular)
cache ->
      forall a b.
(WithCallStack, Storable a) =>
BuilderCache a
-> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b
withPtrLenNonNull BuilderCache (RawValue 'Regular)
cache (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Storable a => a -> Builder a
PtrBuilder.storable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue) f (Value s)
args) forall a b. (a -> b) -> a -> b
$ \Int
n NonNullPtr (RawValue 'Regular)
args' ->
        coerce :: forall a b. Coercible a b => a -> b
coerce 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 (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
func) (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    coerce :: forall a b. Coercible a b => a -> b
coerce 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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Regular)
Env.typeOf @IO Env
env (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    CBoolean -> Bool
Env.isTruthy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CBoolean
Env.isNotNil Env
env (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    CBoolean -> Bool
Env.isTruthy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> RawValue p2 -> m CBoolean
Env.eq Env
env (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
x) (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      forall a b. (a -> b) -> a -> b
$   forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"ExtractInteger" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CIntMax
Env.extractInteger Env
eEnv (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CIntMax -> m (RawValue 'Regular)
Env.makeInteger @IO Env
env (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      forall a b. (a -> b) -> a -> b
$   forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"ExtractFloat" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(CDouble Double
y) -> Double
y)
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CDouble
Env.extractFloat Env
eEnv (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    coerce :: forall a b. Coercible a b => a -> b
coerce 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      forall a b. (a -> b) -> a -> b
$   forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void Text)
Common.extractText (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      forall a b. (a -> b) -> a -> b
$   forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (a :: Pinning) (p :: Pinning).
WithCallStack =>
BuilderCache (RawValue a)
-> Env
-> NonLocalState
-> RawValue p
-> IO (EmacsRes EmacsSignal Void ShortByteString)
Common.extractShortByteString (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
x forall a b. (a -> b) -> a -> b
$ \(CString
pStr, Int
len) ->
      coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Env -> CString -> CPtrdiff -> m (RawValue 'Regular)
Env.makeString @IO Env
env CString
pStr (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
      forall a b. (a -> b) -> a -> b
$   forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"GetUserPtr"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> m (Ptr a)
Env.getUserPtr Env
eEnv (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 = forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env ->
    coerce :: forall a b. Coercible a b => a -> b
coerce 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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    -- callWithResultMayFailSignalWaitSideEffect (SetUserPtr (getRawValue dest) ptr)
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"SetUserPtr"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> Ptr a -> m ()
Env.setUserPtr Env
eEnv (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"GetUserPtrFinaliser"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> m (FinalizerPtr a)
Env.getUserFinaliser Env
eEnv (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"SetUserPtrFinaliser"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning) a.
MonadIO m =>
Env -> RawValue p -> FinalizerPtr a -> m ()
Env.setUserFinaliser Env
eEnv (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecGet"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> CPtrdiff -> m (RawValue 'Regular)
Env.vecGet Env
eEnv (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
      coerce :: forall a b. Coercible a b => a -> b
coerce 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 (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecSet"
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env -> RawValue p1 -> CPtrdiff -> RawValue p2 -> m ()
Env.vecSet Env
eEnv (forall a. GetRawValue a => a -> RawValue 'Regular
getRawValue Value s
vec) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (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 = forall k (s :: k) a. ReaderT Environment IO a -> EmacsM s a
EmacsM forall a b. (a -> b) -> a -> b
$ do
    Environment{Env
eEnv :: Env
eEnv :: Environment -> Env
eEnv, NonLocalState
eNonLocalState :: NonLocalState
eNonLocalState :: Environment -> NonLocalState
eNonLocalState, BuilderCache (RawValue 'Unknown)
eArgsCache :: BuilderCache (RawValue 'Unknown)
eArgsCache :: Environment -> BuilderCache (RawValue 'Unknown)
eArgsCache} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$
          forall a. EmacsRes EmacsSignal Void a -> IO a
handleResultNoThrow
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: Pinning) a.
WithCallStack =>
BuilderCache (RawValue b)
-> Env
-> NonLocalState
-> Text
-> a
-> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal (forall {k1} {k2} (a :: k1) (b :: k2).
BuilderCache a -> BuilderCache b
coerceBuilderCache BuilderCache (RawValue 'Unknown)
eArgsCache) Env
eEnv NonLocalState
eNonLocalState Text
"VecSize" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m CPtrdiff
Env.vecSize Env
eEnv (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 =
    forall {k} a (s :: k). (Env -> IO a) -> EmacsM s a
withEnv forall a b. (a -> b) -> a -> b
$ \Env
env -> do
      Env.EnumProcessInputResult (CInt Int32
x) <- forall (m :: * -> *). MonadIO m => Env -> m EnumProcessInputResult
Env.processInput Env
env
      case forall a. (Eq a, Num a) => a -> Maybe Result
ProcessInput.resultFromNum Int32
x of
        Maybe Result
Nothing ->
          forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ WithCallStack => Doc Void -> EmacsInternalError
mkEmacsInternalError forall a b. (a -> b) -> a -> b
$
            Doc Void
"Unknown value of enum emacs_process_input_result" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Int32
x
        Just Result
y  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
y