diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 2018 Sergey Vinokurov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cbits/emacs-module.h b/cbits/emacs-module.h
new file mode 100644
--- /dev/null
+++ b/cbits/emacs-module.h
@@ -0,0 +1,204 @@
+/* emacs-module.h - GNU Emacs module API.
+
+Copyright (C) 2015-2017 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see . */
+
+#ifndef EMACS_MODULE_H
+#define EMACS_MODULE_H
+
+#include
+#include
+#include
+
+#if defined __cplusplus && __cplusplus >= 201103L
+# define EMACS_NOEXCEPT noexcept
+#else
+# define EMACS_NOEXCEPT
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Current environment. */
+typedef struct emacs_env_25 emacs_env;
+
+/* Opaque pointer representing an Emacs Lisp value.
+ BEWARE: Do not assume NULL is a valid value! */
+typedef struct emacs_value_tag *emacs_value;
+
+enum emacs_arity { emacs_variadic_function = -2 };
+
+/* Struct passed to a module init function (emacs_module_init). */
+struct emacs_runtime
+{
+ /* Structure size (for version checking). */
+ ptrdiff_t size;
+
+ /* Private data; users should not touch this. */
+ struct emacs_runtime_private *private_members;
+
+ /* Return an environment pointer. */
+ emacs_env *(*get_environment) (struct emacs_runtime *ert);
+};
+
+
+/* Function prototype for the module init function. */
+typedef int (*emacs_init_function) (struct emacs_runtime *ert);
+
+/* Function prototype for the module Lisp functions. */
+typedef emacs_value (*emacs_subr) (emacs_env *env, ptrdiff_t nargs,
+ emacs_value args[], void *data);
+
+/* Possible Emacs function call outcomes. */
+enum emacs_funcall_exit
+{
+ /* Function has returned normally. */
+ emacs_funcall_exit_return = 0,
+
+ /* Function has signaled an error using `signal'. */
+ emacs_funcall_exit_signal = 1,
+
+ /* Function has exit using `throw'. */
+ emacs_funcall_exit_throw = 2,
+};
+
+struct emacs_env_25
+{
+ /* Structure size (for version checking). */
+ ptrdiff_t size;
+
+ /* Private data; users should not touch this. */
+ struct emacs_env_private *private_members;
+
+ /* Memory management. */
+
+ emacs_value (*make_global_ref) (emacs_env *env,
+ emacs_value any_reference);
+
+ void (*free_global_ref) (emacs_env *env,
+ emacs_value global_reference);
+
+ /* Non-local exit handling. */
+
+ enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env);
+
+ void (*non_local_exit_clear) (emacs_env *env);
+
+ enum emacs_funcall_exit (*non_local_exit_get)
+ (emacs_env *env,
+ emacs_value *non_local_exit_symbol_out,
+ emacs_value *non_local_exit_data_out);
+
+ void (*non_local_exit_signal) (emacs_env *env,
+ emacs_value non_local_exit_symbol,
+ emacs_value non_local_exit_data);
+
+ void (*non_local_exit_throw) (emacs_env *env,
+ emacs_value tag,
+ emacs_value value);
+
+ /* Function registration. */
+
+ emacs_value (*make_function) (emacs_env *env,
+ ptrdiff_t min_arity,
+ ptrdiff_t max_arity,
+ emacs_value (*function) (emacs_env *env,
+ ptrdiff_t nargs,
+ emacs_value args[],
+ void *)
+ EMACS_NOEXCEPT,
+ const char *documentation,
+ void *data);
+
+ emacs_value (*funcall) (emacs_env *env,
+ emacs_value function,
+ ptrdiff_t nargs,
+ emacs_value args[]);
+
+ emacs_value (*intern) (emacs_env *env,
+ const char *symbol_name);
+
+ /* Type conversion. */
+
+ emacs_value (*type_of) (emacs_env *env,
+ emacs_value value);
+
+ bool (*is_not_nil) (emacs_env *env, emacs_value value);
+
+ bool (*eq) (emacs_env *env, emacs_value a, emacs_value b);
+
+ intmax_t (*extract_integer) (emacs_env *env, emacs_value value);
+
+ emacs_value (*make_integer) (emacs_env *env, intmax_t value);
+
+ double (*extract_float) (emacs_env *env, emacs_value value);
+
+ emacs_value (*make_float) (emacs_env *env, double value);
+
+ /* Copy the content of the Lisp string VALUE to BUFFER as an utf8
+ null-terminated string.
+
+ SIZE must point to the total size of the buffer. If BUFFER is
+ NULL or if SIZE is not big enough, write the required buffer size
+ to SIZE and return false.
+
+ Note that SIZE must include the last null byte (e.g. "abc" needs
+ a buffer of size 4).
+
+ Return true if the string was successfully copied. */
+
+ bool (*copy_string_contents) (emacs_env *env,
+ emacs_value value,
+ char *buffer,
+ ptrdiff_t *size_inout);
+
+ /* Create a Lisp string from a utf8 encoded string. */
+ emacs_value (*make_string) (emacs_env *env,
+ const char *contents, ptrdiff_t length);
+
+ /* Embedded pointer type. */
+ emacs_value (*make_user_ptr) (emacs_env *env,
+ void (*fin) (void *) EMACS_NOEXCEPT,
+ void *ptr);
+
+ void *(*get_user_ptr) (emacs_env *env, emacs_value uptr);
+ void (*set_user_ptr) (emacs_env *env, emacs_value uptr, void *ptr);
+
+ void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr))
+ (void *) EMACS_NOEXCEPT;
+ void (*set_user_finalizer) (emacs_env *env,
+ emacs_value uptr,
+ void (*fin) (void *) EMACS_NOEXCEPT);
+
+ /* Vector functions. */
+ emacs_value (*vec_get) (emacs_env *env, emacs_value vec, ptrdiff_t i);
+
+ void (*vec_set) (emacs_env *env, emacs_value vec, ptrdiff_t i,
+ emacs_value val);
+
+ ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vec);
+};
+
+/* Every module should define a function as follows. */
+extern int emacs_module_init (struct emacs_runtime *ert);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* EMACS_MODULE_H */
diff --git a/emacs-module.cabal b/emacs-module.cabal
new file mode 100644
--- /dev/null
+++ b/emacs-module.cabal
@@ -0,0 +1,132 @@
+name:
+ emacs-module
+version:
+ 0.1
+category: Foreign, Foreign binding
+
+synopsis:
+ Utilities to write Emacs dynamic modules
+
+description:
+ This package provides a full set of bindings to emacs-module.h that
+ allows to develop Emacs modules in Haskell.
+
+license:
+ BSD3
+license-file:
+ LICENSE
+author:
+ Sergey Vinokurov
+maintainer:
+ Sergey Vinokurov
+stability: stable
+tested-with:
+ GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3
+extra-source-files:
+ cbits/emacs-module.h
+
+cabal-version:
+ 2.0
+build-type:
+ Simple
+
+homepage: https://github.com/sergv/emacs-module
+
+source-repository head
+ type: git
+ location: https://github.com/sergv/emacs-module.git
+
+
+flag assertions
+ description:
+ Enable runtime assertions
+ default:
+ False
+ manual:
+ True
+
+flag module-assertions
+ description:
+ Bulid plugin that is plugin indentended to be used with Emacs's
+ '--module-assertions' enabled. Plugin will not free any global values
+ returned to Emacs and thus have an ever-growing memory leak.
+ default:
+ False
+ manual:
+ True
+
+library
+ if flag(assertions)
+ cpp-options: -DASSERTIONS
+ if flag(module-assertions)
+ cpp-options: -DMODULE_ASSERTIONS
+ exposed-modules:
+ Data.Emacs.Module.Args
+ Data.Emacs.Module.Env
+ Data.Emacs.Module.Env.Functions
+ Data.Emacs.Module.NonNullPtr
+ Data.Emacs.Module.Runtime
+ Data.Emacs.Module.SymbolName
+ Data.Emacs.Module.SymbolName.TH
+ Data.Emacs.Module.Value
+ Emacs.Module
+ Emacs.Module.Assert
+ Emacs.Module.Errors
+ Emacs.Module.Functions
+ Emacs.Module.Monad
+ Emacs.Module.Monad.Class
+ other-modules:
+ Data.Emacs.Module.NonNullPtr.Internal
+ Data.Emacs.Module.Raw.Env
+ Data.Emacs.Module.Raw.Env.Internal
+ Data.Emacs.Module.Raw.Env.TH
+ Data.Emacs.Module.Raw.Value
+ Data.Emacs.Module.SymbolName.Internal
+ Data.Emacs.Module.Value.Internal
+ hs-source-dirs:
+ src
+ build-depends:
+ base >=4.7 && < 5,
+ bytestring,
+ deepseq,
+ exceptions,
+ monad-control,
+ mtl,
+ prettyprinter,
+ resourcet,
+ safe-exceptions-checked,
+ text,
+ template-haskell,
+ transformers-base,
+ vector,
+ void
+ if impl(ghc < 8.1)
+ build-depends: bifunctors
+
+ includes:
+ emacs-module.h
+ install-includes:
+ emacs-module.h
+ include-dirs:
+ cbits
+ build-tools:
+ hsc2hs
+ default-language:
+ Haskell2010
+ ghc-options:
+ -Wall
+ -fwarn-name-shadowing
+ -fno-warn-type-defaults
+ if impl(ghc >= 8.0)
+ ghc-options:
+ -Wcompat
+ -Whi-shadowing
+ -Widentities
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wmissing-exported-signatures
+ if impl(ghc >= 8.2)
+ ghc-options:
+ -Wcpp-undef
+ -Wmissing-home-modules
+ -Wunbanged-strict-patterns
diff --git a/src/Data/Emacs/Module/Args.hs b/src/Data/Emacs/Module/Args.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Args.hs
@@ -0,0 +1,235 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Args
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Emacs.Module.Args
+ ( Nat(..)
+ , EmacsArgs
+ , EmacsInvocation(..)
+ , GetArities(..)
+
+ -- * Argument inference
+ , R(..)
+ , O(..)
+ , Rest(..)
+ , Stop(..)
+ ) where
+
+import Control.Monad.Base
+
+import Data.Kind
+import Data.Proxy
+import Foreign
+import Foreign.C.Types (CPtrdiff)
+
+import Data.Emacs.Module.Raw.Env (variadicFunctionArgs)
+import Data.Emacs.Module.Raw.Value
+
+data Nat = Z | S Nat
+
+class NatValue (n :: Nat) where
+ natValue :: Proxy n -> Int
+
+instance NatValue 'Z where
+ {-# INLINE natValue #-}
+ natValue _ = 0
+
+instance forall n. NatValue n => NatValue ('S n) where
+ {-# INLINE natValue #-}
+ natValue _ = 1 + natValue (Proxy @n)
+
+-- type family EmacsArgs' (req :: Nat) (m :: Type -> Type) (a :: Type) = (r :: Type) | r -> req m a where
+-- EmacsArgs' ('S n) m a = RawValue -> EmacsArgs' n m a
+-- -- EmacsArgs 'Z m a = Maybe RawValue -> EmacsArgs' 'Z k rest m a
+-- -- EmacsArgs 'Z m a = [RawValue] -> m a
+-- EmacsArgs' 'Z m a = m a
+
+-- type family EmacsArgs' (req :: Nat) (a :: Type) = (r :: Type) | r -> req
+--
+-- type instance EmacsArgs' ('S n) a = RawValue -> EmacsArgs' n a
+-- -- EmacsArgs 'Z m a = Maybe RawValue -> EmacsArgs' 'Z k rest m a
+-- -- EmacsArgs 'Z m a = [RawValue] -> m a
+-- type instance EmacsArgs' 'Z a = IO a
+
+-- | Required argument.
+data R a b = R !a !b
+
+-- | Optional argument.
+data O a b = O !(Maybe a) !b
+
+-- | All other arguments as a list.
+newtype Rest a = Rest [a]
+
+-- | No more arguments.
+data Stop a = Stop
+
+type family EmacsArgs (req :: Nat) (opt :: Nat) (rest :: Bool) (a :: Type) = (r :: Type) | r -> req opt rest a where
+ EmacsArgs ('S n) opt rest a = R a (EmacsArgs n opt rest a)
+ EmacsArgs 'Z ('S k) rest a = O a (EmacsArgs 'Z k rest a)
+ EmacsArgs 'Z 'Z 'True a = Rest a
+ EmacsArgs 'Z 'Z 'False a = Stop a
+
+-- type family EmacsArgs (req :: Nat) (opt :: Nat) (rest :: Bool) (s :: Type) (a :: Type) = (r :: Type) | r -> req opt rest where
+-- EmacsArgs ('S n) opt rest s a = Value s -> EmacsArgs n opt rest s a
+-- EmacsArgs 'Z ('S k) rest s a = Maybe (Value s) -> EmacsArgs 'Z k rest s a
+-- EmacsArgs 'Z 'Z 'True s a = [Value s] -> IO a
+-- EmacsArgs 'Z 'Z 'False s a = IO a
+
+class EmacsInvocation req opt rest where
+ supplyEmacsArgs
+ :: MonadBase IO m
+ => Int
+ -> Ptr RawValue
+ -> (RawValue -> m a)
+ -> (EmacsArgs req opt rest a -> m b)
+ -> m b
+
+instance EmacsInvocation 'Z 'Z 'False where
+ {-# INLINE supplyEmacsArgs #-}
+ supplyEmacsArgs _nargs _startPtr _mkInput f = f Stop
+
+instance EmacsInvocation 'Z 'Z 'True where
+ {-# INLINE supplyEmacsArgs #-}
+ supplyEmacsArgs
+ :: MonadBase IO m
+ => Int
+ -> Ptr RawValue
+ -> (RawValue -> m a)
+ -> (Rest a -> m b)
+ -> m b
+ supplyEmacsArgs nargs startPtr mkArg f =
+ case nargs of
+ 0 -> f (Rest [])
+ n -> f . Rest =<< traverse mkArg =<< liftBase (peekArray n startPtr)
+
+{-# INLINE advanceEmacsValuePtr #-}
+advanceEmacsValuePtr :: Ptr RawValue -> Ptr RawValue
+advanceEmacsValuePtr =
+ (`plusPtr` (sizeOf (undefined :: RawValue)))
+
+instance EmacsInvocation 'Z n rest => EmacsInvocation 'Z ('S n) rest where
+ {-# INLINE supplyEmacsArgs #-}
+ supplyEmacsArgs
+ :: forall m a b. MonadBase IO m
+ => Int
+ -> Ptr RawValue
+ -> (RawValue -> m a)
+ -> (O a (EmacsArgs 'Z n rest a) -> m b)
+ -> m b
+ supplyEmacsArgs nargs startPtr mkArg f =
+ case nargs of
+ 0 -> supplyEmacsArgs nargs startPtr mkArg (f . O Nothing)
+ _ -> do
+ arg <- mkArg =<< liftBase (peek startPtr)
+ supplyEmacsArgs
+ (nargs - 1)
+ (advanceEmacsValuePtr startPtr)
+ mkArg
+ (f . O (Just arg))
+
+instance EmacsInvocation n opt rest => EmacsInvocation ('S n) opt rest where
+ {-# INLINE supplyEmacsArgs #-}
+ supplyEmacsArgs
+ :: MonadBase IO m
+ => Int
+ -> Ptr RawValue
+ -> (RawValue -> m a)
+ -> (R a (EmacsArgs n opt rest a) -> m b)
+ -> m b
+ supplyEmacsArgs nargs startPtr mkArg f = do
+ arg <- mkArg =<< liftBase (peek startPtr)
+ supplyEmacsArgs (nargs - 1) (advanceEmacsValuePtr startPtr) mkArg (f . R arg)
+
+
+class GetArities (req :: Nat) (opt :: Nat) (rest :: Bool) where
+ arities :: Proxy req -> Proxy opt -> Proxy rest -> (CPtrdiff, CPtrdiff)
+
+instance (NatValue req, NatValue opt) => GetArities req opt 'False where
+ {-# INLINE arities #-}
+ arities preq popt _ = (req, req + opt)
+ where
+ req = fromIntegral (natValue preq)
+ opt = fromIntegral (natValue popt)
+
+instance NatValue req => GetArities req opt 'True where
+ {-# INLINE arities #-}
+ arities preq _ _ =
+ (fromIntegral (natValue preq), variadicFunctionArgs)
+
+
+-- data Args (req :: Nat) (opt :: Nat) (rest :: Bool) (a :: Type) where
+-- NoArgs :: Args 'Z 'Z 'False a
+-- ReqArg :: a -> Args req opt rest a -> Args ('S req) opt rest a
+-- OptArg :: Maybe a -> Args req opt rest a -> Args req ('S opt) rest a
+-- RestArgs :: [a] -> Args 'Z 'Z 'True a
+--
+-- deriving instance Functor (Args req opt rest)
+-- deriving instance Foldable (Args req opt rest)
+-- deriving instance Traversable (Args req opt rest)
+
+-- class GetArgs (req :: Nat) (opt :: Nat) (rest :: Bool) where
+-- getArgs :: Storable a => Int -> Ptr a -> IO (Args req opt rest a)
+--
+-- instance GetArgs 'Z 'Z 'False where
+-- {-# INLINE getArgs #-}
+-- getArgs !_nargs _startPtr = pure NoArgs
+--
+-- instance GetArgs 'Z 'Z 'True where
+-- {-# INLINE getArgs #-}
+-- getArgs !nargs startPtr =
+-- case nargs of
+-- 0 -> pure $ RestArgs []
+-- n -> RestArgs <$> peekArray n startPtr
+--
+-- instance (GetArgs req n rest, DefaultArgs req n rest) => GetArgs req ('S n) rest where
+-- {-# INLINE getArgs #-}
+-- getArgs :: forall a. Storable a => Int -> Ptr a -> IO (Args req ('S n) rest a)
+-- getArgs !nargs startPtr = do
+-- case nargs of
+-- 0 -> pure $ OptArg Nothing defaultArgs
+-- _ -> OptArg <$> (Just <$> peek startPtr) <*> getArgs (nargs - 1) (plusPtr startPtr (sizeOf (undefined :: a)))
+--
+-- instance GetArgs n opt rest => GetArgs ('S n) opt rest where
+-- {-# INLINE getArgs #-}
+-- getArgs :: forall a. Storable a => Int -> Ptr a -> IO (Args ('S n) opt rest a)
+-- getArgs !nargs startPtr = do
+-- ReqArg <$> peek startPtr <*> getArgs (nargs - 1) (plusPtr startPtr (sizeOf (undefined :: a)))
+--
+--
+-- class DefaultArgs (req :: Nat) (opt :: Nat) (rest :: Bool) where
+-- defaultArgs :: Args req opt rest a
+--
+-- instance DefaultArgs 'Z 'Z 'False where
+-- {-# INLINE defaultArgs #-}
+-- defaultArgs = NoArgs
+--
+-- instance DefaultArgs 'Z 'Z 'True where
+-- {-# INLINE defaultArgs #-}
+-- defaultArgs = RestArgs []
+--
+-- instance DefaultArgs req n rest => DefaultArgs req ('S n) rest where
+-- {-# INLINE defaultArgs #-}
+-- defaultArgs = OptArg Nothing defaultArgs
diff --git a/src/Data/Emacs/Module/Env.hs b/src/Data/Emacs/Module/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Env.hs
@@ -0,0 +1,73 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Env
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Data.Emacs.Module.Env
+ ( Env
+
+ , -- * enum emacs_funcall_exit
+ FuncallExit(..)
+ , funcallExitToNum
+ , funcallExitFromNum
+
+ , -- * Wrappers around struct emacs_env fields
+ EnumFuncallExit(..)
+ , UserPtrFinaliserType
+ , UserPtrFinaliser
+ , isValidEnv
+
+ , makeGlobalRef
+ , freeGlobalRef
+
+ , nonLocalExitCheck
+ , nonLocalExitGet
+ , nonLocalExitSignal
+ , nonLocalExitThrow
+ , nonLocalExitClear
+
+ , variadicFunctionArgs
+ , makeFunction
+
+ , funcall
+ , funcallPrimitive
+ , intern
+ , typeOf
+ , isNotNil
+ , eq
+ , extractInteger
+ , makeInteger
+ , extractFloat
+ , makeFloat
+ , copyStringContents
+ , makeString
+ , makeUserPtr
+ , getUserPtr
+ , setUserPtr
+ , getUserFinaliser
+ , setUserFinaliser
+ , vecGet
+ , vecSet
+ , vecSize
+
+ , -- * Expose functions to Emacs
+ exportToEmacs
+ , RawFunctionType
+ , RawFunction
+
+ -- * Expose Haskell data to Emacs
+ , freeStablePtrFinaliser
+ ) where
+
+import Data.Emacs.Module.Env.Functions
+import Data.Emacs.Module.Raw.Env.Internal
+import Data.Emacs.Module.Raw.Env
+
+-- | Pass to 'makeUserPtr' so that Emacs will free the Haskell's stable
+-- pointer when the corresponding elisp value goes out of scope.
+foreign import ccall "& hs_free_stable_ptr" freeStablePtrFinaliser :: UserPtrFinaliser a
diff --git a/src/Data/Emacs/Module/Env/Functions.hsc b/src/Data/Emacs/Module/Env/Functions.hsc
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Env/Functions.hsc
@@ -0,0 +1,54 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Env.Functions
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Emacs.Module.Env.Functions
+ ( FuncallExit(..)
+ , funcallExitToNum
+ , funcallExitFromNum
+ ) where
+
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import Language.Haskell.TH.Syntax (Lift)
+
+#include
+
+-- | Possible Emacs function call outcomes. This is Haskell's version of
+data FuncallExit a =
+ -- | Function has returned normally.
+ FuncallExitReturn
+ | -- | Function has signaled an error using @signal@.
+ FuncallExitSignal a
+ | -- | Function has exit using @throw@.
+ FuncallExitThrow a
+ deriving (Eq, Ord, Show, Data, Generic, Lift, Typeable, Functor, Foldable, Traversable)
+
+funcallExitToNum :: Num a => FuncallExit b -> a
+funcallExitToNum = \case
+ FuncallExitReturn -> (#const emacs_funcall_exit_return)
+ FuncallExitSignal{} -> (#const emacs_funcall_exit_signal)
+ FuncallExitThrow{} -> (#const emacs_funcall_exit_throw)
+
+funcallExitFromNum :: (Eq a, Num a) => a -> Maybe (FuncallExit ())
+funcallExitFromNum = \case
+ (#const emacs_funcall_exit_return) -> Just FuncallExitReturn
+ (#const emacs_funcall_exit_signal) -> Just $ FuncallExitSignal ()
+ (#const emacs_funcall_exit_throw) -> Just $ FuncallExitThrow ()
+ _ -> Nothing
+
diff --git a/src/Data/Emacs/Module/NonNullPtr.hs b/src/Data/Emacs/Module/NonNullPtr.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/NonNullPtr.hs
@@ -0,0 +1,39 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.NonNullPtr
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+module Data.Emacs.Module.NonNullPtr
+ ( NonNullPtr
+ , unNonNullPtr
+ , mkNonNullPtr
+ , allocaNonNull
+ , allocaBytesNonNull
+ ) where
+
+import Foreign
+
+import Data.Emacs.Module.NonNullPtr.Internal
+import Emacs.Module.Assert
+
+mkNonNullPtr :: WithCallStack => Ptr a -> NonNullPtr a
+#ifdef ASSERTIONS
+mkNonNullPtr x
+ | x == nullPtr = error "Assertion failed: trying to make non-null pointer from a null one"
+ | otherwise = NonNullPtr x
+#else
+mkNonNullPtr = NonNullPtr
+#endif
+
+{-# INLINE allocaNonNull #-}
+allocaNonNull :: Storable a => (NonNullPtr a -> IO b) -> IO b
+allocaNonNull f = alloca (f . NonNullPtr)
+
+{-# INLINE allocaBytesNonNull #-}
+allocaBytesNonNull :: Storable a => Int -> (NonNullPtr a -> IO b) -> IO b
+allocaBytesNonNull n f = allocaBytes n (f . NonNullPtr)
diff --git a/src/Data/Emacs/Module/NonNullPtr/Internal.hs b/src/Data/Emacs/Module/NonNullPtr/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/NonNullPtr/Internal.hs
@@ -0,0 +1,17 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.NonNullPtr.Internal
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Emacs.Module.NonNullPtr.Internal (NonNullPtr(..)) where
+
+import Foreign
+
+newtype NonNullPtr a = NonNullPtr { unNonNullPtr :: Ptr a }
+ deriving (Eq, Ord, Show, Storable)
+
diff --git a/src/Data/Emacs/Module/Raw/Env.hsc b/src/Data/Emacs/Module/Raw/Env.hsc
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Raw/Env.hsc
@@ -0,0 +1,518 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Raw.Env
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+--
+-- Low-level and, hopefully, low-overhead wrappers around @struct emacs_env@.
+----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Data.Emacs.Module.Raw.Env
+ ( EnumFuncallExit(..)
+ , UserPtrFinaliserType
+ , UserPtrFinaliser
+ , CBoolean
+ , isTruthy
+ , isValidEnv
+
+ , makeGlobalRef
+ , freeGlobalRef
+
+ , nonLocalExitCheck
+ , nonLocalExitGet
+ , nonLocalExitSignal
+ , nonLocalExitThrow
+ , nonLocalExitClear
+
+ , variadicFunctionArgs
+ , makeFunction
+
+ , funcall
+ , funcallPrimitive
+ , intern
+ , typeOf
+ , isNotNil
+ , eq
+
+ , extractInteger
+ , makeInteger
+ , extractFloat
+ , makeFloat
+ , copyStringContents
+ , makeString
+ , makeUserPtr
+ , getUserPtr
+ , setUserPtr
+ , getUserFinaliser
+ , setUserFinaliser
+ , vecGet
+ , vecSet
+ , vecSize
+ ) where
+
+import Control.Monad.IO.Class
+
+import Data.Coerce
+import Foreign
+import Foreign.C
+
+import Data.Emacs.Module.NonNullPtr
+import Data.Emacs.Module.Raw.Env.Internal as Env
+import Data.Emacs.Module.Raw.Env.TH
+import Data.Emacs.Module.Raw.Value
+
+import Data.Emacs.Module.NonNullPtr.Internal
+
+#include
+
+newtype EnumFuncallExit = EnumFuncallExit { unEnumFuncallExit :: CInt }
+
+type UserPtrFinaliserType a = Ptr a -> IO ()
+type UserPtrFinaliser a = FunPtr (UserPtrFinaliserType a)
+
+-- | A wrapper around C value that denotes true or false.
+newtype CBoolean = CBoolean (#type bool)
+
+{-# INLINE isTruthy #-}
+-- | Check whether a 'CBoolean' denotes true.
+isTruthy :: CBoolean -> Bool
+isTruthy (CBoolean a) = a /= 0
+
+
+{-# INLINE isValidEnv #-}
+-- | Check wheter passed @emacs_env@ structure has expected size so that
+-- we will be able to access all of its fields.
+isValidEnv :: MonadIO m => Env -> m Bool
+isValidEnv env = liftIO $ do
+ realSize <- (#peek emacs_env, size) (Env.toPtr env)
+ pure $ expectedSize <= realSize
+ where
+ expectedSize :: CPtrdiff
+ expectedSize = (#size emacs_env)
+
+$(wrapEmacsFunc "makeGlobalRefTH" Unsafe
+ [e| (#peek emacs_env, make_global_ref) |]
+ [t| Env -> RawValue -> IO RawValue |])
+
+{-# INLINE makeGlobalRef #-}
+makeGlobalRef
+ :: forall m. MonadIO m
+ => Env
+ -> RawValue
+ -> m GlobalRef
+makeGlobalRef env x =
+ liftIO $
+ coerce
+ (makeGlobalRefTH
+ :: Env
+ -> RawValue
+ -> IO RawValue)
+ env
+ x
+
+
+$(wrapEmacsFunc "freeGlobalRefTH" Unsafe
+ [e| (#peek emacs_env, free_global_ref) |]
+ [t| Env -> RawValue -> IO () |])
+
+{-# INLINE freeGlobalRef #-}
+freeGlobalRef
+ :: forall m. MonadIO m
+ => Env
+ -> GlobalRef
+ -> m ()
+freeGlobalRef env x =
+ liftIO $
+ coerce
+ (freeGlobalRefTH :: Env -> RawValue -> IO ())
+ env
+ x
+
+
+$(wrapEmacsFunc "nonLocalExitCheckTH" Unsafe
+ [e| (#peek emacs_env, non_local_exit_check) |]
+ [t| Env -> IO EnumFuncallExit |])
+
+{-# INLINE nonLocalExitCheck #-}
+nonLocalExitCheck
+ :: MonadIO m
+ => Env
+ -> m EnumFuncallExit
+nonLocalExitCheck = nonLocalExitCheckTH
+
+
+$(wrapEmacsFunc "nonLocalExitGetTH" Unsafe
+ [e| (#peek emacs_env, non_local_exit_get) |]
+ [t| Env -> NonNullPtr RawValue -> NonNullPtr RawValue -> IO EnumFuncallExit |])
+
+{-# INLINE nonLocalExitGet #-}
+nonLocalExitGet
+ :: MonadIO m
+ => Env
+ -> NonNullPtr RawValue -- ^ Symbol output
+ -> NonNullPtr RawValue -- ^ Data output
+ -> m EnumFuncallExit
+nonLocalExitGet = nonLocalExitGetTH
+
+
+$(wrapEmacsFunc "nonLocalExitSignalTH" Unsafe
+ [e| (#peek emacs_env, non_local_exit_signal) |]
+ [t| Env -> RawValue -> RawValue -> IO () |])
+
+{-# INLINE nonLocalExitSignal #-}
+nonLocalExitSignal
+ :: MonadIO m
+ => Env
+ -> RawValue -- ^ Error symbol
+ -> RawValue -- ^ Error data
+ -> m ()
+nonLocalExitSignal = nonLocalExitSignalTH
+
+
+$(wrapEmacsFunc "nonLocalExitThrowTH" Unsafe
+ [e| (#peek emacs_env, non_local_exit_throw) |]
+ [t| Env -> RawValue -> RawValue -> IO () |])
+
+{-# INLINE nonLocalExitThrow #-}
+nonLocalExitThrow
+ :: MonadIO m
+ => Env
+ -> RawValue -- ^ Tag, a symbol
+ -> RawValue -- ^ Value
+ -> m ()
+nonLocalExitThrow = nonLocalExitThrowTH
+
+
+$(wrapEmacsFunc "nonLocalExitClearTH" Unsafe
+ [e| (#peek emacs_env, non_local_exit_clear) |]
+ [t| Env -> IO () |])
+
+{-# INLINE nonLocalExitClear #-}
+nonLocalExitClear
+ :: MonadIO m
+ => Env
+ -> m ()
+nonLocalExitClear = nonLocalExitClearTH
+
+
+variadicFunctionArgs :: CPtrdiff
+variadicFunctionArgs = (#const emacs_variadic_function)
+
+$(wrapEmacsFunc "makeFunctionTH" Unsafe
+ [e| (#peek emacs_env, make_function) |]
+ [t| forall a. Env -> CPtrdiff -> CPtrdiff -> FunPtr (RawFunctionType a) -> CString -> Ptr a -> IO RawValue |])
+
+{-# INLINE makeFunction #-}
+makeFunction
+ :: forall m a. MonadIO m
+ => Env
+ -> CPtrdiff -- ^ Minimum arity
+ -> CPtrdiff -- ^ Maximum arity
+ -> RawFunction a -- ^ Implementation
+ -> CString -- ^ Documentation
+ -> Ptr a -- ^ Extra data
+ -> m RawValue
+makeFunction =
+ coerce
+ (makeFunctionTH ::
+ Env
+ -> CPtrdiff
+ -> CPtrdiff
+ -> FunPtr (RawFunctionType a)
+ -> CString
+ -> Ptr a
+ -> m RawValue)
+
+
+$(wrapEmacsFunc "funcallTH" Safe
+ [e| (#peek emacs_env, funcall) |]
+ [t| Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue |])
+
+{-# INLINE funcall #-}
+funcall
+ :: MonadIO m
+ => Env
+ -> RawValue -- ^ Function
+ -> CPtrdiff -- ^ Number of arguments
+ -> NonNullPtr RawValue -- ^ Actual arguments
+ -> m RawValue
+funcall = funcallTH
+
+
+$(wrapEmacsFunc "funcallPrimitiveTH" Unsafe
+ [e| (#peek emacs_env, funcall) |]
+ [t| Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue |])
+
+{-# INLINE funcallPrimitive #-}
+funcallPrimitive
+ :: MonadIO m
+ => Env
+ -> RawValue -- ^ Function
+ -> CPtrdiff -- ^ Number of arguments
+ -> NonNullPtr RawValue -- ^ Actual arguments
+ -> m RawValue
+funcallPrimitive = funcallPrimitiveTH
+
+
+$(wrapEmacsFunc "internTH" Unsafe
+ [e| (#peek emacs_env, intern) |]
+ [t| Env -> CString -> IO RawValue |])
+
+{-# INLINE intern #-}
+intern
+ :: MonadIO m
+ => Env
+ -> CString
+ -> m RawValue
+intern = internTH
+
+
+$(wrapEmacsFunc "typeOfTH" Unsafe
+ [e| (#peek emacs_env, type_of) |]
+ [t| Env -> RawValue -> IO RawValue |])
+
+{-# INLINE typeOf #-}
+typeOf
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m RawValue
+typeOf = typeOfTH
+
+
+$(wrapEmacsFunc "isNotNilTH" Unsafe
+ [e| (#peek emacs_env, is_not_nil) |]
+ [t| Env -> RawValue -> IO CBoolean |])
+
+{-# INLINE isNotNil #-}
+isNotNil
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m CBoolean
+isNotNil = isNotNilTH
+
+
+$(wrapEmacsFunc "eqTH" Unsafe
+ [e| (#peek emacs_env, eq) |]
+ [t| Env -> RawValue -> RawValue -> IO CBoolean |])
+
+{-# INLINE eq #-}
+eq
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> RawValue
+ -> m CBoolean
+eq = eqTH
+
+
+$(wrapEmacsFunc "extractIntegerTH" Unsafe
+ [e| (#peek emacs_env, extract_integer) |]
+ [t| Env -> RawValue -> IO CIntMax |])
+
+{-# INLINE extractInteger #-}
+extractInteger
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m CIntMax
+extractInteger = extractIntegerTH
+
+
+$(wrapEmacsFunc "makeIntegerTH" Unsafe
+ [e| (#peek emacs_env, make_integer) |]
+ [t| Env -> CIntMax -> IO RawValue |])
+
+{-# INLINE makeInteger #-}
+makeInteger
+ :: MonadIO m
+ => Env
+ -> CIntMax
+ -> m RawValue
+makeInteger = makeIntegerTH
+
+
+$(wrapEmacsFunc "extractFloatTH" Unsafe
+ [e| (#peek emacs_env, extract_float) |]
+ [t| Env -> RawValue -> IO CDouble |])
+
+{-# INLINE extractFloat #-}
+extractFloat
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m CDouble
+extractFloat = extractFloatTH
+
+
+$(wrapEmacsFunc "makeFloatTH" Unsafe
+ [e| (#peek emacs_env, make_float) |]
+ [t| Env -> CDouble -> IO RawValue |])
+
+{-# INLINE makeFloat #-}
+makeFloat
+ :: MonadIO m
+ => Env
+ -> CDouble
+ -> m RawValue
+makeFloat = makeFloatTH
+
+
+$(wrapEmacsFunc "copyStringContentsTH" Unsafe
+ [e| (#peek emacs_env, copy_string_contents) |]
+ [t| Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> IO CBoolean |])
+
+{-# INLINE copyStringContents #-}
+-- | Copy the content of the Lisp string VALUE to BUFFER as an utf8
+-- null-terminated string.
+--
+-- SIZE must point to the total size of the buffer. If BUFFER is
+-- NULL or if SIZE is not big enough, write the required buffer size
+-- to SIZE and return true.
+--
+-- Note that SIZE must include the last null byte (e.g. "abc" needs
+-- a buffer of size 4).
+--
+-- Return true if the string was successfully copied.
+copyStringContents
+ :: MonadIO m
+ => Env
+ -> RawValue -- ^ Emacs value that holds a string
+ -> CString -- ^ Destination, may be NULL
+ -> NonNullPtr CPtrdiff -- ^ SIZE pointer
+ -> m CBoolean
+copyStringContents = copyStringContentsTH
+
+
+$(wrapEmacsFunc "makeStringTH" Unsafe
+ [e| (#peek emacs_env, make_string) |]
+ [t| Env -> CString -> CPtrdiff -> IO RawValue |])
+
+{-# INLINE makeString #-}
+makeString
+ :: MonadIO m
+ => Env
+ -> CString -- ^ 0-terminated utf8-encoded string.
+ -> CPtrdiff -- ^ Length.
+ -> m RawValue
+makeString = makeStringTH
+
+
+$(wrapEmacsFunc "makeUserPtrTH" Unsafe
+ [e| (#peek emacs_env, make_user_ptr) |]
+ [t| forall a. Env -> UserPtrFinaliser a -> Ptr a -> IO RawValue |])
+
+{-# INLINE makeUserPtr #-}
+makeUserPtr
+ :: forall m a. MonadIO m
+ => Env
+ -> UserPtrFinaliser a
+ -> Ptr a
+ -> m RawValue
+makeUserPtr = makeUserPtrTH
+
+
+$(wrapEmacsFunc "getUserPtrTH" Unsafe
+ [e| (#peek emacs_env, get_user_ptr) |]
+ [t| forall a. Env -> RawValue -> IO (Ptr a) |])
+
+{-# INLINE getUserPtr #-}
+getUserPtr
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m (Ptr a)
+getUserPtr = getUserPtrTH
+
+
+$(wrapEmacsFunc "setUserPtrTH" Unsafe
+ [e| (#peek emacs_env, set_user_ptr) |]
+ [t| forall a. Env -> RawValue -> Ptr a -> IO () |])
+
+{-# INLINE setUserPtr #-}
+setUserPtr
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> Ptr a
+ -> m ()
+setUserPtr = setUserPtrTH
+
+
+$(wrapEmacsFunc "getUserFinaliserTH" Unsafe
+ [e| (#peek emacs_env, get_user_finalizer) |]
+ [t| forall a. Env -> RawValue -> IO (UserPtrFinaliser a) |])
+
+{-# INLINE getUserFinaliser #-}
+getUserFinaliser
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m (UserPtrFinaliser a)
+getUserFinaliser = getUserFinaliserTH
+
+
+$(wrapEmacsFunc "setUserFinaliserTH" Unsafe
+ [e| (#peek emacs_env, set_user_finalizer) |]
+ [t| forall a. Env -> RawValue -> UserPtrFinaliser a -> IO () |])
+
+{-# INLINE setUserFinaliser #-}
+setUserFinaliser
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> UserPtrFinaliser a
+ -> m ()
+setUserFinaliser = setUserFinaliserTH
+
+
+$(wrapEmacsFunc "vecGetTH" Unsafe
+ [e| (#peek emacs_env, vec_get) |]
+ [t| Env -> RawValue -> CPtrdiff -> IO RawValue |])
+
+{-# INLINE vecGet #-}
+vecGet
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> CPtrdiff
+ -> m RawValue
+vecGet = vecGetTH
+
+
+$(wrapEmacsFunc "vecSetTH" Unsafe
+ [e| (#peek emacs_env, vec_set) |]
+ [t| Env -> RawValue -> CPtrdiff -> RawValue -> IO () |])
+
+{-# INLINE vecSet #-}
+vecSet
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> CPtrdiff
+ -> RawValue
+ -> m ()
+vecSet = vecSetTH
+
+
+$(wrapEmacsFunc "vecSizeTH" Unsafe
+ [e| (#peek emacs_env, vec_size) |]
+ [t| Env -> RawValue -> IO CPtrdiff |])
+
+{-# INLINE vecSize #-}
+vecSize
+ :: MonadIO m
+ => Env
+ -> RawValue
+ -> m CPtrdiff
+vecSize = vecSizeTH
+
diff --git a/src/Data/Emacs/Module/Raw/Env/Internal.hs b/src/Data/Emacs/Module/Raw/Env/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Raw/Env/Internal.hs
@@ -0,0 +1,51 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Env.Internal
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Data.Emacs.Module.Raw.Env.Internal
+ ( Env(..)
+ , toPtr
+ , exportToEmacs
+ , RawFunctionType
+ , RawFunction(..)
+ ) where
+
+import Foreign
+import Foreign.C.Types
+
+import Data.Emacs.Module.NonNullPtr
+import Data.Emacs.Module.Raw.Value
+
+import Data.Emacs.Module.NonNullPtr.Internal
+
+-- | Emacs environment, right from the 'emacs-module.h'.
+newtype Env = Env { unEnv :: NonNullPtr Env }
+
+{-# INLINE toPtr #-}
+toPtr :: Env -> Ptr Env
+toPtr = unNonNullPtr . unEnv
+
+
+type RawFunctionType a =
+ Env
+ -> CPtrdiff -- Number of arguments
+ -> Ptr RawValue -- Actual arguments
+ -> Ptr a -- Extra data
+ -> IO RawValue
+
+-- NB This is *the* coolest point of this library: *any* Haskell
+-- function (incl closures) may be exposed to C to be called later.
+-- The C/C++ will never have this...
+foreign import ccall "wrapper"
+ exportToEmacs :: RawFunctionType a -> IO (RawFunction a)
+
+newtype RawFunction a = RawFunction { unRawFunction :: FunPtr (RawFunctionType a) }
diff --git a/src/Data/Emacs/Module/Raw/Env/TH.hs b/src/Data/Emacs/Module/Raw/Env/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Raw/Env/TH.hs
@@ -0,0 +1,79 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Raw.Env.TH
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where
+
+import Control.Monad.IO.Class
+import Data.List (foldl')
+import Foreign.Ptr as Foreign
+import Language.Haskell.TH
+
+import Data.Emacs.Module.Raw.Env.Internal as Env
+
+decomposeFunctionType :: Type -> ([Type], Type)
+decomposeFunctionType = go []
+ where
+ go :: [Type] -> Type -> ([Type], Type)
+ go args = \case
+ ForallT _ _ t -> go args t
+ AppT (AppT ArrowT x) y -> go (x : args) y
+ ret -> (reverse args, ret)
+
+unwrapForall :: Type -> (Maybe ([TyVarBndr], Cxt), Type)
+unwrapForall (ForallT bs c t) = (Just (bs, c), t)
+unwrapForall t = (Nothing, t)
+
+wrapForall :: Maybe ([TyVarBndr], Cxt) -> Type -> Type
+wrapForall Nothing = id
+wrapForall (Just (bs, c)) = ForallT bs c
+
+-- AppT (AppT ArrowT x) ret -> go [] ret x
+-- invalid -> fail $ "Invalid function type: " ++ show invalid
+-- where
+-- go :: [Type] -> Type -> Type -> Q ([Type], Type)
+-- go args ret = \case
+-- AppT ArrowT firstArg -> pure (firstArg : args, ret)
+-- AppT x y -> go (y : args) ret x
+-- invalid -> fail $ "Invalid function type: " ++ show invalid
+
+wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
+wrapEmacsFunc name safety peekExpr rawFuncType = do
+ rawFuncType' <- rawFuncType
+ let (forallCxt, rawFuncType'') = unwrapForall rawFuncType'
+ (args, _ret) = decomposeFunctionType rawFuncType''
+ (envArg, otherArgs) <- case args of
+ [] -> fail $
+ "Raw function type must take at least one emacs_env argument: " ++ show rawFuncType'
+ x : xs
+ | x /= ConT ''Env.Env -> fail $
+ "Raw function type must take emacs_env as a first argument, but takes " ++ show x ++ " in " ++ show rawFuncType'
+ | otherwise ->
+ (,) <$> newName "env" <*> traverse (const (newName "x")) xs
+ foreignFuncName <- newName $ "emacs_func_" ++ name
+ -- fail $ "otherArgs = " ++ show otherArgs ++ ", rawFuncType = " ++ show rawFuncType'
+ let envPat = varP envArg
+ pats = envPat : map varP otherArgs
+ body = normalB $ do
+ funPtrVar <- newName "funPtr"
+ [e|liftIO|] `appE` doE
+ [ bindS (varP funPtrVar) $ peekExpr `appE` ([e| Env.toPtr |] `appE` varE envArg)
+ , noBindS $ foldl' appE (varE foreignFuncName) (map varE $ funPtrVar : envArg : otherArgs)
+ ]
+ mainDecl <- funD name' [clause pats body []]
+ inlinePragma <- pragInlD name' Inline FunLike AllPhases
+ let foreignDeclType =
+ fmap (wrapForall forallCxt) $
+ arrowT `appT` (conT ''Foreign.FunPtr `appT` pure rawFuncType'') `appT` pure rawFuncType''
+ foreignDecl <- forImpD cCall safety "dynamic" foreignFuncName foreignDeclType
+ pure [mainDecl, inlinePragma, foreignDecl]
+ where
+ name' = mkName name
+
diff --git a/src/Data/Emacs/Module/Raw/Value.hs b/src/Data/Emacs/Module/Raw/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Raw/Value.hs
@@ -0,0 +1,29 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Raw.Value
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Emacs.Module.Raw.Value (RawValue(..), GlobalRef(..)) where
+
+import Control.DeepSeq
+
+import Foreign
+
+-- | Basic handle on an Emacs value. Can be GC'ed after any call into Emacs.
+-- To overcome that, use 'ValueGC'.
+--
+-- Not a real pointer because emacs values are not really pointers. That is,
+-- they're completely opaque.
+newtype RawValue = RawValue { unRawValue :: Ptr RawValue }
+ deriving (NFData, Storable)
+
+-- | Value that is independent of environment ('Env') that produced it.
+--
+-- Can be used to e.g. cache values that are expensive to compute from scratch.
+newtype GlobalRef = GlobalRef { unGlobalRef :: RawValue }
+ deriving (NFData, Storable)
diff --git a/src/Data/Emacs/Module/Runtime.hsc b/src/Data/Emacs/Module/Runtime.hsc
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Runtime.hsc
@@ -0,0 +1,52 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Runtime
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Emacs.Module.Runtime
+ ( Runtime(..)
+ , validateRuntime
+ , getEnvironment
+ ) where
+
+import Control.Monad.Base
+
+import Foreign
+import Foreign.C.Types
+
+import qualified Data.Emacs.Module.Env as Emacs
+import Data.Emacs.Module.Raw.Env.Internal (Env(..))
+import Data.Emacs.Module.NonNullPtr
+
+import Data.Emacs.Module.NonNullPtr.Internal
+
+#include
+
+-- | Emacs environment, right from the 'emacs-module.h'.
+newtype Runtime = Runtime { unRuntime :: NonNullPtr Runtime }
+
+type GetEnvironentType = Runtime -> IO Emacs.Env
+
+foreign import ccall unsafe "dynamic" emacs_get_environment
+ :: FunPtr GetEnvironentType -> GetEnvironentType
+
+validateRuntime :: MonadBase IO m => Ptr Runtime -> m (Maybe Runtime)
+validateRuntime ptr
+ | ptr == nullPtr = pure Nothing
+ | otherwise = liftBase $ do
+ size <- (#peek struct emacs_runtime, size) ptr
+ pure $ if expectedSize <= size then Just (Runtime (NonNullPtr ptr)) else Nothing
+ where
+ expectedSize :: CPtrdiff
+ expectedSize = (#size struct emacs_runtime)
+
+getEnvironment :: MonadBase IO m => Runtime -> m Emacs.Env
+getEnvironment runtime = liftBase $ do
+ (funPtr :: FunPtr GetEnvironentType) <- (#peek struct emacs_runtime, get_environment) (unNonNullPtr $ unRuntime runtime)
+ emacs_get_environment funPtr runtime
diff --git a/src/Data/Emacs/Module/SymbolName.hs b/src/Data/Emacs/Module/SymbolName.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/SymbolName.hs
@@ -0,0 +1,17 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.SymbolName
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+module Data.Emacs.Module.SymbolName
+ ( SymbolName
+ , mkSymbolName
+ , mkSymbolNameShortByteString
+ , useSymbolNameAsCString
+ ) where
+
+import Data.Emacs.Module.SymbolName.Internal
+
diff --git a/src/Data/Emacs/Module/SymbolName/Internal.hs b/src/Data/Emacs/Module/SymbolName/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/SymbolName/Internal.hs
@@ -0,0 +1,42 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.SymbolName.Internal
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+module Data.Emacs.Module.SymbolName.Internal
+ ( SymbolName(..)
+ , mkSymbolName
+ , mkSymbolNameShortByteString
+ , useSymbolNameAsCString
+ ) where
+
+import qualified Data.ByteString.Short as BSS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Unsafe as C8.Unsafe
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TE
+import Data.Text.Prettyprint.Doc
+import Foreign.C.String
+
+newtype SymbolName = SymbolName { unSymbolName :: C8.ByteString }
+ deriving (Eq, Ord, Show)
+
+instance Pretty SymbolName where
+ pretty = pretty . TE.decodeUtf8With TE.lenientDecode . C8.init . unSymbolName
+
+{-# INLINE mkSymbolName #-}
+mkSymbolName :: C8.ByteString -> SymbolName
+mkSymbolName = SymbolName . (`C8.snoc` '\0')
+
+{-# INLINE mkSymbolNameShortByteString #-}
+mkSymbolNameShortByteString :: BSS.ShortByteString -> SymbolName
+mkSymbolNameShortByteString = mkSymbolName . BSS.fromShort
+
+{-# INLINE useSymbolNameAsCString #-}
+useSymbolNameAsCString :: SymbolName -> (CString -> IO a) -> IO a
+useSymbolNameAsCString = C8.Unsafe.unsafeUseAsCString . unSymbolName
diff --git a/src/Data/Emacs/Module/SymbolName/TH.hs b/src/Data/Emacs/Module/SymbolName/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/SymbolName/TH.hs
@@ -0,0 +1,34 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.SymbolName.TH
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Emacs.Module.SymbolName.TH (esym) where
+
+import qualified Data.ByteString.Char8 as C8
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+import Data.Emacs.Module.SymbolName.Internal
+
+-- | Quasi-quoter for 'SymbolName'. Avoids some runtime overhead of
+-- creating a 'SymbolName', but in other respects is absolutely equivalent
+-- to 'mkSymbolName'.
+--
+-- > [esym|foo|] == mkSymbolName "foo"
+-- True
+esym :: QuasiQuoter
+esym = QuasiQuoter
+ { quoteExp = mkESym
+ , quotePat = const $ fail "Only defined for values"
+ , quoteType = const $ fail "Only defined for values"
+ , quoteDec = const $ fail "Only defined for values"
+ }
+
+mkESym :: String -> ExpQ
+mkESym s = [e| SymbolName (C8.pack $(stringE $ s ++ "\0")) |]
diff --git a/src/Data/Emacs/Module/Value.hs b/src/Data/Emacs/Module/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Value.hs
@@ -0,0 +1,15 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.RawValue
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+module Data.Emacs.Module.Value
+ ( RawValue
+ , Value(..)
+ ) where
+
+import Data.Emacs.Module.Raw.Value (RawValue)
+import Data.Emacs.Module.Value.Internal
diff --git a/src/Data/Emacs/Module/Value/Internal.hs b/src/Data/Emacs/Module/Value/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Emacs/Module/Value/Internal.hs
@@ -0,0 +1,36 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Data.Emacs.Module.Value.Internal
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Data.Emacs.Module.Value.Internal (Value(..)) where
+
+import Control.DeepSeq
+import Control.Monad.Trans.Resource
+
+import GHC.Generics (Generic)
+
+import Data.Emacs.Module.Raw.Value (GlobalRef(..))
+
+-- | Value that is independent of environment ('Env') that produced it.
+-- Incidentally, this implies that it's "protected" against Emacs GC and
+-- thus will not unexpectedly go out of scope.
+--
+-- In order to prevent memory leaks, value is registered in the Emacs
+-- monad than produced it and will be freed when the monad finishes.
+-- To make the connection clear the value is tagged with parameter
+-- @s@, which serves the same purpose as tag of the 'ST' monad. That
+-- is, it ensures that value cannot leave the scope of the monad that
+-- produced it.
+data Value s = Value
+ { valuePayload :: {-# UNPACK #-} !GlobalRef
+ , valueReleaseHandle :: {-# UNPACK #-} !ReleaseKey
+ } deriving (Generic)
+
+instance NFData (Value s) where
+ rnf (Value x y) = rnf x `seq` y `seq` ()
diff --git a/src/Emacs/Module.hs b/src/Emacs/Module.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module.hs
@@ -0,0 +1,54 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+module Emacs.Module
+ ( -- * Generic interface
+ MonadEmacs(..)
+
+ -- * Type synonyms
+ , EmacsFunction
+ , EmacsFunctionExtra
+ , Raw.UserPtrFinaliserType
+ , Raw.UserPtrFinaliser
+
+ -- * Types for defining functions
+ , Nat(..)
+ , R(..)
+ , O(..)
+ , Rest(..)
+ , Stop(..)
+
+ -- * Errors
+ , EmacsError(..)
+ , EmacsInternalError(..)
+ , reportAllErrorsToEmacs
+
+ -- * EmacsM
+ , EmacsM
+ , runEmacsM
+
+ -- * Reexports
+ , module Emacs.Module.Functions
+ , module Data.Emacs.Module.Value
+ , Env
+
+ -- * Third-party reexports
+ , MonadThrow
+ , Throws
+ ) where
+
+import Control.Exception.Safe.Checked (MonadThrow, Throws)
+
+import Data.Emacs.Module.Args
+import Data.Emacs.Module.Env (Env)
+import qualified Data.Emacs.Module.Raw.Env as Raw
+import Data.Emacs.Module.Value
+import Emacs.Module.Errors
+import Emacs.Module.Functions
+import Emacs.Module.Monad
+import Emacs.Module.Monad.Class
diff --git a/src/Emacs/Module/Assert.hs b/src/Emacs/Module/Assert.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module/Assert.hs
@@ -0,0 +1,38 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module.Assert
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Emacs.Module.Assert
+ ( WithCallStack
+ , emacsAssert
+ ) where
+
+import Data.Kind (Constraint)
+
+#ifdef ASSERTIONS
+import GHC.Stack (HasCallStack)
+#endif
+
+#ifdef ASSERTIONS
+type WithCallStack = (HasCallStack :: Constraint)
+#else
+type WithCallStack = (() :: Constraint)
+#endif
+
+#ifdef ASSERTIONS
+emacsAssert :: WithCallStack => Bool -> String -> a -> a
+emacsAssert True _ = id
+emacsAssert False msg = error $ "Assertion failed: " ++ msg
+#else
+{-# INLINE emacsAssert #-}
+emacsAssert :: WithCallStack => Bool -> String -> a -> a
+emacsAssert _ _ = id
+#endif
diff --git a/src/Emacs/Module/Errors.hs b/src/Emacs/Module/Errors.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module/Errors.hs
@@ -0,0 +1,242 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module.Errors
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+--
+-- This module defines various kinds of exception that this library
+----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Emacs.Module.Errors
+ ( EmacsThrow(..)
+ , reportEmacsThrowToEmacs
+ , UserError(..)
+ , mkUserError
+ , EmacsError(..)
+ , mkEmacsError
+ , reportErrorToEmacs
+ , EmacsInternalError(..)
+ , mkEmacsInternalError
+ , reportInternalErrorToEmacs
+
+ , formatSomeException
+ , reportAnyErrorToEmacs
+ , reportAllErrorsToEmacs
+ ) where
+
+import Control.Applicative
+import Control.Exception as Exception
+import Control.Exception.Safe.Checked (Throws)
+import qualified Control.Exception.Safe.Checked as Checked
+
+import qualified Data.ByteString.Char8 as C8
+import Data.Proxy
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+import Data.Text.Prettyprint.Doc
+import qualified Data.Text.Prettyprint.Doc.Render.Text as PP
+import Data.Void
+import Data.Void.Unsafe
+import Foreign.C.String
+import Foreign.Marshal.Array
+import GHC.Stack (CallStack, callStack, prettyCallStack)
+import Text.Show (showString)
+
+import qualified Data.Emacs.Module.Env as Raw
+import Data.Emacs.Module.NonNullPtr
+import Data.Emacs.Module.Raw.Env.Internal (Env)
+import Data.Emacs.Module.Raw.Value
+import Data.Emacs.Module.SymbolName (useSymbolNameAsCString)
+import Data.Emacs.Module.SymbolName.TH
+import Emacs.Module.Assert
+-- import qualified Data.Emacs.Module.Value.Internal as Emacs
+
+-- | A Haskell exception used to signal a @throw@ exit performed by an
+-- Emacs function.
+--
+-- Unlikely to be needed when developing Emacs extensions.
+data EmacsThrow = EmacsThrow
+ { emacsThrowTag :: !RawValue
+ , emacsThrowValue :: !RawValue
+ }
+
+instance Show EmacsThrow where
+ showsPrec _ _ = showString "EmacsThrow"
+
+instance Exception EmacsThrow
+
+reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO RawValue
+reportEmacsThrowToEmacs env et = do
+ reportEmacsThrowToEmacs' env et
+ returnNil env
+
+reportEmacsThrowToEmacs' :: Env -> EmacsThrow -> IO ()
+reportEmacsThrowToEmacs' env EmacsThrow{emacsThrowTag, emacsThrowValue} = do
+ Raw.nonLocalExitThrow env emacsThrowTag emacsThrowValue
+
+-- | Error thrown to emacs by Haskell functions when anything goes awry.
+data UserError = UserError
+ { userErrFunctionName :: Doc Void
+ , userErrMsg :: Doc Void
+ , userErrStack :: CallStack
+ } deriving (Show)
+
+instance Exception UserError
+
+instance Pretty UserError where
+ pretty (UserError func msg stack) =
+ "Error in function" <+> unsafeVacuous func <> ":" <> line <>
+ indent 2 (unsafeVacuous msg) <> line <> line <>
+ "Location:" <> line <>
+ indent 2 (ppCallStack stack)
+
+mkUserError
+ :: WithCallStack
+ => Doc Void -- ^ Function name
+ -> Doc Void -- ^ Message body
+ -> UserError
+mkUserError funcName body = UserError
+ { userErrFunctionName = funcName
+ , userErrMsg = body
+ , userErrStack = callStack
+ }
+
+-- | A high-level error thrown when an Emacs function fails.
+data EmacsError = EmacsError
+ { emacsErrMsg :: Doc Void
+ , emacsErrData :: Doc Void
+ , emacsErrStack :: CallStack
+ } deriving (Show)
+
+instance Exception EmacsError
+
+mkEmacsError
+ :: WithCallStack
+ => Doc Void -- ^ Message
+ -> Doc Void -- ^ Error data from Emacs
+ -> EmacsError
+mkEmacsError msg errData = EmacsError
+ { emacsErrMsg = msg
+ , emacsErrData = errData
+ , emacsErrStack = callStack
+ }
+
+instance Pretty EmacsError where
+ pretty EmacsError{emacsErrMsg, emacsErrData, emacsErrStack} =
+ "Error within Haskell<->Emacs bindings:" <> line <>
+ indent 2 (unsafeVacuous emacsErrMsg) <> line <> line <>
+ "Emacs error:" <> line <>
+ indent 2 (unsafeVacuous emacsErrData) <> line <> line <>
+ "Location:" <> line <>
+ indent 2 (ppCallStack emacsErrStack)
+
+reportErrorToEmacs :: Env -> EmacsError -> IO RawValue
+reportErrorToEmacs env e = do
+ report render env e
+ returnNil env
+
+-- | A low-level error thrown when assumptions of this package are
+-- violated and it's not safe to proceed further.
+data EmacsInternalError = EmacsInternalError
+ { emacsInternalErrMsg :: Doc Void
+ , emacsInternalErrStack :: CallStack
+ } deriving (Show)
+
+instance Exception EmacsInternalError
+
+mkEmacsInternalError
+ :: WithCallStack
+ => Doc Void -- ^ Error message
+ -> EmacsInternalError
+mkEmacsInternalError msg = EmacsInternalError
+ { emacsInternalErrMsg = msg
+ , emacsInternalErrStack = callStack
+ }
+
+reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO RawValue
+reportInternalErrorToEmacs env e = do
+ report render env e
+ returnNil env
+
+instance Pretty EmacsInternalError where
+ pretty EmacsInternalError{emacsInternalErrMsg, emacsInternalErrStack} =
+ "Internal error within Haskell<->Emacs bindings:" <> line <>
+ indent 2 (unsafeVacuous emacsInternalErrMsg) <> line <> line <>
+ "Location:" <> line <>
+ indent 2 (ppCallStack emacsInternalErrStack)
+
+formatSomeException :: SomeException -> Text
+formatSomeException e =
+ case pretty @EmacsError <$> fromException e <|>
+ pretty @EmacsInternalError <$> fromException e <|>
+ pretty @UserError <$> fromException e of
+ Just formatted -> render' formatted
+ Nothing ->
+ PP.renderStrict $ layoutPretty defaultLayoutOptions $
+ "Error within Haskell<->Emacs bindings:" <> line <>
+ indent 2 (pretty (show e))
+
+reportAnyErrorToEmacs :: Env -> SomeException -> IO RawValue
+reportAnyErrorToEmacs env e = do
+ report formatSomeException env e
+ returnNil env
+
+-- | Catch all errors this package might throw in an IO action
+-- and make Emacs aware of them.
+--
+-- This is a convenience function intended to be used around exported
+-- @initialise@ entry point into an Emacs module.
+reportAllErrorsToEmacs
+ :: Env
+ -> IO a -- ^ Result to return on error.
+ -> ((Throws EmacsInternalError, Throws EmacsError, Throws UserError, Throws EmacsThrow) => IO a)
+ -> IO a
+reportAllErrorsToEmacs env resultOnErr x =
+ Exception.handle (\e -> report formatSomeException env e *> resultOnErr) $
+ Checked.handle (\et -> reportEmacsThrowToEmacs' env et *> resultOnErr) $
+ Checked.uncheck (Proxy @EmacsInternalError) $
+ Checked.uncheck (Proxy @EmacsError) $
+ Checked.uncheck (Proxy @UserError) x
+
+report :: (e -> Text) -> Env -> e -> IO ()
+report format env err = do
+ errSym <- useSymbolNameAsCString [esym|error|] (Raw.intern env)
+ listSym <- useSymbolNameAsCString [esym|list|] (Raw.intern env)
+ withTextAsCString0AndLen (format err) $ \str len -> do
+ str' <- Raw.makeString env str (fromIntegral len)
+ withArrayLen [str'] $ \nargs argsPtr -> do
+ errData <- Raw.funcallPrimitive env listSym (fromIntegral nargs) (mkNonNullPtr argsPtr)
+ -- The 'nonLocalExitSignal' function does not overwrite pending
+ -- signals, so it's ok to use it here without checking whether an
+ -- error is already going on.
+ Raw.nonLocalExitSignal env errSym errData
+
+withTextAsCString0AndLen :: Text -> (CString -> Int -> IO a) -> IO a
+withTextAsCString0AndLen str f =
+ C8.useAsCString utf8 (\ptr -> f ptr (C8.length utf8))
+ where
+ utf8 = (TE.encodeUtf8 str)
+
+returnNil :: Env -> IO RawValue
+returnNil env =
+ useSymbolNameAsCString [esym|nil|] (Raw.intern env)
+
+
+render :: Pretty a => a -> Text
+render = render' . pretty
+
+render' :: Doc Void -> Text
+render' = PP.renderStrict . layoutPretty defaultLayoutOptions
+
+ppCallStack :: CallStack -> Doc ann
+ppCallStack = pretty . prettyCallStack
+
diff --git a/src/Emacs/Module/Functions.hs b/src/Emacs/Module/Functions.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module/Functions.hs
@@ -0,0 +1,444 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module.Functions
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+--
+-- Wrappers around some Emacs functions, independent of concrete monad.
+----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Emacs.Module.Functions
+ ( bindFunction
+ , makeFunction
+ , withCleanup
+ , provide
+ , makeUserPtrFromStablePtr
+ , extractStablePtrFromUserPtr
+ -- * Haskell<->Emacs datatype conversions
+ , extractInt
+ , makeInt
+ , extractText
+ , makeText
+ , extractShortByteString
+ , makeShortByteString
+ , extractBool
+ , makeBool
+ -- * Vectors
+ , extractVector
+ , extractVectorWith
+ , extractUnboxedVectorWith
+ , makeVector
+ , vconcat2
+ -- * Lists
+ , cons
+ , car
+ , cdr
+ , nil
+ , setcar
+ , setcdr
+ , makeList
+ , extractList
+ , extractListWith
+ , extractListRevWith
+ , foldlEmacsListWith
+ , unfoldEmacsListWith
+ -- * Strings
+ , addFaceProp
+ , concat2
+ , valueToText
+ , symbolName
+
+ -- * Reexports
+ , MonadMask
+ ) where
+
+import Control.Monad.Catch
+import Control.Monad.Except
+
+import qualified Data.ByteString.Char8 as C8
+import Data.ByteString.Short (ShortByteString)
+import qualified Data.ByteString.Short as BSS
+import Data.Foldable
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TE
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as U
+import Foreign.Ptr (nullPtr)
+import Foreign.StablePtr
+
+import Data.Emacs.Module.Args
+import qualified Data.Emacs.Module.Env as Env
+import Data.Emacs.Module.SymbolName (SymbolName)
+import Data.Emacs.Module.SymbolName.TH
+import Emacs.Module.Assert
+import Emacs.Module.Monad.Class
+
+
+{-# INLINABLE bindFunction #-}
+-- | Assign a name to function value.
+bindFunction
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => SymbolName -- ^ Name
+ -> EmacsRef m s -- ^ Function value
+ -> m s ()
+bindFunction name def = do
+ name' <- intern name
+ funcallPrimitive_ [esym|fset|] [name', def]
+
+{-# INLINE makeFunction #-}
+-- | Make Haskell function available as an anonymoucs Emacs
+-- function. In order to be able to use it later from Emacs it should
+-- be fed into 'bindFunction'.
+--
+-- This is a simplified version of 'makeFunctionExtra'.
+makeFunction
+ :: (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest, MonadEmacs m, Monad (m s))
+ => (forall s'. EmacsFunction req opt rest s' m)
+ -> C8.ByteString
+ -> m s (EmacsRef m s)
+makeFunction f doc =
+ makeFunctionExtra (\env _extraPtr -> f env) doc nullPtr
+
+{-# INLINE provide #-}
+-- | Signal to Emacs that certain feature is being provided. Returns provided
+-- symbol.
+provide
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => SymbolName -- ^ Feature to provide
+ -> m s ()
+provide sym = do
+ sym' <- intern sym
+ funcallPrimitive_ [esym|provide|] [sym']
+
+{-# INLINE makeUserPtrFromStablePtr #-}
+-- | Pack a stable pointer as Emacs @user_ptr@.
+makeUserPtrFromStablePtr
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => StablePtr a
+ -> m s (EmacsRef m s)
+makeUserPtrFromStablePtr =
+ makeUserPtr Env.freeStablePtrFinaliser . castStablePtrToPtr
+
+{-# INLINE extractStablePtrFromUserPtr #-}
+extractStablePtrFromUserPtr
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s (StablePtr a)
+extractStablePtrFromUserPtr =
+ fmap castPtrToStablePtr . extractUserPtr
+
+{-# INLINE extractInt #-}
+-- | Try to obtain an 'Int' from Emacs value.
+--
+-- This function will fail if Emacs value is not an integer or
+-- contains value too big to fit into 'Int' on current architecture.
+extractInt
+ :: (WithCallStack, MonadEmacs m, Monad (m s)) => EmacsRef m s -> m s Int
+extractInt x = do
+ y <- extractWideInteger x
+ emacsAssert
+ (y <= fromIntegral (maxBound :: Int))
+ ("Integer is too wide to fit into Int: " ++ show y)
+ (pure (fromIntegral y))
+
+{-# INLINE makeInt #-}
+-- | Pack an 'Int' integer for Emacs.
+makeInt
+ :: (WithCallStack, MonadEmacs m, Monad (m s)) => Int -> m s (EmacsRef m s)
+makeInt = makeWideInteger . fromIntegral
+
+{-# INLINE extractText #-}
+-- | Extract string contents as 'Text' from an Emacs value.
+extractText
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -> m s Text
+extractText x = TE.decodeUtf8With TE.lenientDecode <$> extractString x
+
+{-# INLINE makeText #-}
+-- | Convert a Text into an Emacs string value.
+makeText
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => Text -> m s (EmacsRef m s)
+makeText = makeString . TE.encodeUtf8
+
+
+{-# INLINE extractShortByteString #-}
+-- | Extract string contents as 'ShortByteString' from an Emacs value.
+extractShortByteString
+ :: (WithCallStack, MonadEmacs m, Functor (m s))
+ => EmacsRef m s -> m s ShortByteString
+extractShortByteString = fmap BSS.toShort . extractString
+
+{-# INLINE makeShortByteString #-}
+-- | Convert a ShortByteString into an Emacs string value.
+makeShortByteString
+ :: (WithCallStack, MonadEmacs m)
+ => ShortByteString -> m s (EmacsRef m s)
+makeShortByteString = makeString . BSS.fromShort
+
+
+{-# INLINE extractBool #-}
+-- | Extract a boolean from an Emacs value.
+extractBool
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -> m s Bool
+extractBool = isNotNil
+
+{-# INLINE makeBool #-}
+-- | Convert a Bool into an Emacs string value.
+makeBool
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => Bool -> m s (EmacsRef m s)
+makeBool b = intern (if b then [esym|t|] else [esym|nil|])
+
+{-# INLINE withCleanup #-}
+-- | Feed a value into a function and clean it up afterwards.
+withCleanup
+ :: (WithCallStack, MonadMask (m s), MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> (EmacsRef m s -> m s a)
+ -> m s a
+withCleanup x f = f x `finally` freeValue x
+
+{-# INLINABLE extractVector #-}
+-- | Get all elements form an Emacs vector.
+extractVector
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -> m s (V.Vector (EmacsRef m s))
+extractVector xs = do
+ n <- vecSize xs
+ V.generateM n $ vecGet xs
+
+{-# INLINABLE extractVectorWith #-}
+-- | Get all elements form an Emacs vector using specific function to
+-- convert elements.
+extractVectorWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => (EmacsRef m s -> m s a)
+ -> EmacsRef m s
+ -> m s (V.Vector a)
+extractVectorWith f xs = do
+ n <- vecSize xs
+ V.generateM n $ f <=< vecGet xs
+
+{-# INLINABLE extractUnboxedVectorWith #-}
+-- | Get all elements form an Emacs vector using specific function to
+-- convert elements.
+extractUnboxedVectorWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s), U.Unbox a)
+ => (EmacsRef m s -> m s a)
+ -> EmacsRef m s
+ -> m s (U.Vector a)
+extractUnboxedVectorWith f xs = do
+ n <- vecSize xs
+ U.generateM n $ f <=< vecGet xs
+
+{-# INLINE makeVector #-}
+-- | Create an Emacs vector.
+makeVector
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => [EmacsRef m s]
+ -> m s (EmacsRef m s)
+makeVector = funcallPrimitive [esym|vector|]
+
+{-# INLINE vconcat2 #-}
+-- | Concatenate two vectors.
+vconcat2
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> EmacsRef m s
+ -> m s (EmacsRef m s)
+vconcat2 x y =
+ funcallPrimitive [esym|vconcat|] [x, y]
+
+{-# INLINE cons #-}
+-- | Make a cons pair out of two values.
+cons
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -- ^ car
+ -> EmacsRef m s -- ^ cdr
+ -> m s (EmacsRef m s)
+cons x y = funcallPrimitive [esym|cons|] [x, y]
+
+{-# INLINE car #-}
+-- | Take first element of a pair.
+car
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s (EmacsRef m s)
+car = funcallPrimitive [esym|car|] . (: [])
+
+{-# INLINE cdr #-}
+-- | Take second element of a pair.
+cdr
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s (EmacsRef m s)
+cdr = funcallPrimitive [esym|cdr|] . (: [])
+
+{-# INLINE nil #-}
+-- | A @nil@ symbol aka empty list.
+nil
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => m s (EmacsRef m s)
+nil = intern [esym|nil|]
+
+{-# INLINE setcar #-}
+-- | Mutate first element of a cons pair.
+setcar
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -- ^ Cons pair
+ -> EmacsRef m s -- ^ New value
+ -> m s ()
+setcar x y = funcallPrimitive_ [esym|setcar|] [x, y]
+
+{-# INLINE setcdr #-}
+-- | Mutate second element of a cons pair.
+setcdr
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -- ^ Cons pair
+ -> EmacsRef m s -- ^ New value
+ -> m s ()
+setcdr x y = funcallPrimitive_ [esym|setcdr|] [x, y]
+
+{-# INLINE makeList #-}
+-- | Construct vanilla Emacs list from a Haskell list.
+makeList
+ :: (WithCallStack, MonadEmacs m, Monad (m s), Foldable f)
+ => f (EmacsRef m s)
+ -> m s (EmacsRef m s)
+makeList = unfoldEmacsListWith (pure . go) . toList
+ where
+ go = \case
+ [] -> Nothing
+ y : ys -> Just (y, ys)
+
+{-# INLINE extractList #-}
+-- | Extract vanilla Emacs list as Haskell list.
+extractList
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s [EmacsRef m s]
+extractList = extractListWith pure
+
+{-# INLINE extractListWith #-}
+-- | Extract vanilla Emacs list as a Haskell list.
+extractListWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => (EmacsRef m s -> m s a)
+ -> EmacsRef m s
+ -> m s [a]
+extractListWith = \f -> fmap reverse . extractListRevWith f
+
+{-# INLINE extractListRevWith #-}
+-- | Extract vanilla Emacs list as a reversed Haskell list. It's more
+-- efficient than 'extractList' but doesn't preserve order of elements
+-- that was specified from Emacs side.
+extractListRevWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => (EmacsRef m s -> m s a)
+ -> EmacsRef m s
+ -> m s [a]
+extractListRevWith f = go []
+ where
+ go acc xs = do
+ nonNil <- isNotNil xs
+ if nonNil
+ then do
+ x <- f =<< car xs
+ xs' <- cdr xs
+ go (x : acc) xs'
+ else pure acc
+
+{-# INLINE foldlEmacsListWith #-}
+-- | Fold Emacs list starting from the left.
+foldlEmacsListWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => (a -> EmacsRef m s -> m s a)
+ -> a
+ -> EmacsRef m s
+ -> m s a
+foldlEmacsListWith f = go
+ where
+ go acc xs = do
+ nonNil <- isNotNil xs
+ if nonNil
+ then do
+ acc' <- f acc =<< car xs
+ go acc' =<< cdr xs
+ else pure acc
+
+{-# INLINE unfoldEmacsListWith #-}
+-- | Fold Emacs list starting from the left.
+unfoldEmacsListWith
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => (a -> m s (Maybe (EmacsRef m s, a)))
+ -> a
+ -> m s (EmacsRef m s)
+unfoldEmacsListWith f accum = do
+ accum' <- f accum
+ nilVal <- nil
+ case accum' of
+ Nothing -> pure nilVal
+ Just (x, accum'') -> do
+ cell <- cons x nilVal
+ go nilVal accum'' cell
+ pure cell
+ where
+ go nilVal = go'
+ where
+ go' acc cell = do
+ acc' <- f acc
+ case acc' of
+ Nothing -> pure ()
+ Just (x, acc'') -> do
+ cell' <- cons x nilVal
+ setcdr cell cell'
+ go' acc'' cell'
+
+{-# INLINE addFaceProp #-}
+-- | Add new 'face property to a string.
+addFaceProp
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s -- ^ String to add face to
+ -> SymbolName -- ^ Face name
+ -> m s (EmacsRef m s) -- ^ Propertised string
+addFaceProp str face = do
+ faceSym <- intern [esym|face|]
+ face' <- intern face
+ funcallPrimitive [esym|propertize|] [str, faceSym, face']
+
+{-# INLINE concat2 #-}
+-- | Concatenate two strings.
+concat2
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> EmacsRef m s
+ -> m s (EmacsRef m s)
+concat2 x y =
+ funcallPrimitive [esym|concat|] [x, y]
+
+{-# INLINE valueToText #-}
+-- | Convert an Emacs value into a string using @prin1-to-string@.
+valueToText
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s Text
+valueToText x =
+ extractText =<< funcallPrimitive [esym|prin1-to-string|] [x]
+
+{-# INLINE symbolName #-}
+-- | Wrapper around Emacs @symbol-name@ function - take a symbol
+-- and produce an Emacs string with its textual name.
+symbolName
+ :: (WithCallStack, MonadEmacs m, Monad (m s))
+ => EmacsRef m s
+ -> m s (EmacsRef m s)
+symbolName = funcallPrimitive [esym|symbol-name|] . (:[])
diff --git a/src/Emacs/Module/Monad.hs b/src/Emacs/Module/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module/Monad.hs
@@ -0,0 +1,472 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module.Monad
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+--
+-- This module defines the implementation of the 'MonadEmacs'.
+----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Emacs.Module.Monad
+ ( EmacsM
+ , runEmacsM
+ ) where
+
+import qualified Control.Exception as Exception
+import qualified Control.Monad.Catch as Catch
+import Control.Exception.Safe.Checked (MonadThrow, Throws)
+import qualified Control.Exception.Safe.Checked as Checked
+import Control.Monad.Base
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Resource as Resource
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import Data.Coerce
+import Data.Proxy
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TE
+import Data.Text.Prettyprint.Doc
+import Data.Traversable
+import Data.Void
+import Foreign (Storable(..))
+import Foreign.C.Types
+import Foreign.Marshal.Array
+import Foreign.Ptr (Ptr, nullPtr)
+
+import Data.Emacs.Module.Args
+import Data.Emacs.Module.Env.Functions
+import Data.Emacs.Module.NonNullPtr
+import qualified Data.Emacs.Module.Raw.Env as Raw
+import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType, exportToEmacs)
+import Data.Emacs.Module.Raw.Value (RawValue, GlobalRef(..))
+import Data.Emacs.Module.SymbolName (SymbolName, useSymbolNameAsCString)
+import Data.Emacs.Module.SymbolName.TH
+import Data.Emacs.Module.Value.Internal
+import Emacs.Module.Assert
+import Emacs.Module.Errors
+import Emacs.Module.Monad.Class
+
+data Environment = Environment
+ { eEnv :: !Env
+ , eErrorSym :: !(NonNullPtr RawValue)
+ , eErrorData :: !(NonNullPtr RawValue)
+ , eResourceState :: !Resource.InternalState
+ }
+
+newtype EmacsM s a = EmacsM { unEmacsM :: ReaderT Environment IO a }
+ deriving
+ ( Functor
+ , Applicative
+ , Monad
+ , MonadIO
+ , Catch.MonadThrow
+ , Catch.MonadCatch
+ , Catch.MonadMask
+ , MonadBase IO
+ , MonadFix
+ )
+
+instance MonadResource (EmacsM s) where
+ liftResourceT action = EmacsM $ do
+ resState <- asks eResourceState
+ liftBase $ runInternalState action resState
+
+instance MonadBaseControl IO (EmacsM s) where
+ type StM (EmacsM s) a = StM (ReaderT Environment IO) a
+ {-# INLINE liftBaseWith #-}
+ liftBaseWith f = EmacsM (liftBaseWith (\runInBase -> f (runInBase . unEmacsM)))
+ {-# INLINE restoreM #-}
+ restoreM x = EmacsM (restoreM x)
+
+runEmacsM
+ :: Env
+ -> (forall s. EmacsM s a)
+ -> IO a
+runEmacsM env (EmacsM action) =
+ allocaNonNull $ \pErr ->
+ allocaNonNull $ \pData ->
+ Exception.bracket
+ Resource.createInternalState
+ Resource.closeInternalState
+ (\eResourceState ->
+ runReaderT action Environment
+ { eEnv = env
+ , eErrorSym = pErr
+ , eErrorData = pData
+ , eResourceState
+ })
+
+{-# INLINE getRawValue #-}
+getRawValue :: Value s -> RawValue
+getRawValue = unGlobalRef . valuePayload
+
+{-# INLINE liftIO' #-}
+liftIO' :: (Env -> IO a) -> EmacsM s a
+liftIO' f = EmacsM $ asks eEnv >>= liftIO . f
+
+{-# INLINABLE makeValue #-}
+-- | Protect a raw value (i.e. a plain pointer) from Emacs GC.
+--
+-- Users writing emacs extersions will likely have no need to
+-- call this function directly.
+makeValue
+ :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
+ => RawValue
+ -> EmacsM s (Value s)
+makeValue raw = do
+ env <- EmacsM $ asks eEnv
+ valuePayload <-
+ checkExitAndRethrowInHaskell' "makeGlobalRef failed" $
+ Raw.makeGlobalRef env raw
+ valueReleaseHandle <- register (Raw.freeGlobalRef env valuePayload)
+ pure Value{valuePayload, valueReleaseHandle}
+
+{-# INLINABLE unpackEnumFuncallExit #-}
+unpackEnumFuncallExit
+ :: (MonadThrow m, Throws EmacsInternalError, WithCallStack)
+ => Raw.EnumFuncallExit -> m (FuncallExit ())
+unpackEnumFuncallExit (Raw.EnumFuncallExit (CInt x)) =
+ case funcallExitFromNum x of
+ Nothing -> Checked.throw $ mkEmacsInternalError $
+ "Unknown value of enum emacs_funcall_exit:" <+> pretty x
+ Just y -> pure y
+
+nonLocalExitGet'
+ :: (WithCallStack, Throws EmacsInternalError)
+ => EmacsM s (FuncallExit (RawValue, RawValue))
+nonLocalExitGet' = do
+ Environment{eEnv, eErrorSym, eErrorData} <- EmacsM ask
+ liftIO $ do
+ x <- unpackEnumFuncallExit =<< Raw.nonLocalExitGet eEnv eErrorSym eErrorData
+ for x $ \_ ->
+ (,) <$> (peek (unNonNullPtr eErrorSym)) <*> (peek (unNonNullPtr eErrorData))
+
+{-# INLINE nonLocalExitClear' #-}
+nonLocalExitClear' :: WithCallStack => EmacsM s ()
+nonLocalExitClear' = liftIO' Raw.nonLocalExitClear
+
+{-# INLINE nonLocalExitCheck' #-}
+nonLocalExitCheck'
+ :: (WithCallStack, Throws EmacsInternalError)
+ => EmacsM s (FuncallExit ())
+nonLocalExitCheck' = liftIO' (unpackEnumFuncallExit <=< Raw.nonLocalExitCheck)
+
+
+checkExitAndRethrowInHaskell
+ :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
+ => Doc Void -- ^ Error message
+ -> EmacsM s ()
+checkExitAndRethrowInHaskell errMsg = do
+ x <- nonLocalExitGet'
+ case x of
+ FuncallExitReturn -> pure ()
+ FuncallExitSignal (sym, dat) -> do
+ nonLocalExitClear'
+ dat' <- funcallPrimitiveUnchecked [esym|cons|] [sym, dat]
+ formatted <- funcallPrimitiveUnchecked [esym|prin1-to-string|] [dat']
+ formatRes <- nonLocalExitCheck'
+ case formatRes of
+ FuncallExitSignal{} -> do
+ nonLocalExitClear'
+ Checked.throw $ mkEmacsInternalError $
+ "Failed to format Emacs error data while processing following error:" <> line <> errMsg
+ FuncallExitThrow{} -> do
+ nonLocalExitClear'
+ Checked.throw $ mkEmacsInternalError $
+ "Failed to format Emacs error data while processing following error:" <> line <> errMsg
+ FuncallExitReturn -> do
+ formatted' <- extractTextUtf8Unchecked formatted
+ Checked.throw $
+ mkEmacsError errMsg $
+ pretty formatted'
+ FuncallExitThrow (tag, value) ->
+ -- NB do not clear local exit flag - we, hopefully, should exit
+ -- now by unwinding full Haskell stack and the flag should be
+ -- reported all the way to Emacs to show a meaningful error or
+ -- do a catch in elisp.
+ Checked.throw EmacsThrow
+ { emacsThrowTag = tag
+ , emacsThrowValue = value
+ }
+
+{-# INLINE checkExitAndRethrowInHaskell' #-}
+checkExitAndRethrowInHaskell'
+ :: (WithCallStack, Throws EmacsInternalError, Throws EmacsError, Throws EmacsThrow)
+ => Doc Void -- ^ Error message
+ -> EmacsM s a
+ -> EmacsM s a
+checkExitAndRethrowInHaskell' errMsg action =
+ action <* checkExitAndRethrowInHaskell errMsg
+
+{-# INLINE internUnchecked #-}
+internUnchecked :: SymbolName -> EmacsM s RawValue
+internUnchecked sym =
+ liftIO' $ \env -> useSymbolNameAsCString sym $ Raw.intern env
+
+{-# INLINE funcallUnchecked #-}
+funcallUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
+funcallUnchecked name args = do
+ liftIO' $ \env -> do
+ fun <- useSymbolNameAsCString name $ Raw.intern env
+ withArrayLen args $ \n args' ->
+ Raw.funcall env fun (fromIntegral n) (mkNonNullPtr args')
+
+{-# INLINE funcallPrimitiveUnchecked #-}
+funcallPrimitiveUnchecked :: SymbolName -> [RawValue] -> EmacsM s RawValue
+funcallPrimitiveUnchecked name args =
+ liftIO' $ \env -> do
+ fun <- useSymbolNameAsCString name $ Raw.intern env
+ withArrayLen args $ \n args' ->
+ Raw.funcallPrimitive env fun (fromIntegral n) (mkNonNullPtr args')
+
+{-# INLINE typeOfUnchecked #-}
+typeOfUnchecked :: Value s -> EmacsM s RawValue
+typeOfUnchecked x =
+ liftIO' $ \env -> Raw.typeOf env (getRawValue x)
+
+extractTextUtf8Unchecked
+ :: (WithCallStack, Throws EmacsInternalError)
+ => RawValue -> EmacsM s T.Text
+extractTextUtf8Unchecked =
+ fmap (TE.decodeUtf8With TE.lenientDecode) . extractStringUnchecked
+
+extractStringUnchecked
+ :: (WithCallStack, Throws EmacsInternalError)
+ => RawValue -> EmacsM s BS.ByteString
+extractStringUnchecked x =
+ liftIO' $ \env ->
+ allocaNonNull $ \pSize -> do
+ res <- Raw.copyStringContents env x nullPtr pSize
+ unless (Raw.isTruthy res) $
+ -- Raw.nonLocalExitClear env
+ Checked.throw $ mkEmacsInternalError
+ "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."
+ size <- fromIntegral <$> peek (unNonNullPtr pSize)
+ allocaBytesNonNull size $ \pStr -> do
+ copyPerformed <- Raw.copyStringContents env x (unNonNullPtr pStr) pSize
+ if Raw.isTruthy copyPerformed
+ then
+ -- Should subtract 1 from size to avoid NULL terminator at the end.
+ BS.packCStringLen (unNonNullPtr pStr, size - 1)
+ else do
+ Raw.nonLocalExitClear env
+ Checked.throw $ mkEmacsInternalError "Failed to unpack string"
+
+instance (Throws EmacsThrow, Throws EmacsError, Throws EmacsInternalError) => MonadEmacs EmacsM where
+
+ type EmacsRef EmacsM = Value
+ type EmacsReturn EmacsM = EmacsRef EmacsM
+
+ {-# INLINE produceRef #-}
+ produceRef x = do
+ _ <- Resource.unprotect $ valueReleaseHandle x
+ pure x
+
+ {-# INLINE nonLocalExitCheck #-}
+ nonLocalExitCheck = nonLocalExitCheck'
+
+ {-# INLINE nonLocalExitGet #-}
+ nonLocalExitGet = do
+ z <- nonLocalExitGet'
+ for z $ \(x, y) -> (,) <$> makeValue x <*> makeValue y
+
+ nonLocalExitSignal sym errData = do
+ errData' <- funcallPrimitiveUnchecked [esym|list|] (map getRawValue errData)
+ liftIO' $ \env -> Raw.nonLocalExitSignal env (getRawValue sym) errData'
+
+ {-# INLINE nonLocalExitThrow #-}
+ nonLocalExitThrow tag errData = do
+ liftIO' $ \env -> Raw.nonLocalExitThrow env tag' errData'
+ Checked.throw EmacsThrow
+ { emacsThrowTag = tag'
+ , emacsThrowValue = errData'
+ }
+ where
+ tag' = getRawValue tag
+ errData' = getRawValue errData
+
+ {-# INLINE nonLocalExitClear #-}
+ nonLocalExitClear = nonLocalExitClear'
+
+ -- {-# INLINE makeGlobalRef #-}
+ -- makeGlobalRef x =
+ -- checkExitAndRethrowInHaskell' "makeGlobalRef failed" $
+ -- liftIO' (\env -> Raw.makeGlobalRef env x)
+ --
+ -- {-# INLINE freeGlobalRef #-}
+ -- freeGlobalRef x =
+ -- checkExitAndRethrowInHaskell' "freeGlobalRef failed" $
+ -- liftIO' (\env -> Raw.freeGlobalRef env x)
+
+ {-# INLINE freeValue #-}
+ freeValue :: WithCallStack => Value s -> EmacsM s ()
+ freeValue = Resource.release . valueReleaseHandle
+
+ {-# INLINE makeFunctionExtra #-}
+ makeFunctionExtra
+ :: forall req opt rest extra s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)
+ => (forall s'. EmacsFunctionExtra req opt rest extra s' EmacsM)
+ -> C8.ByteString
+ -> Ptr extra
+ -> EmacsM s (Value s)
+ makeFunctionExtra emacsFun docs extraPtr =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' "makeFunctionExtra failed"
+ (liftIO' $ \env ->
+ C8.useAsCString docs $ \docs' -> do
+ implementation' <- exportToEmacs implementation
+ Raw.makeFunction env minArity maxArity implementation' docs' extraPtr)
+ where
+ (minArity, maxArity) = arities (Proxy @req) (Proxy @opt) (Proxy @rest)
+
+ implementation :: RawFunctionType extra
+ implementation env nargs argsPtr extraPtr' =
+ Checked.uncheck (Proxy @UserError) $
+ Exception.handle (reportAnyErrorToEmacs env) $
+ Checked.handle (reportEmacsThrowToEmacs env) $ do
+ res <- runEmacsM env $ do
+ v <- supplyEmacsArgs (fromIntegral nargs) argsPtr makeValue (\args -> emacsFun args extraPtr')
+ pure $! valuePayload v
+#ifndef MODULE_ASSERTIONS
+ Raw.freeGlobalRef env res
+#endif
+ pure $ unGlobalRef res
+
+ {-# INLINE funcall #-}
+ funcall name args =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' ("funcall" <+> squotes (pretty name) <+> "failed")
+ (funcallUnchecked name (map getRawValue args))
+
+ {-# INLINE funcallPrimitive #-}
+ funcallPrimitive name args =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' ("funcall primitive" <+> squotes (pretty name) <+> "failed")
+ (funcallPrimitiveUnchecked name (map getRawValue args))
+
+ {-# INLINE funcallPrimitive_ #-}
+ funcallPrimitive_ name args =
+ checkExitAndRethrowInHaskell' ("funcall primitive" <+> squotes (pretty name) <+> "failed")
+ (void $ funcallPrimitiveUnchecked name (map getRawValue args))
+
+ {-# INLINE intern #-}
+ intern sym =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' ("intern of" <+> squotes (pretty sym) <+> "failed")
+ (internUnchecked sym)
+
+ {-# INLINE typeOf #-}
+ typeOf x =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' "typeOf failed"
+ (typeOfUnchecked x)
+
+ {-# INLINE isNotNil #-}
+ isNotNil x =
+ checkExitAndRethrowInHaskell' "isNotNil failed"
+ (liftIO' $ \env -> Raw.isTruthy <$> Raw.isNotNil env (getRawValue x))
+
+ {-# INLINE eq #-}
+ eq x y =
+ checkExitAndRethrowInHaskell' "eq failed"
+ (liftIO' $ \env -> Raw.isTruthy <$> Raw.eq env (getRawValue x) (getRawValue y))
+
+
+ {-# INLINE extractWideInteger #-}
+ extractWideInteger x =
+ checkExitAndRethrowInHaskell' "extractWideInteger failed"
+ (liftIO' $ \env -> coerce (Raw.extractInteger env (getRawValue x) :: IO CIntMax))
+
+ {-# INLINE makeWideInteger #-}
+ makeWideInteger x =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' ("makeWideInteger of" <+> pretty x <+> "failed")
+ (liftIO' $ \env -> Raw.makeInteger env (CIntMax x))
+
+ {-# INLINE extractDouble #-}
+ extractDouble x =
+ checkExitAndRethrowInHaskell' "extractDouble failed"
+ (liftIO' $ \env -> coerce (Raw.extractFloat env (getRawValue x) :: IO CDouble))
+
+ {-# INLINE makeDouble #-}
+ makeDouble x =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' ("makeDouble" <+> pretty x <+> "failed")
+ (liftIO' $ \env -> Raw.makeFloat env (CDouble x))
+
+ {-# INLINE extractString #-}
+ extractString x =
+ checkExitAndRethrowInHaskell' "extractString failed" $
+ extractStringUnchecked (getRawValue x)
+
+ {-# INLINE makeString #-}
+ makeString x =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' "makeString failed"
+ (liftIO' $ \env ->
+ BS.useAsCString x $ \pStr ->
+ Raw.makeString env pStr (fromIntegral (BS.length x)))
+
+ {-# INLINE extractUserPtr #-}
+ extractUserPtr x =
+ checkExitAndRethrowInHaskell' "extractUserPtr failed" $
+ liftIO' $ \env -> Raw.getUserPtr env $ getRawValue x
+
+ {-# INLINE makeUserPtr #-}
+ makeUserPtr finaliser ptr =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' "makeUserPtr failed"
+ (liftIO' $ \env -> Raw.makeUserPtr env finaliser ptr)
+
+ {-# INLINE assignUserPtr #-}
+ assignUserPtr dest ptr =
+ checkExitAndRethrowInHaskell' "assignUserPtr failed" $
+ liftIO' $ \env -> Raw.setUserPtr env (getRawValue dest) ptr
+
+ {-# INLINE extractUserPtrFinaliser #-}
+ extractUserPtrFinaliser x =
+ checkExitAndRethrowInHaskell' "extractUserPtrFinaliser failed" $
+ liftIO' $ \env -> Raw.getUserFinaliser env $ getRawValue x
+
+ {-# INLINE assignUserPtrFinaliser #-}
+ assignUserPtrFinaliser x finaliser =
+ checkExitAndRethrowInHaskell' "assignUserPtrFinaliser failed" $
+ liftIO' $ \env -> Raw.setUserFinaliser env (getRawValue x) finaliser
+
+ {-# INLINE vecGet #-}
+ vecGet vec n =
+ makeValue =<<
+ checkExitAndRethrowInHaskell' "vecGet failed"
+ (liftIO' $ \env -> Raw.vecGet env (getRawValue vec) (fromIntegral n))
+
+ {-# INLINE vecSet #-}
+ vecSet vec n x =
+ checkExitAndRethrowInHaskell' "vecSet failed" $
+ liftIO' $ \env -> Raw.vecSet env (getRawValue vec) (fromIntegral n) (getRawValue x)
+
+ {-# INLINE vecSize #-}
+ vecSize vec =
+ checkExitAndRethrowInHaskell' "vecSize failed" $
+ liftIO' $ \env -> fromIntegral <$> Raw.vecSize env (getRawValue vec)
diff --git a/src/Emacs/Module/Monad/Class.hs b/src/Emacs/Module/Monad/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Emacs/Module/Monad/Class.hs
@@ -0,0 +1,208 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Emacs.Module.Monad.Class
+-- Copyright : (c) Sergey Vinokurov 2018
+-- License : BSD3-style (see LICENSE)
+-- Maintainer : serg.foo@gmail.com
+----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Emacs.Module.Monad.Class
+ ( EmacsFunction
+ , EmacsFunctionExtra
+ , MonadEmacs(..)
+ ) where
+
+import Control.Exception.Safe.Checked (Throws)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import Data.Int
+import Data.Kind
+import Foreign.Ptr (Ptr)
+
+import Data.Emacs.Module.Args
+import Data.Emacs.Module.Env (UserPtrFinaliser)
+import Data.Emacs.Module.Env.Functions
+import Data.Emacs.Module.SymbolName (SymbolName)
+import Emacs.Module.Assert
+import Emacs.Module.Errors
+
+type EmacsFunction req opt rest (s :: k) (m :: k -> Type -> Type)
+ = (Throws EmacsThrow, Throws EmacsError, Throws EmacsInternalError, Throws UserError)
+ => EmacsArgs req opt rest (EmacsRef m s) -> m s (EmacsReturn m s)
+
+type EmacsFunctionExtra req opt rest extra (s :: k) (m :: k -> Type -> Type)
+ = (Throws EmacsThrow, Throws EmacsError, Throws EmacsInternalError, Throws UserError)
+ => EmacsArgs req opt rest (EmacsRef m s) -> Ptr extra -> m s (EmacsReturn m s)
+
+class MonadEmacs (m :: k -> Type -> Type) where
+
+ -- | Emacs value that is managed by the 'm' monad. Will be cleaned up
+ -- after 'm' finishes its execution.
+ type EmacsRef m :: k -> Type
+
+ -- | Type of values that Haskell functions may returns to Emacs.
+ type EmacsReturn m :: k -> Type
+
+ -- | Return an 'EmacsRef' back to Emacs.
+ produceRef :: EmacsRef m s -> m s (EmacsReturn m s)
+
+ -- | Check whether a non-local exit is pending.
+ nonLocalExitCheck :: WithCallStack => m s (FuncallExit ())
+
+ -- | Check whether a non-local exit is pending and get detailed data
+ -- in case it is.
+ nonLocalExitGet
+ :: WithCallStack
+ => m s (FuncallExit (EmacsRef m s, EmacsRef m s))
+
+ -- | Equivalent to Emacs's @signal@ function.
+ --
+ -- NB if a non-local exit is alredy pending, this function will not
+ -- overwrite it. In order to do that, use nonLocalExitClear.
+ nonLocalExitSignal
+ :: WithCallStack
+ => EmacsRef m s -- ^ Error symbol
+ -> [EmacsRef m s] -- ^ Error data, will be converted to a list as Emacs API expects.
+ -> m s ()
+
+ -- | Equivalent to Emacs's @throw@ function.
+ --
+ -- NB if a non-local exit is alredy pending, this function will not
+ -- overwrite it. In order to do that, use nonLocalExitClear.
+ nonLocalExitThrow
+ :: WithCallStack
+ => EmacsRef m s -- ^ Tag
+ -> EmacsRef m s -- ^ Data
+ -> m s ()
+
+ -- | Clean any pending local exits.
+ nonLocalExitClear :: WithCallStack => m s ()
+
+ -- | Make value eligible for collection during next GC within Emacs.
+ freeValue :: WithCallStack => EmacsRef m s -> m s ()
+
+ -- | Make Haskell function available as an anonymoucs Emacs
+ -- function. In order to be able to use it later from Emacs it should
+ -- be fed into 'bindFunction'.
+ --
+ -- NB Each call to this function produces a small memory leak that
+ -- will not be freed up. Hence, try not to create unbounded number
+ -- of functions. This happens because GHC has to generate some wrapping
+ -- code to convert between ccall and Haskell calling convention each time
+ -- a function is exported. It is possible to free this code after function
+ -- will not be used, but it's currently not supported.
+ makeFunctionExtra
+ :: (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)
+ => (forall s'. EmacsFunctionExtra req opt rest extra s' m) -- ^ Haskell function to export
+ -> C8.ByteString -- ^ Documentation
+ -> Ptr extra -- ^ Extra data to be passed to the Haskell function
+ -> m s (EmacsRef m s)
+
+ -- | Invoke an Emacs function that may call back into Haskell.
+ funcall
+ :: WithCallStack
+ => SymbolName -- ^ Function name
+ -> [EmacsRef m s] -- ^ Arguments
+ -> m s (EmacsRef m s)
+
+ -- | Invoke an Emacs function. The function should be simple and
+ -- must not call back into Haskell.
+ funcallPrimitive
+ :: WithCallStack
+ => SymbolName -- ^ Function name
+ -> [EmacsRef m s] -- ^ Arguments
+ -> m s (EmacsRef m s)
+
+ -- | Invoke an Emacs function and ignore its result. The function
+ -- should be simple and must not call back into Haskell.
+ funcallPrimitive_
+ :: WithCallStack
+ => SymbolName -- ^ Function name
+ -> [EmacsRef m s] -- ^ Arguments
+ -> m s ()
+
+ -- | Convert a string to an Emacs symbol.
+ intern
+ :: WithCallStack
+ => SymbolName
+ -> m s (EmacsRef m s)
+
+ -- | Get type of an Emacs value as an Emacs symbol.
+ typeOf
+ :: WithCallStack
+ => EmacsRef m s -> m s (EmacsRef m s)
+
+ -- | Check whether Emacs value is not @nil@.
+ isNotNil :: WithCallStack => EmacsRef m s -> m s Bool
+
+ -- | Primitive equality. Tests whether two symbols, integers or
+ -- characters are the equal, but not much more. For more complete
+ -- equality comparison do
+ --
+ -- > funcall [esym|equal|] [x, y]
+ eq
+ :: WithCallStack
+ => EmacsRef m s -> EmacsRef m s -> m s Bool
+
+
+ -- | Try to unpack a wide integer from a value.
+ extractWideInteger :: WithCallStack => EmacsRef m s -> m s Int64
+
+ -- | Pack a wide integer for Emacs.
+ makeWideInteger :: WithCallStack => Int64 -> m s (EmacsRef m s)
+
+ -- | Try to unpack a floating-point number from a value.
+ extractDouble :: WithCallStack => EmacsRef m s -> m s Double
+
+ -- | Convert a floating-point number into Emacs value.
+ makeDouble :: WithCallStack => Double -> m s (EmacsRef m s)
+
+ -- | Extract string contents from an Emacs value.
+ extractString :: WithCallStack => EmacsRef m s -> m s BS.ByteString
+
+ -- | Convert a utf8-encoded ByteString into an Emacs value.
+ makeString :: WithCallStack => BS.ByteString -> m s (EmacsRef m s)
+
+
+ -- | Extract a user pointer from an Emacs value.
+ extractUserPtr :: WithCallStack => EmacsRef m s -> m s (Ptr a)
+
+ -- | Pack a user pointer into an Emacs value.
+ makeUserPtr
+ :: WithCallStack
+ => UserPtrFinaliser a -- ^ Finalisation action that will be executed when user pointer gets garbage-collected by Emacs.
+ -> Ptr a
+ -> m s (EmacsRef m s)
+
+ -- | Set user pointer to a new value
+ assignUserPtr :: WithCallStack => EmacsRef m s -> Ptr a -> m s ()
+
+ -- | Extract a finaliser from an user_ptr.
+ extractUserPtrFinaliser
+ :: WithCallStack => EmacsRef m s -> m s (UserPtrFinaliser a)
+
+ -- | Assign new finaliser into an user_ptr.
+ assignUserPtrFinaliser
+ :: WithCallStack => EmacsRef m s -> UserPtrFinaliser a -> m s ()
+
+ -- | Extract an element from an Emacs vector.
+ vecGet :: WithCallStack => EmacsRef m s -> Int -> m s (EmacsRef m s)
+
+ -- | Assign an element into an Emacs vector.
+ vecSet
+ :: WithCallStack
+ => EmacsRef m s -- ^ Vector
+ -> Int -- ^ Index
+ -> EmacsRef m s -- ^ New value
+ -> m s ()
+
+ -- | Get size of an Emacs vector.
+ vecSize :: WithCallStack => EmacsRef m s -> m s Int