emacs-module 0.1.1.1 → 0.2

raw patch · 36 files changed

+2700/−1187 lines, 36 filesdep +filepathdep +monad-interleavedep +prettyprinter-combinatorsdep −resourcetdep −safe-exceptions-checkeddep ~basedep ~mtldep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, monad-interleave, prettyprinter-combinators, primitive, tuples-homogenous-h98

Dependencies removed: resourcet, safe-exceptions-checked

Dependency ranges changed: base, mtl, text, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +0/−6
• Changelog.md +40/−0
• Readme.md +59/−0
• Readme.org +0/−61
• cbits/emacs-module.h +615/−60
• emacs-module.cabal +54/−40
• src/Data/Emacs/Module/Args.hs +10/−19
• src/Data/Emacs/Module/Doc.hs +70/−0
• src/Data/Emacs/Module/Env.hs +3/−3
• src/Data/Emacs/Module/Env/Functions.hsc +17/−13
• src/Data/Emacs/Module/Env/ProcessInput.hsc +42/−0
• src/Data/Emacs/Module/GetRawValue.hs +25/−0
• src/Data/Emacs/Module/NonNullPtr.hs +16/−5
• src/Data/Emacs/Module/NonNullPtr/Internal.hs +2/−3
• src/Data/Emacs/Module/Raw/Env.hsc +134/−101
• src/Data/Emacs/Module/Raw/Env/Internal.hs +35/−16
• src/Data/Emacs/Module/Raw/Env/TH.hs +19/−16
• src/Data/Emacs/Module/Raw/Value.hs +7/−20
• src/Data/Emacs/Module/Raw/Value/Internal.hs +63/−0
• src/Data/Emacs/Module/Runtime.hsc +7/−9
• src/Data/Emacs/Module/SymbolName.hs +3/−1
• src/Data/Emacs/Module/SymbolName/Internal.hs +141/−14
• src/Data/Emacs/Module/SymbolName/Internal.hs-boot +21/−0
• src/Data/Emacs/Module/SymbolName/Predefined.hs +61/−0
• src/Data/Emacs/Module/SymbolName/Predefined/Funcall.hs +32/−0
• src/Data/Emacs/Module/SymbolName/TH.hs +24/−22
• src/Data/Emacs/Module/Value.hs +1/−3
• src/Data/Emacs/Module/Value/Internal.hs +28/−11
• src/Emacs/Module.hs +23/−37
• src/Emacs/Module/Assert.hs +4/−6
• src/Emacs/Module/Errors.hs +84/−50
• src/Emacs/Module/Functions.hs +194/−201
• src/Emacs/Module/Monad.hs +314/−373
• src/Emacs/Module/Monad/Class.hs +94/−97
• src/Emacs/Module/Monad/Common.hs +333/−0
• src/Foreign/Ptr/Builder.hs +125/−0

@@ -1,6 +0,0 @@-0.1.1.1--- Fix build with GHC 9.0+-- Switch license from BSD 3 to Apache 2.0-- Bump minimum required GHC to 8.10-- Bump minimum `prettyprinter` to 1.7

@@ -0,0 +1,40 @@+# 0.2++- Major rework of the package’s core++- Bump minimum required Emacs version to 28 due to exposing `process_input` from API. It allows to check whether user wants to abort and control should be returned back to Emacs ASAP++- Bump minimum required `base` version to 4.14 - minimum supported GHC is 8.10++- Symbols can be either statically known or dynamically known. This is mostly an optimization that doesn’t affect symbol use but client code may require updating. Statically known symbol are just pointers to statically allocated (by GHC) bytes and the pointers are simply passed to Emacs to create symbols.++- Some commonly used symbols are now cached on first use so they won’t be re-interned on subsequent uses. New symbols can be defined by users.++- `makeFunction` now cleans up after itself and no longer has memory leak if called a lot of times (which shouldn’t have typically happened anyway but still nice to have just in case)++- `makeFunctionExtra` and `EmacsFunctionExtra` are gone. They offered to pass extra pointer into subroutine exposed to Emacs but it was never needed since arbitrary closure can be exposed. Now extra pointer is used to clean up result of `makeFunction`.++- Removed `extractUnboxedVectorWith` - now regular `extractVector` produces generic vectors++- Removed `extractVector` - `extractVectorWith` and similar for other vector/array types are preferable since they’re guaranteed to not create intermediate vectors/arrays++- Introduce dedicated `Doc` type for function documentation that can be constructed from unboxed string literals to just pass the pointer around++- `produceRef` and `EmacsReturn` are gone - vanilla `pure` and `EmacsRef` are enough++- Symbol names got `IsString` instance and can be defined as string constants++- Removed `UserPtrFinaliser` and `UserPtrFinaliserType`. Use `Foreign.ForeignPtr.FinalizerPtr` instead++- `GlobalRef` got removed, instead `RawValue` is indexed by whether it’s going to be GC’ed after returning control back to Emacs++- `funcall` and `funcallPrimitive` now accept any emacs value function rather than symbols only++- `extractString` removed, `extractText` is now part of `MonadEmacs` typeclass++# 0.1.1.1++- Fix build with GHC 9.0++- Switch license from BSD 3 to Apache 2.0+- Bump minimum required GHC to 8.10+- Bump minimum `prettyprinter` to 1.7

@@ -0,0 +1,59 @@+# A Haskell package for writing Emacs modules++## Why would anyone want to write Emacs modules in Haskell?+Emacs Lisp is not a young language and can go quite a long way, but+it has a couple of issues that are not going to be solved any time soon:++- It’s dynamically typed which makes refactoring large extensions a pain+- It’s intepreted and is quite slow. It might be argued that editors don’t+  need much computing power, but from time to time computation-intensive+  tasks do occur. For example, fuzzy matching provided by the cool+  [flx.el](https://github.com/lewang/flx) package and used by great+  [ivy.el](https://github.com/abo-abo/swiper) package to quickly find things.+- Somewhat related to the previous point, there’s virtually no support+  for parallelising computations. There’re [adavances](https://www.gnu.org/software/emacs/draft/manual/html_node/elisp/Threads.html) on adding threads+  to Emacs lisp, but this only provides [concurrency, but no parallelism](https://stackoverflow.com/questions/1050222/what-is-the-difference-between-concurrency-and-parallelism).++  Haskell is well known for solving points 1 and 3 outlined above.+  For me it also solves point 2 by providing enough performance and adding+  parallelism on top of it.++  If you think this might be a good idea and would like to see what+  this package can do for you, you can look at part of+  [my emacs config](https://github.com/sergv/emacs-native/tree/master/lib/Emacs)+  that uses this package to implement things like++  + Rewrite of `flx.el` that leverages parallelism+  + Fast search across filesystem+  + Concurrrent grep reimplementation (somewhat dubious since things like `ripgrep` exist)++## FAQ+### How do I start writing my own extensions?+Some day there will be a proper tutorial for using this package.+For the time being the best place to start is+[this package’s tests](https://github.com/sergv/emacs-module/blob/master/test/src/Emacs/TestsInit.hs).++### What about Windows?+It works, Cabal can build a dll for you.++### How it’s related to [haskell-emacs](https://github.com/knupfer/haskell-emacs)?+The `haskell-emacs` aims to address the same problem - writing Emacs+extensions in Haskell, but uses different approach. It seems to use+some kind of marshalling scheme to make Emacs data available in+Haskell with a caveat that not all Emacs types can be converted (e.g.+buffers cannot be typically serialised). Presumably, an extension+built with this project will look like an executable that reads sexps+from stdin and produces output on stdout. Or, possibly, as a daemon+process that communicates with Emacs over network.++This project is a bit different. It wraps Emacs C API for writing new+extensions that can manipulate Emacs values directly, without+marhsalling. In this approach, an extension will look like a shared+library/dll that can be loaded by standard emacs with `(load "/tmp/libmy-ext.so")`.++### Is there a tutorial?+It’s at https://github.com/sergv/emacs-module/blob/master/Tutorial.md.++## Supported GHC versions++Tested with GHC `9.2`, `9.4`, `9.6`.

@@ -1,61 +0,0 @@-#+STARTUP: content--* A Haskell package for writing Emacs modules--[[https://img.shields.io/badge/license-BSD_3-green.svg?dummy]]-[[https://travis-ci.org/sergv/emacs-module][https://travis-ci.org/sergv/emacs-module.svg?branch=master]]--** Why would anyone want to write Emacs modules in Haskell?-Emacs Lisp is not a young language and can go quite a long way, but-it has a couple of issues that are not going to be solved any time soon:--    - It’s dynamically typed which makes refactoring large extensions a pain-    - It’s intepreted and is quite slow. It might be argued that editors don’t-      need much computing power, but from time to time computation-intensive-      tasks do occur. For example, fuzzy matching provided by the cool-      [[https://github.com/lewang/flx][flx.el]] package and used by great-      [[https://github.com/abo-abo/swiper][ivy.el]] package to quickly find things.-    - Somewhat related to the previous point, there’s virtually no support-      for parallelising computations. There’re [[https://www.gnu.org/software/emacs/draft/manual/html_node/elisp/Threads.html][adavances]] on adding threads-      to Emacs lisp, but this only provides [[https://stackoverflow.com/questions/1050222/what-is-the-difference-between-concurrency-and-parallelism][concurrency, but no parallelism]].--      Haskell is well known for solving points 1 and 3 outlined above.-      For me it also solves point 2 by providing enough performance and adding-      parallelism on top of it.--      If you think this might be a good idea and would like to see what-      this package can do for you, you can look at part of-      [[https://github.com/sergv/emacs-native/tree/master/lib/Emacs][my emacs config]]-      that uses this package to implement things like--      - Rewrite of ~flx.el~ that leverages parallelism-      - Fast search across filesystem-      - Concurrrent grep reimplementation (yeah, it’s dubious since things like ~ripgrep~ exist)--** FAQ-*** How do I start writing my own extensions?-Some day there will be a proper tutorial for using this package.-For the time being the best place to start is-[[https://github.com/sergv/emacs-module/blob/master/test/src/Emacs/TestsInit.hs][this package’s tests]].--*** What about Windows?-It works, Cabal can build a dll for you.--*** How it’s related to [[https://github.com/knupfer/haskell-emacs][haskell-emacs]]?-The ~haskell-emacs~ aims to address the same problem - writing Emacs-extensions in Haskell, but uses different approach. It seems to use-some kind of marshalling scheme to make Emacs data available in-Haskell with a caveat that not all Emacs types can be converted (e.g.-buffers cannot be typically serialised). Presumably, an extension-built with this project will look like an executable that reads sexps-from stdin and produces output on stdout. Or, possibly, as a daemon-process that communicates with Emacs over network.--This project is a bit different. It wraps Emacs C API for writing new-extensions that can manipulate Emacs values directly, without-marhsalling. In this approach, an extension will look like a shared-library/dll that can be loaded by standard emacs with ~(load "/tmp/libmy-ext.so")~.--** Supported GHC versions--Tested with GHC ~8.0.2~, ~8.2.2~, ~8.4.4~, ~8.6.3~.

@@ -1,6 +1,6 @@ /* emacs-module.h - GNU Emacs module API. -Copyright (C) 2015-2017 Free Software Foundation, Inc.+Copyright (C) 2015-2022 Free Software Foundation, Inc.  This file is part of GNU Emacs. @@ -15,33 +15,66 @@ 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 <http://www.gnu.org/licenses/>.  */+along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */ +/*+This file defines the Emacs module API.  Please see the chapter+`Dynamic Modules' in the GNU Emacs Lisp Reference Manual for+information how to write modules and use this header file.+*/+ #ifndef EMACS_MODULE_H #define EMACS_MODULE_H -#include <stdint.h> #include <stddef.h>+#include <stdint.h>+#include <time.h>++#ifndef __cplusplus #include <stdbool.h>+#endif +#define EMACS_MAJOR_VERSION 28+ #if defined __cplusplus && __cplusplus >= 201103L # define EMACS_NOEXCEPT noexcept #else # define EMACS_NOEXCEPT #endif +#if defined __cplusplus && __cplusplus >= 201703L+# define EMACS_NOEXCEPT_TYPEDEF noexcept+#else+# define EMACS_NOEXCEPT_TYPEDEF+#endif++#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__)+# define EMACS_ATTRIBUTE_NONNULL(...) \+   __attribute__ ((__nonnull__ (__VA_ARGS__)))+#elif (defined __has_attribute \+       && (!defined __clang_minor__ \+	   || 3 < __clang_major__ + (5 <= __clang_minor__)))+# if __has_attribute (__nonnull__)+#  define EMACS_ATTRIBUTE_NONNULL(...) \+    __attribute__ ((__nonnull__ (__VA_ARGS__)))+# endif+#endif+#ifndef EMACS_ATTRIBUTE_NONNULL+# define EMACS_ATTRIBUTE_NONNULL(...)+#endif+ #ifdef __cplusplus extern "C" { #endif  /* Current environment.  */-typedef struct emacs_env_25 emacs_env;+typedef struct emacs_env_28 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 };+enum { emacs_variadic_function = -2 };  /* Struct passed to a module init function (emacs_module_init).  */ struct emacs_runtime@@ -53,16 +86,25 @@   struct emacs_runtime_private *private_members;    /* Return an environment pointer.  */-  emacs_env *(*get_environment) (struct emacs_runtime *ert);+  emacs_env *(*get_environment) (struct emacs_runtime *runtime)+    EMACS_ATTRIBUTE_NONNULL (1); }; +/* Type aliases for function pointer types used in the module API.+   Note that we don't use these aliases directly in the API to be able+   to mark the function arguments as 'noexcept' before C++20.+   However, users can use them if they want.  */ -/* Function prototype for the module init function.  */-typedef int (*emacs_init_function) (struct emacs_runtime *ert);+/* Function prototype for the module Lisp functions.  These must not+   throw C++ exceptions.  */+typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs,+                                       emacs_value *args,+                                       void *data)+  EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); -/* Function prototype for the module Lisp functions.  */-typedef emacs_value (*emacs_subr) (emacs_env *env, ptrdiff_t nargs,-				   emacs_value args[], void *data);+/* Function prototype for module user-pointer and function finalizers.+   These must not throw C++ exceptions.  */+typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF;  /* Possible Emacs function call outcomes.  */ enum emacs_funcall_exit@@ -74,9 +116,27 @@   emacs_funcall_exit_signal = 1,    /* Function has exit using `throw'.  */-  emacs_funcall_exit_throw = 2,+  emacs_funcall_exit_throw = 2 }; +/* Possible return values for emacs_env.process_input.  */+enum emacs_process_input_result+{+  /* Module code may continue  */+  emacs_process_input_continue = 0,++  /* Module code should return control to Emacs as soon as possible.  */+  emacs_process_input_quit = 1+};++/* Define emacs_limb_t so that it is likely to match GMP's mp_limb_t.+   This micro-optimization can help modules that use mpz_export and+   mpz_import, which operate more efficiently on mp_limb_t.  It's OK+   (if perhaps a bit slower) if the two types do not match, and+   modules shouldn't rely on the two types matching.  */+typedef size_t emacs_limb_t;+#define EMACS_LIMB_MAX SIZE_MAX+ struct emacs_env_25 {   /* Structure size (for version checking).  */@@ -87,75 +147,85 @@    /* Memory management.  */ -  emacs_value (*make_global_ref) (emacs_env *env,-				  emacs_value any_reference);+  emacs_value (*make_global_ref) (emacs_env *env, emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1); -  void (*free_global_ref) (emacs_env *env,-			   emacs_value global_reference);+  void (*free_global_ref) (emacs_env *env, emacs_value global_value)+    EMACS_ATTRIBUTE_NONNULL(1);    /* Non-local exit handling.  */ -  enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env);+  enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1); -  void (*non_local_exit_clear) (emacs_env *env);+  void (*non_local_exit_clear) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);    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);+    (emacs_env *env, emacs_value *symbol, emacs_value *data)+    EMACS_ATTRIBUTE_NONNULL(1, 2, 3);    void (*non_local_exit_signal) (emacs_env *env,-				 emacs_value non_local_exit_symbol,-				 emacs_value non_local_exit_data);+				 emacs_value symbol, emacs_value data)+    EMACS_ATTRIBUTE_NONNULL(1);    void (*non_local_exit_throw) (emacs_env *env,-				emacs_value tag,-				emacs_value value);+				emacs_value tag, emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);    /* 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 (*func) (emacs_env *env,+                                                     ptrdiff_t nargs,+                                                     emacs_value* args,+                                                     void *data)+				  EMACS_NOEXCEPT+                                  EMACS_ATTRIBUTE_NONNULL(1),+				const char *docstring,+				void *data)+    EMACS_ATTRIBUTE_NONNULL(1, 4);    emacs_value (*funcall) (emacs_env *env,-                          emacs_value function,+                          emacs_value func,                           ptrdiff_t nargs,-                          emacs_value args[]);+                          emacs_value* args)+    EMACS_ATTRIBUTE_NONNULL(1); -  emacs_value (*intern) (emacs_env *env,-                         const char *symbol_name);+  emacs_value (*intern) (emacs_env *env, const char *name)+    EMACS_ATTRIBUTE_NONNULL(1, 2);    /* Type conversion.  */ -  emacs_value (*type_of) (emacs_env *env,-			  emacs_value value);+  emacs_value (*type_of) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1); -  bool (*is_not_nil) (emacs_env *env, emacs_value value);+  bool (*is_not_nil) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1); -  bool (*eq) (emacs_env *env, emacs_value a, emacs_value b);+  bool (*eq) (emacs_env *env, emacs_value a, emacs_value b)+    EMACS_ATTRIBUTE_NONNULL(1); -  intmax_t (*extract_integer) (emacs_env *env, emacs_value value);+  intmax_t (*extract_integer) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1); -  emacs_value (*make_integer) (emacs_env *env, intmax_t value);+  emacs_value (*make_integer) (emacs_env *env, intmax_t n)+    EMACS_ATTRIBUTE_NONNULL(1); -  double (*extract_float) (emacs_env *env, emacs_value value);+  double (*extract_float) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1); -  emacs_value (*make_float) (emacs_env *env, double value);+  emacs_value (*make_float) (emacs_env *env, double d)+    EMACS_ATTRIBUTE_NONNULL(1);    /* 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.+     to SIZE and return true.       Note that SIZE must include the last null byte (e.g. "abc" needs      a buffer of size 4).@@ -164,38 +234,523 @@    bool (*copy_string_contents) (emacs_env *env,                                 emacs_value value,-                                char *buffer,-                                ptrdiff_t *size_inout);+                                char *buf,+                                ptrdiff_t *len)+    EMACS_ATTRIBUTE_NONNULL(1, 4);    /* Create a Lisp string from a utf8 encoded string.  */   emacs_value (*make_string) (emacs_env *env,-			      const char *contents, ptrdiff_t length);+			      const char *str, ptrdiff_t len)+    EMACS_ATTRIBUTE_NONNULL(1, 2);    /* Embedded pointer type.  */   emacs_value (*make_user_ptr) (emacs_env *env, 				void (*fin) (void *) EMACS_NOEXCEPT,-				void *ptr);+				void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1); -  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_ptr) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);    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);+    (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_finalizer) (emacs_env *env, emacs_value arg,+			      void (*fin) (void *) EMACS_NOEXCEPT)+    EMACS_ATTRIBUTE_NONNULL(1);    /* Vector functions.  */-  emacs_value (*vec_get) (emacs_env *env, emacs_value vec, ptrdiff_t i);+  emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index)+    EMACS_ATTRIBUTE_NONNULL(1); -  void (*vec_set) (emacs_env *env, emacs_value vec, ptrdiff_t i,-		   emacs_value val);+  void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index,+		   emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1); -  ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vec);+  ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector)+    EMACS_ATTRIBUTE_NONNULL(1); }; +struct emacs_env_26+{+  /* 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 value)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*free_global_ref) (emacs_env *env, emacs_value global_value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Non-local exit handling.  */++  enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_clear) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  enum emacs_funcall_exit (*non_local_exit_get)+    (emacs_env *env, emacs_value *symbol, emacs_value *data)+    EMACS_ATTRIBUTE_NONNULL(1, 2, 3);++  void (*non_local_exit_signal) (emacs_env *env,+				 emacs_value symbol, emacs_value data)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_throw) (emacs_env *env,+				emacs_value tag, emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Function registration.  */++  emacs_value (*make_function) (emacs_env *env,+				ptrdiff_t min_arity,+				ptrdiff_t max_arity,+				emacs_value (*func) (emacs_env *env,+                                                     ptrdiff_t nargs,+                                                     emacs_value* args,+                                                     void *data)+				  EMACS_NOEXCEPT+                                  EMACS_ATTRIBUTE_NONNULL(1),+				const char *docstring,+				void *data)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  emacs_value (*funcall) (emacs_env *env,+                          emacs_value func,+                          ptrdiff_t nargs,+                          emacs_value* args)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*intern) (emacs_env *env, const char *name)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Type conversion.  */++  emacs_value (*type_of) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*is_not_nil) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*eq) (emacs_env *env, emacs_value a, emacs_value b)+    EMACS_ATTRIBUTE_NONNULL(1);++  intmax_t (*extract_integer) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_integer) (emacs_env *env, intmax_t n)+    EMACS_ATTRIBUTE_NONNULL(1);++  double (*extract_float) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_float) (emacs_env *env, double d)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* 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.  */++  bool (*copy_string_contents) (emacs_env *env,+                                emacs_value value,+                                char *buf,+                                ptrdiff_t *len)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  /* Create a Lisp string from a utf8 encoded string.  */+  emacs_value (*make_string) (emacs_env *env,+			      const char *str, ptrdiff_t len)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Embedded pointer type.  */+  emacs_value (*make_user_ptr) (emacs_env *env,+				void (*fin) (void *) EMACS_NOEXCEPT,+				void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void *(*get_user_ptr) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr))+    (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_finalizer) (emacs_env *env, emacs_value arg,+			      void (*fin) (void *) EMACS_NOEXCEPT)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Vector functions.  */+  emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index,+		   emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Returns whether a quit is pending.  */+  bool (*should_quit) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);+};++struct emacs_env_27+{+  /* 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 value)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*free_global_ref) (emacs_env *env, emacs_value global_value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Non-local exit handling.  */++  enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_clear) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  enum emacs_funcall_exit (*non_local_exit_get)+    (emacs_env *env, emacs_value *symbol, emacs_value *data)+    EMACS_ATTRIBUTE_NONNULL(1, 2, 3);++  void (*non_local_exit_signal) (emacs_env *env,+				 emacs_value symbol, emacs_value data)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_throw) (emacs_env *env,+				emacs_value tag, emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Function registration.  */++  emacs_value (*make_function) (emacs_env *env,+				ptrdiff_t min_arity,+				ptrdiff_t max_arity,+				emacs_value (*func) (emacs_env *env,+                                                     ptrdiff_t nargs,+                                                     emacs_value* args,+                                                     void *data)+				  EMACS_NOEXCEPT+                                  EMACS_ATTRIBUTE_NONNULL(1),+				const char *docstring,+				void *data)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  emacs_value (*funcall) (emacs_env *env,+                          emacs_value func,+                          ptrdiff_t nargs,+                          emacs_value* args)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*intern) (emacs_env *env, const char *name)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Type conversion.  */++  emacs_value (*type_of) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*is_not_nil) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*eq) (emacs_env *env, emacs_value a, emacs_value b)+    EMACS_ATTRIBUTE_NONNULL(1);++  intmax_t (*extract_integer) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_integer) (emacs_env *env, intmax_t n)+    EMACS_ATTRIBUTE_NONNULL(1);++  double (*extract_float) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_float) (emacs_env *env, double d)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* 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.  */++  bool (*copy_string_contents) (emacs_env *env,+                                emacs_value value,+                                char *buf,+                                ptrdiff_t *len)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  /* Create a Lisp string from a utf8 encoded string.  */+  emacs_value (*make_string) (emacs_env *env,+			      const char *str, ptrdiff_t len)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Embedded pointer type.  */+  emacs_value (*make_user_ptr) (emacs_env *env,+				void (*fin) (void *) EMACS_NOEXCEPT,+				void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void *(*get_user_ptr) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr))+    (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_finalizer) (emacs_env *env, emacs_value arg,+			      void (*fin) (void *) EMACS_NOEXCEPT)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Vector functions.  */+  emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index,+		   emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Returns whether a quit is pending.  */+  bool (*should_quit) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Processes pending input events and returns whether the module+     function should quit.  */+  enum emacs_process_input_result (*process_input) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL (1);++  struct timespec (*extract_time) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL (1);++  emacs_value (*make_time) (emacs_env *env, struct timespec time)+    EMACS_ATTRIBUTE_NONNULL (1);++  bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign,+                               ptrdiff_t *count, emacs_limb_t *magnitude)+    EMACS_ATTRIBUTE_NONNULL (1);++  emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count,+                                   const emacs_limb_t *magnitude)+    EMACS_ATTRIBUTE_NONNULL (1);+};++struct emacs_env_28+{+  /* 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 value)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*free_global_ref) (emacs_env *env, emacs_value global_value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Non-local exit handling.  */++  enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_clear) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  enum emacs_funcall_exit (*non_local_exit_get)+    (emacs_env *env, emacs_value *symbol, emacs_value *data)+    EMACS_ATTRIBUTE_NONNULL(1, 2, 3);++  void (*non_local_exit_signal) (emacs_env *env,+				 emacs_value symbol, emacs_value data)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*non_local_exit_throw) (emacs_env *env,+				emacs_value tag, emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Function registration.  */++  emacs_value (*make_function) (emacs_env *env,+				ptrdiff_t min_arity,+				ptrdiff_t max_arity,+				emacs_value (*func) (emacs_env *env,+                                                     ptrdiff_t nargs,+                                                     emacs_value* args,+                                                     void *data)+				  EMACS_NOEXCEPT+                                  EMACS_ATTRIBUTE_NONNULL(1),+				const char *docstring,+				void *data)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  emacs_value (*funcall) (emacs_env *env,+                          emacs_value func,+                          ptrdiff_t nargs,+                          emacs_value* args)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*intern) (emacs_env *env, const char *name)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Type conversion.  */++  emacs_value (*type_of) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*is_not_nil) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  bool (*eq) (emacs_env *env, emacs_value a, emacs_value b)+    EMACS_ATTRIBUTE_NONNULL(1);++  intmax_t (*extract_integer) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_integer) (emacs_env *env, intmax_t n)+    EMACS_ATTRIBUTE_NONNULL(1);++  double (*extract_float) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);++  emacs_value (*make_float) (emacs_env *env, double d)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* 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.  */++  bool (*copy_string_contents) (emacs_env *env,+                                emacs_value value,+                                char *buf,+                                ptrdiff_t *len)+    EMACS_ATTRIBUTE_NONNULL(1, 4);++  /* Create a Lisp string from a utf8 encoded string.  */+  emacs_value (*make_string) (emacs_env *env,+			      const char *str, ptrdiff_t len)+    EMACS_ATTRIBUTE_NONNULL(1, 2);++  /* Embedded pointer type.  */+  emacs_value (*make_user_ptr) (emacs_env *env,+				void (*fin) (void *) EMACS_NOEXCEPT,+				void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void *(*get_user_ptr) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr))+    (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1);+  void (*set_user_finalizer) (emacs_env *env, emacs_value arg,+			      void (*fin) (void *) EMACS_NOEXCEPT)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Vector functions.  */+  emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index)+    EMACS_ATTRIBUTE_NONNULL(1);++  void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index,+		   emacs_value value)+    EMACS_ATTRIBUTE_NONNULL(1);++  ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Returns whether a quit is pending.  */+  bool (*should_quit) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL(1);++  /* Processes pending input events and returns whether the module+     function should quit.  */+  enum emacs_process_input_result (*process_input) (emacs_env *env)+    EMACS_ATTRIBUTE_NONNULL (1);++  struct timespec (*extract_time) (emacs_env *env, emacs_value arg)+    EMACS_ATTRIBUTE_NONNULL (1);++  emacs_value (*make_time) (emacs_env *env, struct timespec time)+    EMACS_ATTRIBUTE_NONNULL (1);++  bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign,+                               ptrdiff_t *count, emacs_limb_t *magnitude)+    EMACS_ATTRIBUTE_NONNULL (1);++  emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count,+                                   const emacs_limb_t *magnitude)+    EMACS_ATTRIBUTE_NONNULL (1);++  void (*(*EMACS_ATTRIBUTE_NONNULL (1)+            get_function_finalizer) (emacs_env *env,+                                     emacs_value arg)) (void *) EMACS_NOEXCEPT;++  void (*set_function_finalizer) (emacs_env *env, emacs_value arg,+                                  void (*fin) (void *) EMACS_NOEXCEPT)+    EMACS_ATTRIBUTE_NONNULL (1);++  int (*open_channel) (emacs_env *env, emacs_value pipe_process)+    EMACS_ATTRIBUTE_NONNULL (1);++  void (*make_interactive) (emacs_env *env, emacs_value function,+                            emacs_value spec)+    EMACS_ATTRIBUTE_NONNULL (1);++  /* Create a unibyte Lisp string from a string.  */+  emacs_value (*make_unibyte_string) (emacs_env *env,+				      const char *str, ptrdiff_t len)+    EMACS_ATTRIBUTE_NONNULL(1, 2);+};+ /* Every module should define a function as follows.  */-extern int emacs_module_init (struct emacs_runtime *ert);+extern int emacs_module_init (struct emacs_runtime *runtime)+  EMACS_NOEXCEPT+  EMACS_ATTRIBUTE_NONNULL (1);  #ifdef __cplusplus }

@@ -3,7 +3,7 @@ name:   emacs-module version:-  0.1.1.1+  0.2 category: Foreign, Foreign binding  synopsis:@@ -12,12 +12,14 @@ description:   This package provides a full set of bindings to emacs-module.h that   allows to develop Emacs modules in Haskell. Bindings are based on-  Emacs 25 version of the interface and thus should work in all-  subsequent versions of Emacs.+  Emacs 28 version of the interface and thus should work in all+  subsequent versions of Emacs, but will now work with earlier versions. -  For pointers on how to write minimal Emacs module, please refer-  to https://github.com/sergv/emacs-module/blob/master/test/src/Emacs/TestsInit.hs+  For pointers on how to write minimal Emacs module, please refer to+  tutorial https://github.com/sergv/emacs-module/blob/master/Tutorial.md. +  Entry point: Emacs.Module module.+ license:   Apache-2.0 license-file:@@ -27,12 +29,13 @@ maintainer:   Sergey Vinokurov <serg.foo@gmail.com> tested-with:-    GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2+    GHC == 9.2.7, GHC == 9.4.5, GHC == 9.6.1 extra-source-files:   cbits/emacs-module.h  extra-source-files:-  Readme.org ChangeLog.md+  Changelog.md+  Readme.md  build-type:   Simple@@ -40,24 +43,20 @@ homepage: https://github.com/sergv/emacs-module  source-repository head-    type: git-    location: https://github.com/sergv/emacs-module.git-+  type: git+  location: https://github.com/sergv/emacs-module.git -flag assertions+flag call-stacks   description:-    Enable runtime assertions+    Enable call stacks   default:     False   manual:     True -flag module-assertions+flag assertions   description:-    Build a plugin that is intended to be used with Emacs's-    '--module-assertions' flag enabled. Plugin will not free any-    global values returned to Emacs and thus have an ever-growing-    memory leak.+    Enable runtime assertions   default:     False   manual:@@ -65,19 +64,23 @@  common ghc-options   default-language:-    Haskell2010+    GHC2021 +  default-extensions:+    ImportQualifiedPost+    LambdaCase+   ghc-options:     -Weverything-    -Wno-redundant-constraints-    -Wno-type-defaults+    -Wno-all-missed-specialisations     -Wno-implicit-prelude-    -Wno-missing-local-signatures-    -Wno-missing-import-lists     -Wno-missed-specialisations-    -Wno-all-missed-specialisations-    -Wno-safe+    -Wno-missing-import-lists+    -Wno-missing-local-signatures     -Wno-missing-safe-haskell-mode+    -Wno-redundant-constraints+    -Wno-safe+    -Wno-type-defaults     -Wno-unsafe    if impl(ghc >= 8.8)@@ -90,17 +93,22 @@  library   import: ghc-options+  if flag(call-stacks)+    cpp-options: -DCALL_STACKS   if flag(assertions)     cpp-options: -DASSERTIONS-  if flag(module-assertions)-    cpp-options: -DMODULE_ASSERTIONS   exposed-modules:     Data.Emacs.Module.Args+    Data.Emacs.Module.Doc     Data.Emacs.Module.Env     Data.Emacs.Module.Env.Functions+    Data.Emacs.Module.Env.ProcessInput+    Data.Emacs.Module.GetRawValue     Data.Emacs.Module.NonNullPtr     Data.Emacs.Module.Runtime     Data.Emacs.Module.SymbolName+    Data.Emacs.Module.SymbolName.Predefined+    Data.Emacs.Module.SymbolName.Predefined.Funcall     Data.Emacs.Module.SymbolName.TH     Data.Emacs.Module.Value     Emacs.Module@@ -115,25 +123,31 @@     Data.Emacs.Module.Raw.Env.Internal     Data.Emacs.Module.Raw.Env.TH     Data.Emacs.Module.Raw.Value+    Data.Emacs.Module.Raw.Value.Internal     Data.Emacs.Module.SymbolName.Internal     Data.Emacs.Module.Value.Internal+    Emacs.Module.Monad.Common+    Foreign.Ptr.Builder   hs-source-dirs:     src   build-depends:-    base >=4.14 && <5,-    bytestring,-    deepseq,-    exceptions,-    monad-control,-    mtl,-    prettyprinter >=1.7,-    resourcet,-    safe-exceptions-checked,-    text,-    template-haskell,-    transformers-base,-    vector,-    void+    , base >= 4.16 && < 5+    , bytestring+    , deepseq+    , exceptions+    , filepath >= 1.4.100+    , monad-control+    , monad-interleave >= 0.2+    , mtl >= 2.3+    , primitive+    , prettyprinter >= 1.7+    , prettyprinter-combinators+    , text >= 2+    , template-haskell+    , transformers-base+    , tuples-homogenous-h98+    , vector >= 0.13+    , void    includes:     emacs-module.h

@@ -7,18 +7,9 @@ ----------------------------------------------------------------------------  {-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE GADTs                  #-}-{-# LANGUAGE InstanceSigs           #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-}  module Data.Emacs.Module.Args@@ -94,8 +85,8 @@   supplyEmacsArgs     :: MonadBase IO m     => Int-    -> Ptr RawValue-    -> (RawValue -> m a)+    -> Ptr (RawValue 'Regular)+    -> (RawValue 'Regular -> m a)     -> (EmacsArgs req opt rest a -> m b)     -> m b @@ -108,8 +99,8 @@   supplyEmacsArgs     :: MonadBase IO m     => Int-    -> Ptr RawValue-    -> (RawValue -> m a)+    -> Ptr (RawValue 'Regular)+    -> (RawValue 'Regular -> m a)     -> (Rest a -> m b)     -> m b   supplyEmacsArgs nargs startPtr mkArg f =@@ -118,17 +109,17 @@       n -> f . Rest =<< traverse mkArg =<< liftBase (peekArray n startPtr)  {-# INLINE advanceEmacsValuePtr #-}-advanceEmacsValuePtr :: Ptr RawValue -> Ptr RawValue+advanceEmacsValuePtr :: forall p. Ptr (RawValue p) -> Ptr (RawValue p) advanceEmacsValuePtr =-  (`plusPtr` (sizeOf (undefined :: RawValue)))+  (`plusPtr` (sizeOf (undefined :: RawValue p)))  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)+    -> Ptr (RawValue 'Regular)+    -> (RawValue 'Regular -> m a)     -> (O a (EmacsArgs 'Z n rest a) -> m b)     -> m b   supplyEmacsArgs nargs startPtr mkArg f =@@ -147,8 +138,8 @@   supplyEmacsArgs     :: MonadBase IO m     => Int-    -> Ptr RawValue-    -> (RawValue -> m a)+    -> Ptr (RawValue 'Regular)+    -> (RawValue 'Regular -> m a)     -> (R a (EmacsArgs n opt rest a) -> m b)     -> m b   supplyEmacsArgs nargs startPtr mkArg f = do

@@ -0,0 +1,70 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.Doc+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+--+-- Defines type that provides function's documentation that would be visible+-- in Emacs.+----------------------------------------------------------------------------++{-# LANGUAGE MagicHash #-}++module Data.Emacs.Module.Doc+  ( Doc+  , mkLiteralDoc+  , mkTextDoc+  , useDocAsCString+  ) where++import Data.String+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Foreign qualified as T+import Foreign.C.String+import GHC.Exts++data Doc+  = StaticDoc Addr#+  | DynamicDoc !Text++instance Show Doc where+  show = \case+    DynamicDoc x   -> show x+    StaticDoc addr -> show (unpackCString# addr)++instance IsString Doc where+  {-# INLINE fromString #-}+  fromString = mkStringDoc++mkStringDoc :: String -> Doc+mkStringDoc = mkTextDoc . T.pack++{-# INLINE [0] mkStringDoc #-}++{-# RULES+"Doc string literal" forall s .+   mkStringDoc (unpackCString# s) = mkLiteralDoc s+ #-}++-- | Indended to be used with unboxed string literals like this+--+-- @+-- mkLiteralDoc "foo"#+-- @+{-# INLINE mkLiteralDoc #-}+mkLiteralDoc :: Addr# -> Doc+mkLiteralDoc = StaticDoc++-- | Turn abritrary bytestring into 'Doc'.+{-# INLINE mkTextDoc #-}+mkTextDoc :: Text -> Doc+mkTextDoc = DynamicDoc++{-# INLINE useDocAsCString #-}+useDocAsCString :: Doc -> (CString -> IO a) -> IO a+useDocAsCString doc f = case doc of+  StaticDoc addr -> f (Ptr addr)+  DynamicDoc str -> T.withCString str f+

@@ -18,8 +18,6 @@    , -- * Wrappers around struct emacs_env fields     EnumFuncallExit(..)-  , UserPtrFinaliserType-  , UserPtrFinaliser   , isValidEnv    , makeGlobalRef@@ -64,10 +62,12 @@   , freeStablePtrFinaliser   ) where +import Foreign.ForeignPtr (FinalizerPtr)+ 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+foreign import ccall "& hs_free_stable_ptr" freeStablePtrFinaliser :: FinalizerPtr a

@@ -6,31 +6,22 @@ -- 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+  , foldFuncallExitFromNum   ) where  import Data.Data (Data)-import GHC.Generics (Generic) import Language.Haskell.TH.Syntax (Lift)+import Prettyprinter.Generics  #include <emacs-module.h>  -- | Possible Emacs function call outcomes. This is Haskell's version of-data FuncallExit a =-    -- | Function has returned normally.+data FuncallExit a+  = -- | Function has returned normally.     FuncallExitReturn   | -- | Function has signaled an error using @signal@.     FuncallExitSignal a@@ -38,16 +29,29 @@     FuncallExitThrow a   deriving (Eq, Ord, Show, Data, Generic, Lift, Functor, Foldable, Traversable) +instance Pretty a => Pretty (FuncallExit a) where+  pretty = ppGeneric++{-# INLINE funcallExitToNum #-} 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) +{-# INLINE funcallExitFromNum #-} 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++{-# INLINE foldFuncallExitFromNum #-}+foldFuncallExitFromNum :: (Eq a, Num a) => a -> b -> (FuncallExit () -> b) -> b+foldFuncallExitFromNum x def f = case x of+  (#const emacs_funcall_exit_return) -> f FuncallExitReturn+  (#const emacs_funcall_exit_signal) -> f $ FuncallExitSignal ()+  (#const emacs_funcall_exit_throw)  -> f $ FuncallExitThrow ()+  _                                  -> def 

@@ -0,0 +1,42 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.Env.ProcessInput+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++module Data.Emacs.Module.Env.ProcessInput+  ( Result(..)+  , resultToNum+  , resultFromNum+  ) where++import Data.Data (Data)+import Language.Haskell.TH.Syntax (Lift)+import Prettyprinter.Generics++#include <emacs-module.h>++-- | Result of 'process_inputs' Emacs API call.+data Result+  = Continue+  | Quit+  deriving (Eq, Ord, Show, Data, Generic, Lift)++instance Pretty Result where+  pretty = ppGeneric++{-# INLINE resultToNum #-}+resultToNum :: Num a => Result -> a+resultToNum = \case+  Continue -> (#const emacs_process_input_continue)+  Quit     -> (#const emacs_process_input_quit)++{-# INLINE resultFromNum #-}+resultFromNum :: (Eq a, Num a) => a -> Maybe Result+resultFromNum = \case+  (#const emacs_process_input_continue) -> Just Continue+  (#const emacs_process_input_quit)     -> Just Quit+  _                                     -> Nothing+

@@ -0,0 +1,25 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.GetRawValue+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}++module Data.Emacs.Module.GetRawValue (GetRawValue(..)) where++import Data.Emacs.Module.Raw.Value+import Data.Emacs.Module.Value.Internal++class GetRawValue a where+  getRawValue :: a -> RawValue 'Regular++instance GetRawValue (RawValue 'Regular) where+  {-# INLINE getRawValue #-}+  getRawValue = id++instance GetRawValue (Value s) where+  {-# INLINE getRawValue #-}+  getRawValue = unValue

@@ -6,7 +6,8 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.Emacs.Module.NonNullPtr   ( NonNullPtr@@ -14,12 +15,15 @@   , mkNonNullPtr   , allocaNonNull   , allocaBytesNonNull+  , withPtrLenNonNull   ) where +import Data.Coerce import Foreign  import Data.Emacs.Module.NonNullPtr.Internal import Emacs.Module.Assert+import Foreign.Ptr.Builder  mkNonNullPtr :: WithCallStack => Ptr a -> NonNullPtr a #ifdef ASSERTIONS@@ -31,9 +35,16 @@ #endif  {-# INLINE allocaNonNull #-}-allocaNonNull :: Storable a => (NonNullPtr a -> IO b) -> IO b-allocaNonNull f = alloca (f . NonNullPtr)+allocaNonNull :: forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b+allocaNonNull = coerce (alloca :: (Ptr a -> IO b) -> IO b)  {-# INLINE allocaBytesNonNull #-}-allocaBytesNonNull :: Int -> (NonNullPtr a -> IO b) -> IO b-allocaBytesNonNull n f = allocaBytes n (f . NonNullPtr)+allocaBytesNonNull :: forall a b. Int -> (NonNullPtr a -> IO b) -> IO b+allocaBytesNonNull = coerce (allocaBytes :: Int -> (Ptr a -> IO b) -> IO b)++{-# INLINE withPtrLenNonNull #-}+withPtrLenNonNull+  :: forall a b. (WithCallStack, Storable a)+  => BuilderCache a -> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b+withPtrLenNonNull =+  coerce (withPtrLen :: BuilderCache a -> Builder a -> (Int -> Ptr a -> IO b) -> IO b)

@@ -6,12 +6,11 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Data.Emacs.Module.NonNullPtr.Internal (NonNullPtr(..)) where +import Control.DeepSeq import Foreign  newtype NonNullPtr a = NonNullPtr { unNonNullPtr :: Ptr a }-  deriving (Eq, Ord, Show, Storable)+  deriving (Eq, Ord, Show, NFData, Storable) 

@@ -8,21 +8,20 @@ -- Low-level and, hopefully, low-overhead wrappers around @struct emacs_env@. ---------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE DataKinds                #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE TemplateHaskell          #-}+{-# LANGUAGE UnliftedFFITypes         #-}  {-# OPTIONS_HADDOCK not-home #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-}- module Data.Emacs.Module.Raw.Env   ( EnumFuncallExit(..)-  , UserPtrFinaliserType-  , UserPtrFinaliser+  , EnumProcessInputResult(..)+  , Env   , CBoolean   , isTruthy+  , isNonTruthy   , isValidEnv    , makeGlobalRef@@ -58,6 +57,8 @@   , vecGet   , vecSet   , vecSize+  , setFunctionFinalizer+  , processInput   ) where  import Control.Monad.IO.Class@@ -65,11 +66,13 @@ import Data.Coerce import Foreign import Foreign.C+import Prettyprinter  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.Raw.Value.Internal  import Data.Emacs.Module.NonNullPtr.Internal @@ -77,9 +80,14 @@  newtype EnumFuncallExit = EnumFuncallExit { unEnumFuncallExit :: CInt } -type UserPtrFinaliserType a = Ptr a -> IO ()-type UserPtrFinaliser a = FunPtr (UserPtrFinaliserType a)+instance Pretty EnumFuncallExit where+  pretty (EnumFuncallExit (CInt x)) = pretty x +newtype EnumProcessInputResult = EnumProcessInputResult { unEnumProcessInputResult :: CInt }++instance Pretty EnumProcessInputResult where+  pretty (EnumProcessInputResult (CInt x)) = pretty x+ -- | A wrapper around C value that denotes true or false. newtype CBoolean = CBoolean (#type bool) @@ -88,7 +96,13 @@ isTruthy :: CBoolean -> Bool isTruthy (CBoolean a) = a /= 0 +{-# INLINE isNonTruthy #-}+-- | Check whether a 'CBoolean' denotes false.+isNonTruthy :: CBoolean -> Bool+isNonTruthy (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.@@ -98,45 +112,34 @@   pure $ expectedSize <= realSize   where     expectedSize :: CPtrdiff-    expectedSize = (#size emacs_env)+    expectedSize = (#size struct emacs_env_28)  $(wrapEmacsFunc "makeGlobalRefTH" Unsafe    [e| (#peek emacs_env, make_global_ref) |]-   [t| Env -> RawValue -> IO RawValue |])+   [t| forall p. Env -> RawValue p -> IO (RawValue 'Pinned) |])  {-# INLINE makeGlobalRef #-} makeGlobalRef-  :: forall m. MonadIO m+  :: forall m p. MonadIO m   => Env-  -> RawValue-  -> m GlobalRef+  -> RawValue p+  -> m (RawValue 'Pinned) makeGlobalRef env x =-  liftIO $-    coerce-      (makeGlobalRefTH-        :: Env-        -> RawValue-        -> IO RawValue)-      env-      x+  liftIO $ makeGlobalRefTH env x   $(wrapEmacsFunc "freeGlobalRefTH" Unsafe    [e| (#peek emacs_env, free_global_ref) |]-   [t| Env -> RawValue -> IO () |])+   [t| Env -> RawValue 'Pinned -> IO () |])  {-# INLINE freeGlobalRef #-} freeGlobalRef   :: forall m. MonadIO m   => Env-  -> GlobalRef+  -> RawValue 'Pinned   -> m () freeGlobalRef env x =-  liftIO $-  coerce-    (freeGlobalRefTH :: Env -> RawValue -> IO ())-    env-    x+  liftIO $ freeGlobalRefTH env x   $(wrapEmacsFunc "nonLocalExitCheckTH" Unsafe@@ -153,42 +156,42 @@  $(wrapEmacsFunc "nonLocalExitGetTH" Unsafe    [e| (#peek emacs_env, non_local_exit_get) |]-   [t| Env -> NonNullPtr RawValue -> NonNullPtr RawValue -> IO EnumFuncallExit |])+   [t| Env -> NonNullPtr (RawValue 'Regular) -> NonNullPtr (RawValue 'Regular) -> IO EnumFuncallExit |])  {-# INLINE nonLocalExitGet #-} nonLocalExitGet   :: MonadIO m   => Env-  -> NonNullPtr RawValue -- ^ Symbol output-  -> NonNullPtr RawValue -- ^ Data output+  -> NonNullPtr (RawValue 'Regular) -- ^ Symbol output+  -> NonNullPtr (RawValue 'Regular) -- ^ Data output   -> m EnumFuncallExit nonLocalExitGet = nonLocalExitGetTH   $(wrapEmacsFunc "nonLocalExitSignalTH" Unsafe    [e| (#peek emacs_env, non_local_exit_signal) |]-   [t| Env -> RawValue -> RawValue -> IO () |])+   [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO () |])  {-# INLINE nonLocalExitSignal #-} nonLocalExitSignal   :: MonadIO m   => Env-  -> RawValue -- ^ Error symbol-  -> RawValue -- ^ Error data+  -> RawValue p1 -- ^ Error symbol+  -> RawValue p2 -- ^ Error data   -> m () nonLocalExitSignal = nonLocalExitSignalTH   $(wrapEmacsFunc "nonLocalExitThrowTH" Unsafe    [e| (#peek emacs_env, non_local_exit_throw) |]-   [t| Env -> RawValue -> RawValue -> IO () |])+   [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO () |])  {-# INLINE nonLocalExitThrow #-} nonLocalExitThrow   :: MonadIO m   => Env-  -> RawValue -- ^ Tag, a symbol-  -> RawValue -- ^ Value+  -> RawValue p1 -- ^ Tag, a symbol+  -> RawValue p2 -- ^ Value   -> m () nonLocalExitThrow = nonLocalExitThrowTH @@ -210,168 +213,168 @@  $(wrapEmacsFunc "makeFunctionTH" Unsafe    [e| (#peek emacs_env, make_function) |]-   [t| forall a. Env -> CPtrdiff -> CPtrdiff -> FunPtr (RawFunctionType a) -> CString -> Ptr a -> IO RawValue |])+   [t| forall a o. Env -> CPtrdiff -> CPtrdiff -> FunPtr (RawFunctionType o a) -> CString -> Ptr a -> IO (RawValue 'Regular) |])  {-# INLINE makeFunction #-} makeFunction-  :: forall m a. MonadIO m+  :: forall m o a. MonadIO m   => Env-  -> CPtrdiff      -- ^ Minimum arity-  -> CPtrdiff      -- ^ Maximum arity-  -> RawFunction a -- ^ Implementation-  -> CString       -- ^ Documentation-  -> Ptr a         -- ^ Extra data-  -> m RawValue+  -> CPtrdiff        -- ^ Minimum arity+  -> CPtrdiff        -- ^ Maximum arity+  -> RawFunction o a -- ^ Implementation+  -> CString         -- ^ Documentation+  -> Ptr a           -- ^ Extra data+  -> m (RawValue 'Regular) makeFunction =   coerce     (makeFunctionTH ::          Env       -> CPtrdiff       -> CPtrdiff-      -> FunPtr (RawFunctionType a)+      -> FunPtr (RawFunctionType o a)       -> CString       -> Ptr a-      -> m RawValue)+      -> m (RawValue 'Regular))   $(wrapEmacsFunc "funcallTH" Safe    [e| (#peek emacs_env, funcall) |]-   [t| Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue |])+   [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> NonNullPtr (RawValue p2) -> IO (RawValue 'Regular) |])  {-# INLINE funcall #-} funcall   :: MonadIO m   => Env-  -> RawValue            -- ^ Function-  -> CPtrdiff            -- ^ Number of arguments-  -> NonNullPtr RawValue -- ^ Actual arguments-  -> m RawValue+  -> RawValue p1              -- ^ Function+  -> CPtrdiff                 -- ^ Number of arguments+  -> NonNullPtr (RawValue p2) -- ^ Actual arguments+  -> m (RawValue 'Regular) funcall = funcallTH   $(wrapEmacsFunc "funcallPrimitiveTH" Unsafe    [e| (#peek emacs_env, funcall) |]-   [t| Env -> RawValue -> CPtrdiff -> NonNullPtr RawValue -> IO RawValue |])+   [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> NonNullPtr (RawValue p2) -> IO (RawValue 'Regular) |])  {-# INLINE funcallPrimitive #-} funcallPrimitive   :: MonadIO m   => Env-  -> RawValue            -- ^ Function-  -> CPtrdiff            -- ^ Number of arguments-  -> NonNullPtr RawValue -- ^ Actual arguments-  -> m RawValue+  -> RawValue p1              -- ^ Function+  -> CPtrdiff                 -- ^ Number of arguments+  -> NonNullPtr (RawValue p2) -- ^ Actual arguments+  -> m (RawValue 'Regular) funcallPrimitive = funcallPrimitiveTH   $(wrapEmacsFunc "internTH" Unsafe    [e| (#peek emacs_env, intern) |]-   [t| Env -> CString -> IO RawValue |])+   [t| Env -> CString -> IO (RawValue 'Regular) |])  {-# INLINE intern #-} intern   :: MonadIO m   => Env   -> CString-  -> m RawValue+  -> m (RawValue 'Regular) intern = internTH   $(wrapEmacsFunc "typeOfTH" Unsafe    [e| (#peek emacs_env, type_of) |]-   [t| Env -> RawValue -> IO RawValue |])+   [t| forall p. Env -> RawValue p -> IO (RawValue 'Regular) |])  {-# INLINE typeOf #-} typeOf   :: MonadIO m   => Env-  -> RawValue-  -> m RawValue+  -> RawValue p+  -> m (RawValue 'Regular) typeOf = typeOfTH   $(wrapEmacsFunc "isNotNilTH" Unsafe    [e| (#peek emacs_env, is_not_nil) |]-   [t| Env -> RawValue -> IO CBoolean |])+   [t| forall p. Env -> RawValue p -> IO CBoolean |])  {-# INLINE isNotNil #-} isNotNil   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> m CBoolean isNotNil = isNotNilTH   $(wrapEmacsFunc "eqTH" Unsafe    [e| (#peek emacs_env, eq) |]-   [t| Env -> RawValue -> RawValue -> IO CBoolean |])+   [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO CBoolean |])  {-# INLINE eq #-} eq   :: MonadIO m   => Env-  -> RawValue-  -> RawValue+  -> RawValue p1+  -> RawValue p2   -> m CBoolean eq = eqTH   $(wrapEmacsFunc "extractIntegerTH" Unsafe    [e| (#peek emacs_env, extract_integer) |]-   [t| Env -> RawValue -> IO CIntMax |])+   [t| forall p. Env -> RawValue p -> IO CIntMax |])  {-# INLINE extractInteger #-} extractInteger   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> m CIntMax extractInteger = extractIntegerTH   $(wrapEmacsFunc "makeIntegerTH" Unsafe    [e| (#peek emacs_env, make_integer) |]-   [t| Env -> CIntMax -> IO RawValue |])+   [t| Env -> CIntMax -> IO (RawValue 'Regular) |])  {-# INLINE makeInteger #-} makeInteger   :: MonadIO m   => Env   -> CIntMax-  -> m RawValue+  -> m (RawValue 'Regular) makeInteger = makeIntegerTH   $(wrapEmacsFunc "extractFloatTH" Unsafe    [e| (#peek emacs_env, extract_float) |]-   [t| Env -> RawValue -> IO CDouble |])+   [t| forall p. Env -> RawValue p -> IO CDouble |])  {-# INLINE extractFloat #-} extractFloat   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> m CDouble extractFloat = extractFloatTH   $(wrapEmacsFunc "makeFloatTH" Unsafe    [e| (#peek emacs_env, make_float) |]-   [t| Env -> CDouble -> IO RawValue |])+   [t| Env -> CDouble -> IO (RawValue 'Regular) |])  {-# INLINE makeFloat #-} makeFloat   :: MonadIO m   => Env   -> CDouble-  -> m RawValue+  -> m (RawValue 'Regular) makeFloat = makeFloatTH   $(wrapEmacsFunc "copyStringContentsTH" Unsafe    [e| (#peek emacs_env, copy_string_contents) |]-   [t| Env -> RawValue -> CString -> NonNullPtr CPtrdiff -> IO CBoolean |])+   [t| forall p. Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean |])  {-# INLINE copyStringContents #-} -- |  Copy the content of the Lisp string VALUE to BUFFER as an utf8@@ -388,7 +391,7 @@ copyStringContents   :: MonadIO m   => Env-  -> RawValue         -- ^ Emacs value that holds a string+  -> RawValue p          -- ^ Emacs value that holds a string   -> CString             -- ^ Destination, may be NULL   -> NonNullPtr CPtrdiff -- ^ SIZE pointer   -> m CBoolean@@ -397,54 +400,55 @@  $(wrapEmacsFunc "makeStringTH" Unsafe    [e| (#peek emacs_env, make_string) |]-   [t| Env -> CString -> CPtrdiff -> IO RawValue |])+   [t| Env -> CString -> CPtrdiff -> IO (RawValue 'Regular) |])  {-# INLINE makeString #-} makeString   :: MonadIO m   => Env-  -> CString  -- ^ 0-terminated utf8-encoded string.+  -> CString  -- ^ Utf8-encoded string, may contain null bytes and is+              -- not required to be terminated with one.   -> CPtrdiff -- ^ Length.-  -> m RawValue+  -> m (RawValue 'Regular) makeString = makeStringTH   $(wrapEmacsFunc "makeUserPtrTH" Unsafe    [e| (#peek emacs_env, make_user_ptr) |]-   [t| forall a. Env -> UserPtrFinaliser a -> Ptr a -> IO RawValue |])+   [t| forall a. Env -> FinalizerPtr a -> Ptr a -> IO (RawValue 'Regular) |])  {-# INLINE makeUserPtr #-} makeUserPtr   :: forall m a. MonadIO m   => Env-  -> UserPtrFinaliser a+  -> FinalizerPtr a   -> Ptr a-  -> m RawValue+  -> m (RawValue 'Regular) makeUserPtr = makeUserPtrTH   $(wrapEmacsFunc "getUserPtrTH" Unsafe    [e| (#peek emacs_env, get_user_ptr) |]-   [t| forall a. Env -> RawValue -> IO (Ptr a) |])+   [t| forall p a. Env -> RawValue p -> IO (Ptr a) |])  {-# INLINE getUserPtr #-} getUserPtr   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> m (Ptr a) getUserPtr = getUserPtrTH   $(wrapEmacsFunc "setUserPtrTH" Unsafe    [e| (#peek emacs_env, set_user_ptr) |]-   [t| forall a. Env -> RawValue -> Ptr a -> IO () |])+   [t| forall p a. Env -> RawValue p -> Ptr a -> IO () |])  {-# INLINE setUserPtr #-} setUserPtr   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> Ptr a   -> m () setUserPtr = setUserPtrTH@@ -452,69 +456,98 @@  $(wrapEmacsFunc "getUserFinaliserTH" Unsafe    [e| (#peek emacs_env, get_user_finalizer) |]-   [t| forall a. Env -> RawValue -> IO (UserPtrFinaliser a) |])+   [t| forall p a. Env -> RawValue p -> IO (FinalizerPtr a) |])  {-# INLINE getUserFinaliser #-} getUserFinaliser   :: MonadIO m   => Env-  -> RawValue-  -> m (UserPtrFinaliser a)+  -> RawValue p+  -> m (FinalizerPtr a) getUserFinaliser = getUserFinaliserTH   $(wrapEmacsFunc "setUserFinaliserTH" Unsafe    [e| (#peek emacs_env, set_user_finalizer) |]-   [t| forall a. Env -> RawValue -> UserPtrFinaliser a -> IO () |])+   [t| forall p a. Env -> RawValue p -> FinalizerPtr a -> IO () |])  {-# INLINE setUserFinaliser #-} setUserFinaliser   :: MonadIO m   => Env-  -> RawValue-  -> UserPtrFinaliser a+  -> RawValue p+  -> FinalizerPtr a   -> m () setUserFinaliser = setUserFinaliserTH   $(wrapEmacsFunc "vecGetTH" Unsafe    [e| (#peek emacs_env, vec_get) |]-   [t| Env -> RawValue -> CPtrdiff -> IO RawValue |])+   [t| forall p. Env -> RawValue p -> CPtrdiff -> IO (RawValue 'Regular) |])  {-# INLINE vecGet #-} vecGet   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> CPtrdiff-  -> m RawValue+  -> m (RawValue 'Regular) vecGet = vecGetTH   $(wrapEmacsFunc "vecSetTH" Unsafe    [e| (#peek emacs_env, vec_set) |]-   [t| Env -> RawValue -> CPtrdiff -> RawValue -> IO () |])+   [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> RawValue p2 -> IO () |])  {-# INLINE vecSet #-} vecSet   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p1   -> CPtrdiff-  -> RawValue+  -> RawValue p2   -> m () vecSet = vecSetTH   $(wrapEmacsFunc "vecSizeTH" Unsafe    [e| (#peek emacs_env, vec_size) |]-   [t| Env -> RawValue -> IO CPtrdiff |])+   [t| forall p. Env -> RawValue p -> IO CPtrdiff |])  {-# INLINE vecSize #-} vecSize   :: MonadIO m   => Env-  -> RawValue+  -> RawValue p   -> m CPtrdiff vecSize = vecSizeTH+++-- These are mostly of administrative interest.++$(wrapEmacsFunc "setFunctionFinalizerTH" Unsafe+   [e| (#peek emacs_env, set_function_finalizer) |]+   [t| forall p a. Env -> RawValue p -> FinalizerPtr a -> IO () |])++{-# INLINE setFunctionFinalizer #-}+setFunctionFinalizer+  :: MonadIO m+  => Env+  -> RawValue p+  -> FinalizerPtr a+  -> m ()+setFunctionFinalizer = setFunctionFinalizerTH++$(wrapEmacsFunc "processInputTH" Unsafe+   [e| (#peek emacs_env, process_input) |]+   [t| Env -> IO EnumProcessInputResult |])++{-# INLINE processInput #-}+-- | Processes pending input events and returns whether the module+-- function should quit.+processInput+  :: MonadIO m+  => Env+  -> m EnumProcessInputResult+processInput = processInputTH 

@@ -6,46 +6,65 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE DataKinds                #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash                #-}+{-# LANGUAGE UnliftedFFITypes         #-}+{-# LANGUAGE UnliftedNewtypes         #-}  {-# OPTIONS_HADDOCK not-home #-}  module Data.Emacs.Module.Raw.Env.Internal   ( Env(..)+  , Environment   , toPtr+  , fromPtr   , exportToEmacs   , RawFunctionType   , RawFunction(..)++  , freeHaskellFunPtrWrapped   ) where  import Foreign import Foreign.C.Types--import Data.Emacs.Module.NonNullPtr-import Data.Emacs.Module.Raw.Value+import GHC.Exts (Addr#, Ptr(..)) -import Data.Emacs.Module.NonNullPtr.Internal+import Data.Emacs.Module.Raw.Value.Internal  -- | Emacs environment, right from the 'emacs-module.h'.-newtype Env = Env { unEnv :: NonNullPtr Env }+newtype Env = Env { unEnv# :: Addr# } +data Environment+ {-# INLINE toPtr #-}-toPtr :: Env -> Ptr Env-toPtr = unNonNullPtr . unEnv+toPtr :: Env -> Ptr Environment+toPtr (Env x) = Ptr x +{-# INLINE fromPtr #-}+fromPtr :: Ptr Environment -> Env+fromPtr (Ptr x) = Env x -type RawFunctionType a =-     Env-  -> CPtrdiff     -- Number of arguments-  -> Ptr RawValue -- Actual arguments-  -> Ptr a        -- Extra data-  -> IO RawValue+type RawFunctionType o a+  =  Ptr Environment+  -> CPtrdiff                -- Number of arguments+  -> Ptr (RawValue 'Regular) -- Actual arguments, always supplied by Emacs so never 'Pinned'.+  -> Ptr a                   -- Extra data+  -> IO (RawValue o)  -- 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...++-- | Take Haskell function and return C pointer to function (which+-- ideally needs to be cleaned up later by 'freeHaskellFunPtrWrapped'). foreign import ccall "wrapper"-  exportToEmacs :: RawFunctionType a -> IO (RawFunction a)+  exportToEmacs :: RawFunctionType o a -> IO (RawFunction o a) -newtype RawFunction a = RawFunction { unRawFunction :: FunPtr (RawFunctionType a) }+-- | Pointer to a function that may later be called by by Emacs.+newtype RawFunction o a = RawFunction { unRawFunction :: FunPtr (RawFunctionType o a) }+  deriving (Eq, Ord, Show)++-- This function is defined in base. See what 'freeHaskellFunPtr' for a start.+foreign import ccall unsafe "&freeHaskellFunctionPtr"+  freeHaskellFunPtrWrapped :: FinalizerPtr a

@@ -7,12 +7,12 @@ ----------------------------------------------------------------------------  {-# LANGUAGE CPP                   #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE TemplateHaskellQuotes #-}  module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where  import Control.Monad.IO.Class+import Data.Bifunctor import Data.List (foldl') import Foreign.Ptr as Foreign import Language.Haskell.TH@@ -44,20 +44,11 @@ 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''+      (args, ret)                = decomposeFunctionType rawFuncType''   (envArg, otherArgs) <- case args of     [] -> fail $       "Raw function type must take at least one emacs_env argument: " ++ show rawFuncType'@@ -67,22 +58,34 @@      | otherwise ->         (,) <$> newName "env" <*> traverse (const (newName "x")) xs   foreignFuncName <- newName $ "emacs_func_" ++ name-  -- fail $ "otherArgs = " ++ show otherArgs ++ ", rawFuncType = " ++ show rawFuncType'-  let envPat = varP envArg+  let envPat :: PatQ+      envPat = varP envArg       pats   = envPat : map varP otherArgs-      body = normalB $ do+      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)           ]+  m    <- newName "m"+  ret' <- case ret of+    AppT monad result+      | monad == ConT ''IO+      -> appT (varT m) (pure result)+    _ -> fail $ "Expected function that returns result in IO monad"+  let tv         = PlainTV m SpecifiedSpec+      constraint = ConT ''MonadIO `AppT` (VarT m)+  typeSig      <- sigD name' $ pure $+    wrapForall (Just (maybe ([tv], [constraint]) (bimap (tv :) (constraint :)) forallCxt)) $+      foldr (\x acc -> ArrowT `AppT` x `AppT` acc) ret' args   mainDecl     <- funD name' [clause pats body []]   inlinePragma <- pragInlD name' Inline FunLike AllPhases-  let foreignDeclType =+  let foreignDeclType :: TypeQ+      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]+  pure [typeSig, mainDecl, inlinePragma, foreignDecl]   where     name' = mkName name 

@@ -6,24 +6,11 @@ -- 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)+module Data.Emacs.Module.Raw.Value+  ( RawValue+  , unRawValue+  , Pinning(..)+  , toUnknown+  ) where --- | 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)+import Data.Emacs.Module.Raw.Value.Internal

@@ -0,0 +1,63 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.Raw.Value.Internal+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE DataKinds    #-}+{-# LANGUAGE DerivingVia  #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE UnboxedTuples #-}++module Data.Emacs.Module.Raw.Value.Internal+  ( RawValue(..)+  , Pinning(..)+  , toUnknown+  ) where++import Control.DeepSeq+import Data.Coerce+import Data.Primitive.Types+import Data.Vector.Generic qualified as G+import Data.Vector.Generic.Mutable qualified as GM+import Data.Vector.Primitive qualified as P+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Base qualified as U+import Foreign+import GHC.Generics (Generic)+import Prettyprinter (Pretty(..))++data Pinning+  -- | Tag for global values are independent of environment ('Env') that produced it.+  --+  -- Can be used to e.g. cache values that are expensive to compute from scratch.+  = Pinned++  -- | Tag denoting regular Emacs values. Will go away after control+  -- returns to Emacs.+  | Regular++  -- | Tag denoting either global or regular emacs values. Cannot tell+  -- them apart, just pass to Emacs.+  | Unknown++toUnknown :: RawValue p -> RawValue 'Unknown+toUnknown = coerce++-- | Basic handle on an Emacs value.+newtype RawValue (p :: Pinning) = RawValue { unRawValue :: Ptr (RawValue p) }+  deriving (Show, NFData, Generic, Storable, Prim)++instance Pretty (RawValue p) where+  pretty = pretty . show . unRawValue++newtype instance U.MVector s (RawValue p) = MV_RawValue (P.MVector s (RawValue p))+newtype instance U.Vector    (RawValue p) = V_RawValue  (P.Vector    (RawValue p))++deriving via (U.UnboxViaPrim (RawValue p)) instance GM.MVector U.MVector (RawValue p)+deriving via (U.UnboxViaPrim (RawValue p)) instance G.Vector   U.Vector  (RawValue p)++instance U.Unbox (RawValue p)

@@ -6,14 +6,12 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnliftedFFITypes #-}  module Data.Emacs.Module.Runtime   ( Runtime(..)   , validateRuntime-  , getEnvironment+  , withEnvironment   ) where  import Control.Monad.Base@@ -32,13 +30,13 @@ -- | Emacs environment, right from the 'emacs-module.h'. newtype Runtime = Runtime { unRuntime :: NonNullPtr Runtime } -type GetEnvironentType = Runtime -> IO Emacs.Env+type GetEnvironentType = Runtime -> Emacs.Env  foreign import ccall unsafe "dynamic" emacs_get_environment   :: FunPtr GetEnvironentType -> GetEnvironentType  validateRuntime :: MonadBase IO m => Ptr Runtime -> m (Maybe Runtime)-validateRuntime ptr+validateRuntime !ptr   | ptr == nullPtr = pure Nothing   | otherwise      = liftBase $ do       size <- (#peek struct emacs_runtime, size) ptr@@ -47,7 +45,7 @@     expectedSize :: CPtrdiff     expectedSize = (#size struct emacs_runtime) -getEnvironment :: MonadBase IO m => Runtime -> m Emacs.Env-getEnvironment runtime = liftBase $ do+withEnvironment :: Runtime -> (Emacs.Env -> IO a) -> IO a+withEnvironment !runtime k = do   (funPtr :: FunPtr GetEnvironentType) <- (#peek struct emacs_runtime, get_environment) (unNonNullPtr $ unRuntime runtime)-  emacs_get_environment funPtr runtime+  k (emacs_get_environment funPtr runtime)

@@ -9,8 +9,10 @@ module Data.Emacs.Module.SymbolName   ( SymbolName   , mkSymbolName+  , mkSymbolNameString   , mkSymbolNameShortByteString-  , useSymbolNameAsCString+  , mkSymbolNameUnsafe+  , reifySymbol   ) where  import Data.Emacs.Module.SymbolName.Internal

@@ -6,39 +6,166 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE UnliftedNewtypes #-}  {-# OPTIONS_HADDOCK not-home #-}  module Data.Emacs.Module.SymbolName.Internal-  ( SymbolName(..)+  ( Static(..)+  , Dynamic(..)+  , SymbolName(..)   , mkSymbolName+  , mkSymbolNameString   , mkSymbolNameShortByteString-  , useSymbolNameAsCString+  , mkSymbolNameUnsafe++  , mkSymbolNameCache+  , mkCachedSymbolName+  , reifySymbolRaw+  , reifySymbolUnknown+  , reifySymbol   ) where -import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Internal qualified as BS import Data.ByteString.Short qualified as BSS-import Data.ByteString.Unsafe qualified as C8.Unsafe+import Data.Char+import Data.Coerce+import Data.IORef+import Data.String+import Data.Text (Text)+import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Encoding.Error qualified as TE-import Foreign.C.String+import Data.Text.Foreign qualified as T+import Foreign.C.Types+import Foreign.Storable+import GHC.Exts (Addr#, unpackCString#)+import GHC.Ptr import Prettyprinter+import System.IO.Unsafe -newtype SymbolName = SymbolName { unSymbolName :: C8.ByteString }+import Data.Emacs.Module.NonNullPtr+import Data.Emacs.Module.Raw.Env qualified as Raw+import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value+import Emacs.Module.Assert++import Data.Emacs.Module.SymbolName.Predefined.Funcall++-- | Symbols that are known at compile time.+--+-- Will just pass pointer to 0-terminated statically-allocated string+-- to Emacs API when used.+newtype Static = Static { unStatic :: Ptr CChar }   deriving (Eq, Ord, Show) +newtype Dynamic = Dynamic { unDynamic :: Text }+  deriving (Eq, Ord, Show, Pretty)++data SymbolName+  = StaticSymbol  {-# UNPACK #-} !(Ptr CChar)+  | DynamicSymbol {-# UNPACK #-} !Text+  | CachedSymbol  (IORef (Env -> IO (RawValue 'Pinned))) SymbolName+  deriving (Eq)++instance Show SymbolName where+  show = \case+    StaticSymbol (Ptr addr)+      -> show $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr+    DynamicSymbol str  -> show str+    CachedSymbol _ sym -> show sym+ instance Pretty SymbolName where-  pretty = pretty . TE.decodeUtf8With TE.lenientDecode . C8.init . unSymbolName+  pretty = \case+    StaticSymbol (Ptr addr)+      -> pretty $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr+    DynamicSymbol str  -> pretty str+    CachedSymbol _ sym -> pretty sym +mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))+mkSymbolNameCache = go+  where+    go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))+    go !name =+      unsafeFixIO $ \ ref ->+        newIORef $ \env -> do+          !global <- Raw.makeGlobalRef env =<< reifySymbolRaw env name+          writeIORef ref $ \_env -> pure global+          pure global++{-# INLINE mkCachedSymbolName #-}+mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName+mkCachedSymbolName = CachedSymbol++-- | Should be applied to unboxed string literals like this+--+-- @+-- mkSymbolNameUnsafe "foo"#+-- @+--+-- Can be safely applied to non-literals (e.g. arbitrary pointers) if+-- it's guaranteed that address points to a null-terminated strings.+-- Otherwise behaviour is undefined.+--+-- The string literal must only contain ASCII symbols. This condition+-- is required by the Emacs API and results in undefined behaviour if+-- violated.+{-# INLINE mkSymbolNameUnsafe #-}+mkSymbolNameUnsafe :: Addr# -> SymbolName+mkSymbolNameUnsafe addr = StaticSymbol (Ptr addr)+ {-# INLINE mkSymbolName #-}-mkSymbolName :: C8.ByteString -> SymbolName-mkSymbolName = SymbolName . (`C8.snoc` '\0')+mkSymbolName :: Text -> SymbolName+mkSymbolName = DynamicSymbol  {-# INLINE mkSymbolNameShortByteString #-} mkSymbolNameShortByteString :: BSS.ShortByteString -> SymbolName-mkSymbolNameShortByteString = mkSymbolName . BSS.fromShort+mkSymbolNameShortByteString = DynamicSymbol . TE.decodeUtf8With TE.lenientDecode . BSS.fromShort -{-# INLINE useSymbolNameAsCString #-}-useSymbolNameAsCString :: SymbolName -> (CString -> IO a) -> IO a-useSymbolNameAsCString = C8.Unsafe.unsafeUseAsCString . unSymbolName+{-# INLINE [0] mkSymbolNameString #-}+mkSymbolNameString :: String -> SymbolName+mkSymbolNameString = mkSymbolName . T.pack++instance IsString SymbolName where+  {-# INLINE fromString #-}+  fromString = mkSymbolNameString++{-# RULES+"SymbolName string literal" forall s .+   mkSymbolNameString (unpackCString# s) = mkSymbolNameUnsafe s+ #-}++{-# INLINE reifySymbolRaw #-}+reifySymbolRaw :: Env -> SymbolName -> IO (RawValue 'Regular)+reifySymbolRaw env sym = reifySymbol env sym id coerce++{-# INLINE reifySymbolUnknown #-}+reifySymbolUnknown :: Env -> SymbolName -> IO (RawValue 'Unknown)+reifySymbolUnknown env sym = reifySymbol env sym coerce coerce++{-# INLINE reifySymbol #-}+reifySymbol+  :: WithCallStack+  => Env -> SymbolName -> (RawValue 'Regular -> a) -> (RawValue 'Pinned -> a) -> IO a+reifySymbol env sym f g = case sym of+  StaticSymbol addr ->+    f <$> Raw.intern env addr+  DynamicSymbol str+    -- If it's only ASCII then can run FFI intern, otherwise have to go via funcall+    -- TODO: cache this check+    | T.all (\c -> ord c < 128) str ->+      f <$> T.withCString str (Raw.intern env)+    | otherwise                    ->+      T.withCStringLen str $ \(ptr, len) -> do+        str' <- emacsAssert (len >= 0) "Symbol text length must be non-negative" $+          Raw.makeString env ptr (fromIntegral len)+        funcall' <- reifySymbolUnknown env funcall+        allocaNonNull $ \args -> do+          poke (unNonNullPtr args) str'+          f <$> Raw.funcallPrimitive env funcall' 1 args++  CachedSymbol ref _ ->+    g <$> ((\k -> k env) =<< readIORef ref)

@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}++module Data.Emacs.Module.SymbolName.Internal+  ( SymbolName+  , mkSymbolNameCache+  , mkCachedSymbolName+  , mkSymbolNameString+  ) where++import Data.IORef++import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value++data SymbolName++mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))++mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName++mkSymbolNameString :: String -> SymbolName

@@ -0,0 +1,61 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.SymbolName.Predefined+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+--+-- Some commonly used symbol names which will get initialized only+-- once after they're used.+----------------------------------------------------------------------------++{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Emacs.Module.SymbolName.Predefined+  ( error+  , list+  , cons+  , car+  , cdr+  , setcar+  , setcdr+  , nil+  , fset+  , provide+  , t+  , vector+  , vconcat+  , face+  , propertize+  , concat+  , symbolName+  , prin1ToString+  , funcall+  ) where++import Prelude hiding (error, concat)++import Data.Emacs.Module.SymbolName.TH++import Data.Emacs.Module.SymbolName.Predefined.Funcall++cacheSym "error"           Nothing+cacheSym "list"            Nothing+cacheSym "cons"            Nothing+cacheSym "car"             Nothing+cacheSym "cdr"             Nothing+cacheSym "setcar"          Nothing+cacheSym "setcdr"          Nothing+cacheSym "nil"             Nothing+cacheSym "fset"            Nothing+cacheSym "provide"         Nothing+cacheSym "t"               Nothing+cacheSym "vector"          Nothing+cacheSym "vconcat"         Nothing+cacheSym "face"            Nothing+cacheSym "propertize"      Nothing+cacheSym "concat"          Nothing+cacheSym "symbol-name"     (Just "symbolName")+cacheSym "prin1-to-string" (Just "prin1ToString")

@@ -0,0 +1,32 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.SymbolName.Predefined.Funcall+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}++module Data.Emacs.Module.SymbolName.Predefined.Funcall+  ( funcall+  ) where++import Data.IORef+import System.IO.Unsafe++import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value++import {-# SOURCE #-} Data.Emacs.Module.SymbolName.Internal++funcallSym :: SymbolName+funcallSym = mkSymbolNameString "funcall"++{-# NOINLINE funcallCache #-}+funcallCache :: IORef (Env -> IO (RawValue 'Pinned))+funcallCache = unsafePerformIO $ mkSymbolNameCache funcallSym++funcall :: SymbolName+funcall = mkCachedSymbolName funcallCache funcallSym+

@@ -6,30 +6,32 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE TemplateHaskell #-} -module Data.Emacs.Module.SymbolName.TH (esym) where+module Data.Emacs.Module.SymbolName.TH+  ( cacheSym+  ) where -import Data.ByteString.Char8 qualified as C8+import Data.IORef+import Data.Maybe import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Data.Emacs.Module.SymbolName.Internal+import System.IO.Unsafe --- | 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"-  }+import Data.Emacs.Module.Raw.Env.Internal (Env)+import Data.Emacs.Module.Raw.Value+import Data.Emacs.Module.SymbolName.Internal qualified as Sym -mkESym :: String -> ExpQ-mkESym s = [e| SymbolName (C8.pack $(stringE $ s ++ "\0")) |]+cacheSym :: String -> Maybe String -> Q [Dec]+cacheSym sym bindingName = do+  ref      <- newName ("ref_" ++ binding)+  noinline <- pragInlD ref NoInline FunLike AllPhases+  refSig   <- sigD ref [t| IORef (Env -> IO (RawValue 'Pinned)) |]+  refDecl  <- valD (varP ref) (normalB [e| unsafePerformIO (Sym.mkSymbolNameCache $sym') |]) []+  symSig   <- sigD (mkName binding) [t| Sym.SymbolName |]+  symDecl  <- valD (varP (mkName binding)) (normalB [e| Sym.CachedSymbol $(varE ref) $sym' |]) []+  pure [noinline, refSig, refDecl, symSig, symDecl]+  where+    sym' :: ExpQ+    sym' = [e| Sym.mkSymbolNameString $(litE (stringL sym)) |]+    binding = fromMaybe sym bindingName

@@ -7,9 +7,7 @@ ----------------------------------------------------------------------------  module Data.Emacs.Module.Value-  ( RawValue-  , Value(..)+  ( Value   ) where -import Data.Emacs.Module.Raw.Value (RawValue) import Data.Emacs.Module.Value.Internal

@@ -6,16 +6,28 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DerivingVia          #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -module Data.Emacs.Module.Value.Internal (Value(..)) where+{-# LANGUAGE UnboxedTuples #-} -import Control.DeepSeq-import Control.Monad.Trans.Resource+module Data.Emacs.Module.Value.Internal+  ( Value(..)+  ) where +import Control.DeepSeq+import Data.Primitive.Types+import Data.Vector.Generic qualified as G+import Data.Vector.Generic.Mutable qualified as GM+import Data.Vector.Primitive qualified as P+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Base qualified as U import GHC.Generics (Generic)+import Prettyprinter (Pretty) -import Data.Emacs.Module.Raw.Value (GlobalRef(..))+import Data.Emacs.Module.Raw.Value  -- | Value that is independent of environment ('Env') that produced it. -- Incidentally, this implies that it's "protected" against Emacs GC and@@ -27,10 +39,15 @@ -- @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)+newtype Value (s :: k) = Value+  { unValue :: RawValue 'Regular+  } deriving (Show, NFData, Generic, Prim, Pretty) -instance NFData (Value s) where-  rnf (Value x y) = rnf x `seq` y `seq` ()+newtype instance U.MVector s (Value s') = MV_Value (P.MVector s (Value s'))+newtype instance U.Vector    (Value s') = V_Value  (P.Vector    (Value s'))++deriving via (U.UnboxViaPrim (Value s')) instance GM.MVector U.MVector (Value s')+deriving via (U.UnboxViaPrim (Value s')) instance G.Vector   U.Vector  (Value s')++instance U.Unbox (Value s')+

@@ -23,30 +23,28 @@ -- -- With help of this package, it may be defined as ----- @--- {-# LANGUAGE DataKinds        #-}-{-# LANGUAGE ImportQualifiedPost #-}--- {-# LANGUAGE QuasiQuotes #-} ----- import Data.Maybe--- import Data.Emacs.Module.SymbolName.TH--- import Emacs.Module------ foo---   :: (MonadEmacs m, Monad (m s))---   => EmacsFunction ('S ('S ('S ('S 'Z)))) ('S ('S 'Z)) 'True s m--- foo (R f (R x (R y (R z (O w (O t (Rest quux))))))) = do---   x'    <- extractInt x---   y'    <- extractInt y---   z'    <- extractInt z---   w'    <- traverse extractInt w---   t'    <- traverse extractInt t------   tmp   <- makeInt (x' * y' * z')---   tmp'  <- extractInt =<< funcall [esym|funcall|] [f, tmp]+-- > {-# LANGUAGE DataKinds   #-}+-- > {-# LANGUAGE QuasiQuotes #-}+-- >+-- > import Data.Maybe+-- > import Data.Emacs.Module.SymbolName.TH+-- > import Emacs.Module -----   produceRef =<< makeInt (tmp' + fromMaybe 1 w' * fromMaybe 2 t' + length quux)--- @+-- > foo+-- >   :: MonadEmacs m v+-- >   => EmacsFunction ('S ('S ('S ('S 'Z)))) ('S ('S 'Z)) 'True m v s+-- > foo (R f (R x (R y (R z (O w (O t (Rest quux))))))) = do+-- >   x'    <- extractInt x+-- >   y'    <- extractInt y+-- >   z'    <- extractInt z+-- >   w'    <- traverse extractInt w+-- >   t'    <- traverse extractInt t+-- >+-- >   tmp   <- makeInt (x' * y' * z')+-- >   tmp'  <- extractInt =<< funcallSym "funcall" [f, tmp]+-- >+-- >   produceRef =<< makeInt (tmp' + fromMaybe 1 w' * fromMaybe 2 t' + length quux) -- -- = Creating Emacs dynamic module -- In order to make shared object or dll callable from Emacs,@@ -61,16 +59,11 @@  module Emacs.Module   (-    -- * EmacsM-    EmacsM-  , runEmacsM-     -- * Basic bindings-  , MonadEmacs(..)+    MonadEmacs(..)      -- ** Define functions callable by Emacs   , EmacsFunction-  , EmacsFunctionExtra   , Nat(..)   , R(..)   , O(..)@@ -82,27 +75,20 @@   , EmacsInternalError(..)   , reportAllErrorsToEmacs -    -- ** Other types-  , Raw.UserPtrFinaliserType-  , Raw.UserPtrFinaliser-     -- * Reexports   , module Emacs.Module.Functions   , module Data.Emacs.Module.Value   , Env      -- * Third-party reexports-  , MonadThrow-  , Throws+  , MonadThrow(..)   ) where -import Control.Exception.Safe.Checked (MonadThrow, Throws)+import Control.Monad.Catch (MonadThrow(..))  import Data.Emacs.Module.Args import Data.Emacs.Module.Env (Env)-import Data.Emacs.Module.Raw.Env qualified as Raw import Data.Emacs.Module.Value import Emacs.Module.Errors import Emacs.Module.Functions-import Emacs.Module.Monad import Emacs.Module.Monad.Class

@@ -6,9 +6,7 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE CPP             #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE CPP #-}  module Emacs.Module.Assert   ( WithCallStack@@ -17,14 +15,14 @@  import Data.Kind (Constraint) -#ifdef ASSERTIONS+#ifdef CALL_STACKS import GHC.Stack (HasCallStack) #endif  -- | Call stacks for all emacs-related functions in Haskell.--- Will be disabled unless this package was build with 'assertions'+-- Will be disabled unless this package was built with 'call-stacks' -- flag enabled.-#ifdef ASSERTIONS+#ifdef CALL_STACKS type WithCallStack = (HasCallStack :: Constraint) #else type WithCallStack = (() :: Constraint)

@@ -8,26 +8,22 @@ -- This module defines various kinds of exception that this library ---------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE QuasiQuotes         #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}  module Emacs.Module.Errors   ( EmacsThrow(..)   , reportEmacsThrowToEmacs-  , UserError(..)-  , mkUserError+  , EmacsSignal(..)+  , reportEmacsSignalToEmacs   , EmacsError(..)   , mkEmacsError   , reportErrorToEmacs   , EmacsInternalError(..)   , mkEmacsInternalError   , reportInternalErrorToEmacs+  , UserError(..)+  , mkUserError    , formatSomeException   , reportAnyErrorToEmacs@@ -36,53 +32,86 @@  import Control.Applicative import Control.Exception as Exception-import Control.Exception.Safe.Checked (Throws)-import Control.Exception.Safe.Checked qualified as Checked  import Data.ByteString.Char8 qualified as C8-import Data.Proxy import Data.Text (Text)+import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Void import Data.Void.Unsafe+import Foreign import Foreign.C.String-import Foreign.Marshal.Array import GHC.Stack (CallStack, callStack, prettyCallStack) import Prettyprinter+import Prettyprinter.Combinators hiding (render, ppCallStack) import Prettyprinter.Render.Text as PP  import Data.Emacs.Module.Env qualified as Raw+import Data.Emacs.Module.GetRawValue 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 Data.Emacs.Module.SymbolName.Internal+import Data.Emacs.Module.SymbolName.Predefined qualified as Sym 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+  { emacsThrowTag    :: !(RawValue 'Regular)+  , emacsThrowValue  :: !(RawValue 'Regular)+  , emacsThrowOrigin :: CallStack   }  instance Show EmacsThrow where-  showsPrec _ _ = showString "EmacsThrow"+  showsPrec _ EmacsThrow{emacsThrowOrigin}+    = showString "EmacsThrow\n"+    . showString (prettyCallStack emacsThrowOrigin)  instance Exception EmacsThrow -reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO RawValue+reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO (RawValue 'Unknown) reportEmacsThrowToEmacs env et = do+  nil <- mkNil env   reportEmacsThrowToEmacs' env et-  returnNil env+  pure nil  reportEmacsThrowToEmacs' :: Env -> EmacsThrow -> IO ()-reportEmacsThrowToEmacs' env EmacsThrow{emacsThrowTag, emacsThrowValue} = do+reportEmacsThrowToEmacs' env EmacsThrow{emacsThrowTag, emacsThrowValue} =   Raw.nonLocalExitThrow env emacsThrowTag emacsThrowValue +-- | A Haskell exception used to signal a @signal@ exit performed by an+-- Emacs function.+--+-- Unlikely to be needed when developing Emacs extensions.+data EmacsSignal = EmacsSignal+  { emacsSignalSym    :: !(RawValue 'Unknown)+  , emacsSignalData   :: !(RawValue 'Regular)+  , emacsSignalInfo   :: !Text+  , emacsSignalOrigin :: CallStack+  }++instance Show EmacsSignal where+  showsPrec _ EmacsSignal{emacsSignalInfo, emacsSignalOrigin}+    = showString "EmacsSignal "+    . showString (T.unpack emacsSignalInfo)+    . showChar '\n'+    . showString (prettyCallStack emacsSignalOrigin)++instance Exception EmacsSignal++reportEmacsSignalToEmacs :: Env -> EmacsSignal -> IO (RawValue 'Unknown)+reportEmacsSignalToEmacs env et = do+  nil <- mkNil env+  reportEmacsSignalToEmacs' env et+  pure nil++reportEmacsSignalToEmacs' :: Env -> EmacsSignal -> IO ()+reportEmacsSignalToEmacs' env EmacsSignal{emacsSignalSym, emacsSignalData} =+  Raw.nonLocalExitSignal env emacsSignalSym emacsSignalData+ -- | Error thrown to emacs by Haskell functions when anything goes awry. data UserError = UserError   { userErrFunctionName :: Doc Void@@ -139,20 +168,28 @@     "Location:" <> line <>     indent 2 (ppCallStack emacsErrStack) -reportErrorToEmacs :: Env -> EmacsError -> IO RawValue+reportErrorToEmacs :: Env -> EmacsError -> IO (RawValue 'Unknown) reportErrorToEmacs env e = do+  nil <- mkNil env   report render env e-  returnNil env+  pure nil  -- | A low-level error thrown when assumptions of this package are -- violated and it's not safe to proceed further.+--+-- E.g. Emacs returned value not specified in a C enum - cannot+-- really process it in a meaningful way. data EmacsInternalError = EmacsInternalError   { emacsInternalErrMsg   :: Doc Void   , emacsInternalErrStack :: CallStack-  } deriving (Show)+  }  instance Exception EmacsInternalError +instance Show EmacsInternalError where+  showsPrec _ (EmacsInternalError msg stack)+    = showString (renderString ("EmacsInternalError" ## msg <> line <> ppCallStack stack))+ mkEmacsInternalError   :: WithCallStack   => Doc Void -- ^ Error message@@ -162,10 +199,11 @@   , emacsInternalErrStack = callStack   } -reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO RawValue+reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO (RawValue 'Unknown) reportInternalErrorToEmacs env e = do+  nil <- mkNil env   report render env e-  returnNil env+  pure nil  instance Pretty EmacsInternalError where   pretty EmacsInternalError{emacsInternalErrMsg, emacsInternalErrStack} =@@ -177,18 +215,18 @@ formatSomeException :: SomeException -> Text formatSomeException e =   case pretty @EmacsError         <$> fromException e <|>-       pretty @EmacsInternalError <$> fromException e <|>-       pretty @UserError          <$> fromException e of+       pretty @EmacsInternalError <$> fromException e of     Just formatted -> render' formatted-    Nothing ->+    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+reportAnyErrorToEmacs :: Env -> SomeException -> IO (RawValue 'Unknown)+reportAnyErrorToEmacs env !e = do+  !nil <- mkNil env   report formatSomeException env e-  returnNil env+  pure nil  -- | Catch all errors this package might throw in an IO action -- and make Emacs aware of them.@@ -198,23 +236,22 @@ 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+  -> IO a+reportAllErrorsToEmacs env resultOnErr x+  = Exception.handle (\e -> report formatSomeException env e *> resultOnErr)+  $ Exception.handle (\et -> reportEmacsThrowToEmacs' env et *> resultOnErr)+  $ Exception.handle (\et -> reportEmacsSignalToEmacs' env et *> resultOnErr) 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)+  errSym  <- reifySymbolRaw env Sym.error+  listSym <- reifySymbolRaw env Sym.list   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)+    alloca $ \argsPtr -> do+      poke argsPtr str'+      errData <- Raw.funcallPrimitive env (getRawValue listSym) 1 (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.@@ -226,10 +263,8 @@   where     utf8 = TE.encodeUtf8 str -returnNil :: Env -> IO RawValue-returnNil env =-  useSymbolNameAsCString [esym|nil|] (Raw.intern env)-+mkNil :: WithCallStack => Env -> IO (RawValue 'Unknown)+mkNil env = reifySymbolUnknown env Sym.nil  render :: Pretty a => a -> Text render = render' . pretty@@ -239,4 +274,3 @@  ppCallStack :: CallStack -> Doc ann ppCallStack = pretty . prettyCallStack-

@@ -8,32 +8,32 @@ -- Wrappers around some Emacs functions, independent of concrete monad. ---------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE QuasiQuotes         #-}-{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE CPP #-} +#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+# define WINDOWS 1+#endif+ module Emacs.Module.Functions-  ( bindFunction-  , makeFunction-  , withCleanup+  ( funcallPrimitiveSym+  , funcallPrimitiveUncheckedSym+  , funcallPrimitiveSym_+  , bindFunction   , provide   , makeUserPtrFromStablePtr   , extractStablePtrFromUserPtr     -- * Haskell<->Emacs datatype conversions   , extractInt+  , extractOsPath   , makeInt-  , extractText   , makeText-  , extractShortByteString   , makeShortByteString   , extractBool   , makeBool     -- * Vectors-  , extractVector   , extractVectorWith-  , extractUnboxedVectorWith+  , extractVectorMutableWith+  , extractVectorAsPrimArrayWith   , makeVector   , vconcat2     -- * Lists@@ -46,7 +46,6 @@   , makeList   , extractList   , extractListWith-  , extractListRevWith   , foldlEmacsListWith   , unfoldEmacsListWith     -- * Strings@@ -60,78 +59,91 @@   , MonadMask   ) where +import Control.Monad import Control.Monad.Catch-import Control.Monad.Except--import Data.ByteString.Char8 qualified as C8+import Control.Monad.Interleave+import Control.Monad.Primitive (PrimState) import Data.ByteString.Short (ShortByteString) import Data.ByteString.Short qualified as BSS import Data.Foldable+import Data.Primitive.PrimArray+import Data.Primitive.Types import Data.Text (Text) import Data.Text.Encoding qualified as TE-import Data.Text.Encoding.Error qualified as TE-import Data.Vector qualified as V-import Data.Vector.Unboxed qualified as U-import Foreign.Ptr (nullPtr)+import Data.Tuple.Homogenous+import Data.Vector.Generic qualified as G+import Data.Vector.Generic.Mutable qualified as GM import Foreign.StablePtr+import System.OsPath+import System.OsString.Internal.Types -import Data.Emacs.Module.Args import Data.Emacs.Module.Env qualified as Env-import Data.Emacs.Module.SymbolName (SymbolName)-import Data.Emacs.Module.SymbolName.TH+import Data.Emacs.Module.SymbolName+import Data.Emacs.Module.SymbolName.Predefined qualified as Sym import Emacs.Module.Assert import Emacs.Module.Monad.Class +-- | Call a function by its name, similar to 'funcallPrimitive'.+{-# INLINE funcallPrimitiveSym #-}+funcallPrimitiveSym+  :: (WithCallStack, MonadEmacs m v, Foldable f)+  => SymbolName -> f (v s) -> m s (v s)+funcallPrimitiveSym func args = do+  func' <- intern func+  funcallPrimitive func' args +-- | Call a function by its name, similar to 'funcallPrimitiveUnchecked'.+{-# INLINE funcallPrimitiveUncheckedSym #-}+funcallPrimitiveUncheckedSym+  :: (WithCallStack, MonadEmacs m v, Foldable f)+  => SymbolName -> f (v s) -> m s (v s)+funcallPrimitiveUncheckedSym func args = do+  func' <- intern func+  funcallPrimitiveUnchecked func' args++-- | Call a function by its name and ignore its result, similar to 'funcallPrimitiveSym'.+{-# INLINE funcallPrimitiveSym_ #-}+funcallPrimitiveSym_+  :: (WithCallStack, MonadEmacs m v, Foldable f)+  => SymbolName -> f (v s) -> m s ()+funcallPrimitiveSym_ func args =+  void $ funcallPrimitiveSym func args+ {-# INLINABLE bindFunction #-} -- | Assign a name to function value. bindFunction-  :: (WithCallStack, MonadEmacs m, Monad (m s))+  :: (WithCallStack, MonadEmacs m v)   => SymbolName   -- ^ Name-  -> EmacsRef m s -- ^ Function value+  -> v 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+  funcallPrimitiveSym_ Sym.fset [name', def]  {-# INLINE provide #-} -- | Signal to Emacs that certain feature is being provided. Returns provided -- symbol. provide-  :: (WithCallStack, MonadEmacs m, Monad (m s))+  :: (WithCallStack, MonadEmacs m v)   => SymbolName -- ^ Feature to provide   -> m s () provide sym = do   sym' <- intern sym-  funcallPrimitive_ [esym|provide|] [sym']+  void $ funcallPrimitiveUncheckedSym Sym.provide [sym']  {-# INLINE makeUserPtrFromStablePtr #-} -- | Pack a stable pointer as Emacs @user_ptr@. makeUserPtrFromStablePtr-  :: (WithCallStack, MonadEmacs m, Monad (m s))+  :: (WithCallStack, MonadEmacs m v)   => StablePtr a-  -> m s (EmacsRef m s)+  -> m s (v s) makeUserPtrFromStablePtr =   makeUserPtr Env.freeStablePtrFinaliser . castStablePtrToPtr  {-# INLINE extractStablePtrFromUserPtr #-} extractStablePtrFromUserPtr-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s+  :: (WithCallStack, MonadEmacs m v)+  => v s   -> m s (StablePtr a) extractStablePtrFromUserPtr =   fmap castPtrToStablePtr . extractUserPtr@@ -142,7 +154,7 @@ -- 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+  :: (WithCallStack, MonadEmacs m v) => v s -> m s Int extractInt x = do   y <- extractWideInteger x   emacsAssert@@ -150,222 +162,204 @@     ("Integer is too wide to fit into Int: " ++ show y)     (pure (fromIntegral y)) +extractOsPath+  :: (WithCallStack, MonadEmacs m v) => v s -> m s OsPath+extractOsPath x = do+#ifdef WINDOWS+  OsString . WindowsString . BSS.toShort . TE.encodeUtf16LE <$> extractText x+#else+  OsString . PosixString <$> extractShortByteString x+#endif+ {-# INLINE makeInt #-} -- | Pack an 'Int' integer for Emacs. makeInt-  :: (WithCallStack, MonadEmacs m, Monad (m s)) => Int -> m s (EmacsRef m s)+  :: (WithCallStack, MonadEmacs m v) => Int -> m s (v 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)+  :: (WithCallStack, MonadEmacs m v)+  => Text -> m s (v 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)+  :: (WithCallStack, MonadEmacs m v)+  => ShortByteString -> m s (v 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+  :: (WithCallStack, MonadEmacs m v)+  => v 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+  :: (WithCallStack, MonadEmacs m v)+  => Bool -> m s (v s)+makeBool b = if b then intern Sym.t else nil -{-# INLINABLE extractVector #-}+{-# INLINE extractVectorWith #-} -- | 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)+  :: (WithCallStack, MonadEmacs m v, G.Vector w a)+  => (v s -> m s a) -> v s -> m s (w a) extractVectorWith f xs = do   n <- vecSize xs-  V.generateM n $ f <=< vecGet xs+  G.generateM n $ f <=< unsafeVecGet 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+{-# INLINE extractVectorMutableWith #-}+-- | Get all elements form an Emacs vector.+extractVectorMutableWith+  :: (WithCallStack, MonadEmacs m v, GM.MVector w a)+  => (v s -> m s a) -> v s -> m s (w (PrimState (m s)) a)+extractVectorMutableWith f xs = do   n <- vecSize xs-  U.generateM n $ f <=< vecGet xs+  GM.generateM n $ f <=< unsafeVecGet xs +{-# INLINE extractVectorAsPrimArrayWith #-}+-- | Get all elements form an Emacs vector.+extractVectorAsPrimArrayWith+  :: (WithCallStack, MonadEmacs m v, Prim a)+  => (v s -> m s a) -> v s -> m s (PrimArray a)+extractVectorAsPrimArrayWith f xs = do+  n <- vecSize xs+  generatePrimArrayA n $ f <=< unsafeVecGet 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|]+  :: (WithCallStack, MonadEmacs m v, Foldable f)+  => f (v s)+  -> m s (v s)+makeVector = funcallPrimitiveUncheckedSym Sym.vector  {-# INLINE vconcat2 #-} -- | Concatenate two vectors. vconcat2-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s-  -> EmacsRef m s-  -> m s (EmacsRef m s)+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> v s+  -> m s (v s) vconcat2 x y =-  funcallPrimitive [esym|vconcat|] [x, y]+  funcallPrimitiveSym Sym.vconcat (Tuple2 (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]+  :: (WithCallStack, MonadEmacs m v)+  => v s -- ^ car+  -> v s -- ^ cdr+  -> m s (v s)+cons x y = funcallPrimitiveUncheckedSym Sym.cons (Tuple2 (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|] . (: [])+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> m s (v s)+car = funcallPrimitiveUncheckedSym Sym.car . Tuple1  {-# 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|] . (: [])+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> m s (v s)+cdr = funcallPrimitiveUncheckedSym Sym.cdr . Tuple1  {-# INLINE nil #-} -- | A @nil@ symbol aka empty list. nil-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => m s (EmacsRef m s)-nil = intern [esym|nil|]+  :: (WithCallStack, MonadEmacs m v)+  => m s (v s)+nil = intern Sym.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+  :: (WithCallStack, MonadEmacs m v)+  => v s -- ^ Cons pair+  -> v s -- ^ New value   -> m s ()-setcar x y = funcallPrimitive_ [esym|setcar|] [x, y]+setcar x y = funcallPrimitiveSym_ Sym.setcar (Tuple2 (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+  :: (WithCallStack, MonadEmacs m v)+  => v s -- ^ Cons pair+  -> v s -- ^ New value   -> m s ()-setcdr x y = funcallPrimitive_ [esym|setcdr|] [x, y]+setcdr x y = funcallPrimitiveSym_ Sym.setcdr (Tuple2 (x, y)) +-- {-# INLINE makeList #-}+-- -- | Construct vanilla Emacs list from a Haskell list.+-- makeList+--   :: (WithCallStack, MonadEmacs m v, Foldable f)+--   => f (v s)+--   -> m s (v s)+-- makeList = unfoldEmacsListWith (pure . go) . toList+--   where+--     go = \case+--       []     -> Nothing+--       y : ys -> Just (y, ys)+ {-# 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+  :: (WithCallStack, MonadEmacs m v, Foldable f)+  => f (v s)+  -> m s (v s)+makeList xs = do+  nilVal <- nil+  mkListLoop (reverse (toList xs)) nilVal   where-    go = \case-      []     -> Nothing-      y : ys -> Just (y, ys)+    mkListLoop ys res = case ys of+      []     -> pure res+      z : zs -> mkListLoop zs =<< cons z res  {-# INLINE extractList #-} -- | Extract vanilla Emacs list as Haskell list. extractList-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s-  -> m s [EmacsRef m s]+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> m s [v 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+  :: (WithCallStack, MonadEmacs m v)+  => (v s -> m s a)+  -> v s   -> m s [a]-extractListRevWith f = go []+extractListWith f = extractListLoop   where-    go acc xs = do+    extractListLoop xs = unsafeInterleave $ do       nonNil <- isNotNil xs       if nonNil-        then do-          x   <- f =<< car xs-          xs' <- cdr xs-          go (x : acc) xs'-        else pure acc+      then+        (:) <$> (f =<< car xs) <*> (extractListLoop =<< cdr xs)+      else+        pure []  {-# INLINE foldlEmacsListWith #-} -- | Fold Emacs list starting from the left. foldlEmacsListWith-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => (a -> EmacsRef m s -> m s a)+  :: (WithCallStack, MonadEmacs m v)+  => (a -> v s -> m s a)   -> a-  -> EmacsRef m s+  -> v s   -> m s a foldlEmacsListWith f = go   where@@ -380,10 +374,10 @@ {-# INLINE unfoldEmacsListWith #-} -- | Fold Emacs list starting from the left. unfoldEmacsListWith-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => (a -> m s (Maybe (EmacsRef m s, a)))+  :: (WithCallStack, MonadEmacs m v)+  => (a -> m s (Maybe (v s, a)))   -> a-  -> m s (EmacsRef m s)+  -> m s (v s) unfoldEmacsListWith f accum = do   accum' <- f accum   nilVal <- nil@@ -397,8 +391,7 @@     go nilVal = go'       where         go' acc cell = do-          acc' <- f acc-          case acc' of+          f acc >>= \case             Nothing         -> pure ()             Just (x, acc'') -> do               cell' <- cons x nilVal@@ -408,49 +401,49 @@ {-# INLINE addFaceProp #-} -- | Add new 'face property to a string. addFaceProp-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s       -- ^ String to add face to+  :: (WithCallStack, MonadEmacs m v)+  => v s       -- ^ String to add face to   -> SymbolName         -- ^ Face name-  -> m s (EmacsRef m s) -- ^ Propertised string+  -> m s (v s) -- ^ Propertised string addFaceProp str face = do   face' <- intern face-  propertize str [([esym|face|], face')]+  propertize str [(Sym.face, face')]  {-# INLINE propertize #-} -- | Add new 'face property to a string. propertize-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s                 -- ^ String to add properties to-  -> [(SymbolName, EmacsRef m s)] -- ^ Properties-  -> m s (EmacsRef m s)           -- ^ Propertised string+  :: (WithCallStack, MonadEmacs m v)+  => v s                 -- ^ String to add properties to+  -> [(SymbolName, v s)] -- ^ Properties+  -> m s (v s)           -- ^ Propertised string propertize str props = do   props' <- traverse (\(name, val) -> (\name' -> [name', val]) <$> intern name) props-  funcallPrimitive [esym|propertize|] (str : concat props')+  funcallPrimitiveSym Sym.propertize (str : concat props')  {-# INLINE concat2 #-} -- | Concatenate two strings. concat2-  :: (WithCallStack, MonadEmacs m, Monad (m s))-  => EmacsRef m s-  -> EmacsRef m s-  -> m s (EmacsRef m s)+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> v s+  -> m s (v s) concat2 x y =-  funcallPrimitive [esym|concat|] [x, y]+  funcallPrimitiveSym Sym.concat (Tuple2 (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+  :: (WithCallStack, MonadEmacs m v)+  => v s   -> m s Text-valueToText x =-  extractText =<< funcallPrimitive [esym|prin1-to-string|] [x]+valueToText =+  extractText <=< funcallPrimitiveUncheckedSym Sym.prin1ToString . Tuple1  {-# 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|] . (:[])+  :: (WithCallStack, MonadEmacs m v)+  => v s+  -> m s (v s)+symbolName = funcallPrimitiveSym Sym.symbolName . Tuple1

@@ -1,79 +1,72 @@ ---------------------------------------------------------------------------- -- | -- Module      :  Emacs.Module.Monad--- Copyright   :  (c) Sergey Vinokurov 2018+-- Copyright   :  (c) Sergey Vinokurov 2022 -- License     :  Apache-2.0 (see LICENSE) -- Maintainer  :  serg.foo@gmail.com------ This module defines the implementation of the 'MonadEmacs'. ---------------------------------------------------------------------------- -{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImportQualifiedPost        #-}-{-# LANGUAGE InstanceSigs               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE QuasiQuotes                #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UnboxedTuples        #-}+{-# LANGUAGE UndecidableInstances #-}  module Emacs.Module.Monad-  ( EmacsM+  ( module Emacs.Module.Monad.Class+  , EmacsM   , runEmacsM   ) where +import Control.Exception import Control.Exception qualified as Exception-import Control.Monad.Catch qualified as Catch-import Control.Exception.Safe.Checked (Throws)-import Control.Exception.Safe.Checked qualified as Checked import Control.Monad.Base-import Control.Monad.Except+import Control.Monad.Catch qualified as Catch+import Control.Monad.Fix (MonadFix)+import Control.Monad.Interleave+import Control.Monad.Primitive hiding (unsafeInterleave) import Control.Monad.Reader import Control.Monad.Trans.Control-import Control.Monad.Trans.Resource as Resource- import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Unsafe qualified as BSU import Data.Coerce+import Data.Emacs.Module.Doc qualified as Doc+import Data.Int+import Data.Kind import Data.Proxy-import Data.Text qualified as T-import Data.Text.Encoding qualified as TE-import Data.Text.Encoding.Error qualified as TE-import Data.Traversable+import Data.Text (Text) import Data.Void-import Foreign (Storable(..)) import Foreign.C.Types-import Foreign.Marshal.Array-import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Ptr+import GHC.ForeignPtr+import GHC.Stack (callStack) import Prettyprinter  import Data.Emacs.Module.Args import Data.Emacs.Module.Env.Functions+import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput+import Data.Emacs.Module.GetRawValue import Data.Emacs.Module.NonNullPtr-import Data.Emacs.Module.Raw.Env qualified as 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.Raw.Env qualified as Env+import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType)+import Data.Emacs.Module.Raw.Env.Internal qualified as Env+import Data.Emacs.Module.Raw.Value+import Data.Emacs.Module.SymbolName.Internal import Data.Emacs.Module.Value.Internal import Emacs.Module.Assert import Emacs.Module.Errors import Emacs.Module.Monad.Class+import Emacs.Module.Monad.Common as Common+import Foreign.Ptr.Builder as PtrBuilder  data Environment = Environment-  { eEnv           :: !Env-  , eErrorSym      :: !(NonNullPtr RawValue)-  , eErrorData     :: !(NonNullPtr RawValue)-  , eResourceState :: !Resource.InternalState+  { eEnv           :: Env+  , eNonLocalState :: {-# UNPACK #-} !NonLocalState+  , eArgsCache     :: BuilderCache (RawValue 'Unknown)   }  -- | Concrete monad for interacting with Emacs. It provides:@@ -87,399 +80,347 @@ -- Parameter 's' serves to make ownership-tracking capabilities possible. -- It's use is the same as in 'Control.Monad.ST' monad. That is, it creates -- local threads so that no produced Emacs values can leave past 'runEmacsM'.-newtype EmacsM s a = EmacsM { unEmacsM :: ReaderT Environment IO a }+newtype EmacsM (s :: k) (a :: Type) = EmacsM { unEmacsM :: ReaderT Environment IO a }   deriving     ( Functor     , Applicative     , Monad-    , MonadIO     , Catch.MonadThrow     , Catch.MonadCatch     , Catch.MonadMask-    , MonadBase IO     , MonadFix+    , PrimMonad     ) -instance MonadResource (EmacsM s) where-  liftResourceT action = EmacsM $ do-    resState <- asks eResourceState-    liftBase $ runInternalState action resState+instance MonadInterleave (EmacsM s) where+  {-# INLINE unsafeInterleave #-}+  unsafeInterleave (EmacsM action) = EmacsM $ do+    env <- ask+    liftBase $ unsafeInterleave $ runReaderT action env +instance MonadIO (EmacsM s) where+  {-# INLINE liftIO #-}+  liftIO = EmacsM . lift++instance MonadBase IO (EmacsM s) where+  {-# INLINE liftBase #-}+  liftBase = EmacsM . lift+ 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)+  restoreM = EmacsM . restoreM  -- | Execute emacs interaction session using an environment supplied by Emacs. runEmacsM-  :: Env+  :: WithCallStack+  => 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')+runEmacsM eEnv (EmacsM action) =+  withNonLocalState $ \eNonLocalState ->+    withBuilderCache 8 $ \eArgsCache ->+      runReaderT action Environment { eEnv, eNonLocalState, eArgsCache } -{-# 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 withEnv #-}+withEnv :: (Env -> IO a) -> EmacsM s a+withEnv f = EmacsM $ do+  Environment{eEnv} <- ask+  liftBase (f eEnv) -{-# INLINE typeOfUnchecked #-}-typeOfUnchecked :: Value s -> EmacsM s RawValue-typeOfUnchecked x =-  liftIO' $ \env -> Raw.typeOf env (getRawValue x)+{-# INLINE withEnvCache #-}+withEnvCache :: (Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a+withEnvCache f = EmacsM $ do+  Environment{eEnv, eArgsCache} <- ask+  liftBase $ f eEnv (coerceBuilderCache eArgsCache) -extractTextUtf8Unchecked-  :: (WithCallStack, Throws EmacsInternalError)-  => RawValue -> EmacsM s T.Text-extractTextUtf8Unchecked =-  fmap (TE.decodeUtf8With TE.lenientDecode) . extractStringUnchecked+handleResult :: EmacsRes EmacsSignal EmacsThrow a -> IO a+handleResult = \case+  EmacsSuccess    x -> pure x+  EmacsExitSignal e -> throwIO e+  EmacsExitThrow  e -> throwIO e -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"+handleResultNoThrow :: EmacsRes EmacsSignal Void a -> IO a+handleResultNoThrow = \case+  EmacsSuccess    x -> pure x+  EmacsExitSignal e -> throwIO e+  EmacsExitThrow  e -> absurd e -instance (Throws EmacsThrow, Throws EmacsError, Throws EmacsInternalError) => MonadEmacs EmacsM where+instance MonadEmacs EmacsM Value where -  type EmacsRef    EmacsM = Value-  type EmacsReturn EmacsM = EmacsRef EmacsM+  {-# INLINE makeGlobalRef #-}+  makeGlobalRef :: WithCallStack => Value s -> EmacsM s (RawValue 'Pinned)+  makeGlobalRef x = withEnv $ \env ->+    liftBase $ Env.makeGlobalRef env $ getRawValue x -  {-# INLINE produceRef #-}-  produceRef x = do-    _ <- Resource.unprotect $ valueReleaseHandle x-    pure x+  {-# INLINE freeGlobalRef #-}+  freeGlobalRef :: WithCallStack => RawValue 'Pinned -> EmacsM s ()+  freeGlobalRef x = withEnv $ \env ->+    liftBase $ Env.freeGlobalRef env x -  {-# INLINE nonLocalExitCheck #-}-  nonLocalExitCheck = nonLocalExitCheck'+  nonLocalExitCheck+    :: WithCallStack+    => EmacsM s (FuncallExit ())+  nonLocalExitCheck = withEnv $ \env ->+    Env.nonLocalExitCheck env >>= Common.unpackEnumFuncallExit -  {-# INLINE nonLocalExitGet #-}-  nonLocalExitGet = do-    z <- nonLocalExitGet'-    for z $ \(x, y) -> (,) <$> makeValue x <*> makeValue y+  nonLocalExitGet+    :: WithCallStack+    => EmacsM s (FuncallExit (Value s, Value s))+  nonLocalExitGet = EmacsM $ do+    Environment{eEnv, eNonLocalState} <- ask+    liftBase $ do+      res <- Common.nonLocalExitGet eEnv eNonLocalState+      pure $ coerce res -  nonLocalExitSignal sym errData = do-    errData' <- funcallPrimitiveUnchecked [esym|list|] (map getRawValue errData)-    liftIO' $ \env -> Raw.nonLocalExitSignal env (getRawValue sym) errData'+  nonLocalExitSignal+    :: (WithCallStack, Foldable f)+    => Value s     -- ^ Error symbol+    -> f (Value s) -- ^ Error data, will be converted to a list as Emacs API expects.+    -> EmacsM s ()+  nonLocalExitSignal sym errData = withEnvCache $ \env cache ->+    Exception.throwIO =<< Common.nonLocalExitSignal cache env callStack (coerce sym) errData'+    where+      errData' =+        foldMap (coerce (PtrBuilder.storable :: RawValue 'Regular -> PtrBuilder.Builder (RawValue 'Regular))) errData -  {-# INLINE nonLocalExitThrow #-}-  nonLocalExitThrow tag errData = do-    liftIO' $ \env -> Raw.nonLocalExitThrow env tag' errData'-    Checked.throw EmacsThrow-      { emacsThrowTag   = tag'-      , emacsThrowValue = errData'+  nonLocalExitThrow+    :: WithCallStack+    => Value s -- ^ Tag+    -> Value s -- ^ Data+    -> EmacsM s ()+  nonLocalExitThrow tag errData = withEnv $ \env -> do+    Env.nonLocalExitThrow env tag' errData'+    Exception.throwIO EmacsThrow+      { emacsThrowTag    = tag'+      , emacsThrowValue  = errData'+      , emacsThrowOrigin = callStack       }     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+  nonLocalExitClear :: WithCallStack => EmacsM s ()+  nonLocalExitClear = withEnv Env.nonLocalExitClear -  {-# 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+  {-# INLINE makeFunction #-}+  makeFunction+    :: forall req opt rest s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)+    => (forall s'. EmacsFunction req opt rest EmacsM Value s')+    -> Doc.Doc     -> EmacsM s (Value s)-  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)+  makeFunction emacsFun doc = withEnv $ \env -> do+    impl' <- liftBase $ Env.exportToEmacs impl+    Doc.useDocAsCString doc $ \doc' -> do+      func <- Env.makeFunction env minArity maxArity impl' doc' (castFunPtrToPtr (Env.unRawFunction impl'))+      Env.setFunctionFinalizer env func Env.freeHaskellFunPtrWrapped+      pure $ Value func     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+      impl :: RawFunctionType 'Unknown ()+      impl envPtr nargs argsPtr _extraPtr = do+        let env = Env.fromPtr envPtr+        Exception.handle (reportAnyErrorToEmacs env) $+          Exception.handle (reportEmacsSignalToEmacs env) $+            Exception.handle (reportEmacsThrowToEmacs env) $+              runEmacsM env $ do+                res <- coerce (supplyEmacsArgs (fromIntegral nargs) argsPtr (pure . Value) emacsFun)+                -- Force since value may contain exceptions.+                liftIO $ evaluate res    {-# INLINE funcall #-}-  funcall name args =-    makeValue =<<-    checkExitAndRethrowInHaskell' ("funcall" <+> squotes (pretty name) <+> "failed")-      (funcallUnchecked name (map getRawValue args))+  funcall+    :: (WithCallStack, Foldable f)+    => Value s+    -> f (Value s)+    -> EmacsM s (Value s)+  funcall func args = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          coerce . handleResult+      =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState+      =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->+             Env.funcall eEnv (getRawValue func) (fromIntegral n) args') +   {-# INLINE funcallPrimitive #-}-  funcallPrimitive name args =-    makeValue =<<-    checkExitAndRethrowInHaskell' ("funcall primitive" <+> squotes (pretty name) <+> "failed")-      (funcallPrimitiveUnchecked name (map getRawValue args))+  funcallPrimitive+    :: (WithCallStack, Foldable f)+    => Value s+    -> f (Value s)+    -> EmacsM s (Value s)+  funcallPrimitive func args = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          coerce . handleResult+      =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState+      =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->+            Env.funcallPrimitive eEnv (getRawValue func) (fromIntegral n) args') -  {-# INLINE funcallPrimitive_ #-}-  funcallPrimitive_ name args =-    checkExitAndRethrowInHaskell' ("funcall primitive" <+> squotes (pretty name) <+> "failed")-      (void $ funcallPrimitiveUnchecked name (map getRawValue args))+  {-# INLINE funcallPrimitiveUnchecked #-}+  funcallPrimitiveUnchecked+    :: (WithCallStack, Foldable f)+    => Value s+    -> f (Value s)+    -> EmacsM s (Value s)+  funcallPrimitiveUnchecked func args =+    withEnvCache $ \env cache ->+      withPtrLenNonNull cache (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->+        coerce $ Env.funcallPrimitive @IO env (getRawValue func) (fromIntegral n) args' -  {-# INLINE intern #-}-  intern sym =-    makeValue =<<-    checkExitAndRethrowInHaskell' ("intern of" <+> squotes (pretty sym) <+> "failed")-      (internUnchecked sym)+  intern+    :: WithCallStack+    => SymbolName+    -> EmacsM s (Value s)+  intern sym = withEnv $ \env ->+    coerce $ reifySymbolUnknown env sym -  {-# INLINE typeOf #-}-  typeOf x =-    makeValue =<<-    checkExitAndRethrowInHaskell' "typeOf failed"-      (typeOfUnchecked x)+  typeOf+    :: WithCallStack+    => Value s -> EmacsM s (Value s)+  typeOf x = withEnv $ \env ->+    coerce $ Env.typeOf @IO env (getRawValue x)    {-# INLINE isNotNil #-}-  isNotNil x =-    checkExitAndRethrowInHaskell' "isNotNil failed"-      (liftIO' $ \env -> Raw.isTruthy <$> Raw.isNotNil env (getRawValue x))+  isNotNil :: WithCallStack => Value s -> EmacsM s Bool+  isNotNil x = withEnv $ \env ->+    Env.isTruthy <$> Env.isNotNil env (getRawValue x) -  {-# INLINE eq #-}-  eq x y =-    checkExitAndRethrowInHaskell' "eq failed"-      (liftIO' $ \env -> Raw.isTruthy <$> Raw.eq env (getRawValue x) (getRawValue y))+  eq :: Value s -> Value s -> EmacsM s Bool+  eq x y = withEnv $ \env ->+    Env.isTruthy <$> Env.eq env (getRawValue x) (getRawValue y) +  extractWideInteger :: WithCallStack => Value s -> EmacsM s Int64+  extractWideInteger x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase+      $   handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractInteger" . fromIntegral+      =<< Env.extractInteger eEnv (getRawValue x) -  {-# INLINE extractWideInteger #-}-  extractWideInteger x =-    checkExitAndRethrowInHaskell' "extractWideInteger failed"-      (liftIO' $ \env -> coerce (Raw.extractInteger env (getRawValue x) :: IO CIntMax))+  makeWideInteger :: WithCallStack => Int64 -> EmacsM s (Value s)+  makeWideInteger x = withEnv $ \env ->+    coerce $ Env.makeInteger @IO env (fromIntegral x) -  {-# INLINE makeWideInteger #-}-  makeWideInteger x =-    makeValue =<<-    checkExitAndRethrowInHaskell' ("makeWideInteger of" <+> pretty x <+> "failed")-      (liftIO' $ \env -> Raw.makeInteger env (CIntMax x))+  extractDouble :: WithCallStack => Value s -> EmacsM s Double+  extractDouble x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase+      $   handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractFloat" . (\(CDouble y) -> y)+      =<< Env.extractFloat eEnv (getRawValue x) -  {-# INLINE extractDouble #-}-  extractDouble x =-    checkExitAndRethrowInHaskell' "extractDouble failed"-      (liftIO' $ \env -> coerce (Raw.extractFloat env (getRawValue x) :: IO CDouble))+  makeDouble :: WithCallStack => Double -> EmacsM s (Value s)+  makeDouble x = withEnv $ \env ->+    coerce $ Env.makeFloat @IO env (CDouble x) -  {-# INLINE makeDouble #-}-  makeDouble x =-    makeValue =<<-    checkExitAndRethrowInHaskell' ("makeDouble" <+> pretty x <+> "failed")-      (liftIO' $ \env -> Raw.makeFloat env (CDouble x))+  extractText :: WithCallStack => Value s -> EmacsM s Text+  extractText x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase+      $   handleResultNoThrow+      =<< Common.extractText (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x) -  {-# INLINE extractString #-}-  extractString x =-    checkExitAndRethrowInHaskell' "extractString failed" $-      extractStringUnchecked (getRawValue x)+  extractShortByteString :: WithCallStack => Value s -> EmacsM s ShortByteString+  extractShortByteString x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase+      $   handleResultNoThrow+      =<< Common.extractShortByteString (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x) -  {-# INLINE makeString #-}-  makeString x =-    makeValue =<<-    checkExitAndRethrowInHaskell' "makeString failed"-      (liftIO' $ \env ->-        BS.useAsCString x $ \pStr ->-          Raw.makeString env pStr (fromIntegral (BS.length x)))+  makeString :: WithCallStack => BS.ByteString -> EmacsM s (Value s)+  makeString x = withEnv $ \env ->+    BSU.unsafeUseAsCStringLen x $ \(pStr, len) ->+      coerce $ Env.makeString @IO env pStr (fromIntegral len) -  {-# INLINE extractUserPtr #-}-  extractUserPtr x =-    checkExitAndRethrowInHaskell' "extractUserPtr failed" $-      liftIO' $ \env -> Raw.getUserPtr env $ getRawValue x+  extractUserPtr :: WithCallStack => Value s -> EmacsM s (Ptr a)+  extractUserPtr x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase+      $   handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtr"+      =<< Env.getUserPtr eEnv (getRawValue x) -  {-# INLINE makeUserPtr #-}-  makeUserPtr finaliser ptr =-    makeValue =<<-    checkExitAndRethrowInHaskell' "makeUserPtr failed"-      (liftIO' $ \env -> Raw.makeUserPtr env finaliser ptr)+  makeUserPtr+    :: WithCallStack+    => FinalizerPtr a+    -> Ptr a+    -> EmacsM s (Value s)+  makeUserPtr fin ptr = withEnv $ \env ->+    coerce $ Env.makeUserPtr @IO env fin ptr -  {-# INLINE assignUserPtr #-}-  assignUserPtr dest ptr =-    checkExitAndRethrowInHaskell' "assignUserPtr failed" $-      liftIO' $ \env -> Raw.setUserPtr env (getRawValue dest) ptr+  assignUserPtr :: WithCallStack => Value s -> Ptr a -> EmacsM s ()+  assignUserPtr dest ptr = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    -- callWithResultMayFailSignalWaitSideEffect (SetUserPtr (getRawValue dest) ptr)+    liftBase $+          handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtr"+      =<< Env.setUserPtr eEnv (getRawValue dest) ptr -  {-# INLINE extractUserPtrFinaliser #-}-  extractUserPtrFinaliser x =-    checkExitAndRethrowInHaskell' "extractUserPtrFinaliser failed" $-      liftIO' $ \env -> Raw.getUserFinaliser env $ getRawValue x+  extractUserPtrFinaliser+    :: WithCallStack => Value s -> EmacsM s (FinalizerPtr a)+  extractUserPtrFinaliser x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtrFinaliser"+      =<< Env.getUserFinaliser eEnv (getRawValue x) -  {-# INLINE assignUserPtrFinaliser #-}-  assignUserPtrFinaliser x finaliser =-    checkExitAndRethrowInHaskell' "assignUserPtrFinaliser failed" $-      liftIO' $ \env -> Raw.setUserFinaliser env (getRawValue x) finaliser+  assignUserPtrFinaliser+    :: WithCallStack => Value s -> FinalizerPtr a -> EmacsM s ()+  assignUserPtrFinaliser x fin = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtrFinaliser"+      =<< Env.setUserFinaliser eEnv (getRawValue x) fin -  {-# INLINE vecGet #-}-  vecGet vec n =-    makeValue =<<-    checkExitAndRethrowInHaskell' "vecGet failed"-      (liftIO' $ \env -> Raw.vecGet env (getRawValue vec) (fromIntegral n))+  vecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)+  vecGet vec n = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          coerce . handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecGet"+      =<< Env.vecGet eEnv (getRawValue vec) (fromIntegral n) -  {-# INLINE vecSet #-}-  vecSet vec n x =-    checkExitAndRethrowInHaskell' "vecSet failed" $-      liftIO' $ \env -> Raw.vecSet env (getRawValue vec) (fromIntegral n) (getRawValue x)+  unsafeVecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)+  unsafeVecGet vec n = EmacsM $ do+    Environment{eEnv} <- ask+    liftBase $+      coerce $+        Env.vecGet @IO eEnv (getRawValue vec) (fromIntegral n) -  {-# INLINE vecSize  #-}-  vecSize vec =-    checkExitAndRethrowInHaskell' "vecSize failed" $-      liftIO' $ \env -> fromIntegral <$> Raw.vecSize env (getRawValue vec)+  vecSet+    :: WithCallStack+    => Value s -- ^ Vector+    -> Int     -- ^ Index+    -> Value s -- ^ New value+    -> EmacsM s ()+  vecSet vec n x = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSet"+      =<< Env.vecSet eEnv (getRawValue vec) (fromIntegral n) (getRawValue x)++  vecSize :: WithCallStack => Value s -> EmacsM s Int+  vecSize vec = EmacsM $ do+    Environment{eEnv, eNonLocalState, eArgsCache} <- ask+    liftBase $+          handleResultNoThrow+      =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSize" . fromIntegral+      =<< Env.vecSize eEnv (getRawValue vec)++  processInput :: WithCallStack => EmacsM s ProcessInput.Result+  processInput =+    withEnv $ \env -> do+      Env.EnumProcessInputResult (CInt x) <- Env.processInput env+      case ProcessInput.resultFromNum x of+        Nothing ->+          throwIO $ mkEmacsInternalError $+            "Unknown value of enum emacs_process_input_result" <+> pretty x+        Just y  -> pure y

@@ -6,65 +6,60 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE ImportQualifiedPost   #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE QuantifiedConstraints  #-}+{-# LANGUAGE TypeFamilies           #-}  module Emacs.Module.Monad.Class   ( EmacsFunction-  , EmacsFunctionExtra   , MonadEmacs(..)   ) where -import Control.Exception.Safe.Checked (Throws)-+import Control.Monad.Interleave+import Control.Monad.Primitive import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Short qualified as BSS import Data.Int import Data.Kind+import Data.Text (Text)+import Data.Vector.Unboxed qualified as U+import Foreign.ForeignPtr (FinalizerPtr) import Foreign.Ptr (Ptr)  import Data.Emacs.Module.Args-import Data.Emacs.Module.Env (UserPtrFinaliser)+import Data.Emacs.Module.Doc qualified as Doc import Data.Emacs.Module.Env.Functions-import Data.Emacs.Module.SymbolName (SymbolName)+import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput+import Data.Emacs.Module.Raw.Value+import Data.Emacs.Module.SymbolName import Emacs.Module.Assert-import Emacs.Module.Errors  -- | Basic Haskell function that can be called by Emacs.-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)---- | A Haskell functions that is callable by Emacs.------ This type differs from 'EmacsFunction' in that it has an extra--- parameter which will result in an additional pointer being passed--- to this function when it's called by Emacs. Contents of the pointer is--- specified when function is exported to Emacs.-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)+type EmacsFunction req opt rest (m :: k -> Type -> Type) (v :: k -> Type) (s :: k)+  = EmacsArgs req opt rest (v s) -> m s (v s)  -- | A mtl-style typeclass for interacting with Emacs. Typeclass functions -- are mostly direct translations of emacs interface provided by 'emacs-module.h'. -- -- For more functions please refer to "Emacs.Module.Functions" module.-class MonadEmacs (m :: k -> Type -> Type) where+class+  ( forall s. Monad (m s)+  , forall s. MonadInterleave (m s)+  , forall s. U.Unbox (v s)+  , forall s. PrimMonad (m s)+  ) => MonadEmacs (m :: k -> Type -> Type) (v :: k -> Type) | m -> v where -  -- | Emacs value that is managed by the 'm' monad. Will be cleaned up-  -- after 'm' finishes its execution.-  type EmacsRef m :: k -> Type+  -- -- | 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+  -- | Make a global reference to a value so that it will persist+  -- across different calls from Emacs into exposed functions.+  makeGlobalRef :: WithCallStack => v s -> m s (RawValue 'Pinned) -  -- | Return an 'EmacsRef' back to Emacs.-  produceRef :: EmacsRef m s -> m s (EmacsReturn m s)+  -- | Free a global reference.+  freeGlobalRef :: WithCallStack => RawValue 'Pinned -> m s ()    -- | Check whether a non-local exit is pending.   nonLocalExitCheck :: WithCallStack => m s (FuncallExit ())@@ -73,148 +68,150 @@   -- in case it is.   nonLocalExitGet     :: WithCallStack-    => m s (FuncallExit (EmacsRef m s, EmacsRef m s))+    => m s (FuncallExit (v s, v s)) -  -- | Equivalent to Emacs's @signal@ function.+  -- | Equivalent to Emacs's @signal@ function. Terminates current computation.   --   -- NB if a non-local exit is alredy pending, this function will not-  -- overwrite it. In order to do that, use 'nonLocalExitClear'.+  -- overwrite it. In order to do that, first use 'nonLocalExitClear'.   nonLocalExitSignal-    :: WithCallStack-    => EmacsRef m s   -- ^ Error symbol-    -> [EmacsRef m s] -- ^ Error data, will be converted to a list as Emacs API expects.+    :: (WithCallStack, Foldable f)+    => v s     -- ^ Error symbol+    -> f (v s) -- ^ Error data, will be converted to a list as Emacs API expects.     -> m s () -  -- | Equivalent to Emacs's @throw@ function.+  -- | Equivalent to Emacs's @throw@ function. Terminates current computation.   --   -- 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+    => v s -- ^ Tag+    -> v 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+  -- | Make Haskell function available as an anonymous 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+  makeFunction     :: (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)+    => (forall s'. EmacsFunction req opt rest m v s') -- ^ Haskell function to export+    -> Doc.Doc                                        -- ^ Documentation+    -> m s (v 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)+    :: (WithCallStack, Foldable f)+    => v s     -- ^ Function name+    -> f (v s) -- ^ Arguments+    -> m s (v 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)+    :: (WithCallStack, Foldable f)+    => v s     -- ^ Function name+    -> f (v s) -- ^ Arguments+    -> m s (v 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 ()+  -- | Invoke an Emacs function. The function should be simple and+  -- must not call back into Haskell.+  --+  -- Exit status is not checked - function is expected to always+  -- succeed. Consult Emacs side to make sure that's the case.+  -- Examples of safe functions: @cons@, @list@, @vector@, etc.+  funcallPrimitiveUnchecked+    :: (WithCallStack, Foldable f)+    => v s     -- ^ Function name+    -> f (v s) -- ^ Arguments+    -> m s (v s)    -- | Convert a string to an Emacs symbol.   intern     :: WithCallStack     => SymbolName-    -> m s (EmacsRef m s)+    -> m s (v s)    -- | Get type of an Emacs value as an Emacs symbol.   typeOf     :: WithCallStack-    => EmacsRef m s -> m s (EmacsRef m s)+    => v s -> m s (v s)    -- | Check whether Emacs value is not @nil@.-  isNotNil :: WithCallStack => EmacsRef m s -> m s Bool+  isNotNil :: WithCallStack => v 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   ---  -- > funcallPrimitive [esym|equal|] [x, y]+  -- > intern "equal" >>= \equal -> funcallPrimitiveUnchecked equal [x, y]   eq     :: WithCallStack-    => EmacsRef m s -> EmacsRef m s -> m s Bool+    => v s -> v s -> m s Bool     -- | Try to unpack a wide integer from a value.-  extractWideInteger :: WithCallStack => EmacsRef m s -> m s Int64+  extractWideInteger :: WithCallStack => v s -> m s Int64    -- | Pack a wide integer for Emacs.-  makeWideInteger :: WithCallStack => Int64 -> m s (EmacsRef m s)+  makeWideInteger :: WithCallStack => Int64 -> m s (v s)    -- | Try to unpack a floating-point number from a value.-  extractDouble :: WithCallStack => EmacsRef m s -> m s Double+  extractDouble :: WithCallStack => v s -> m s Double    -- | Convert a floating-point number into Emacs value.-  makeDouble :: WithCallStack => Double -> m s (EmacsRef m s)+  makeDouble :: WithCallStack => Double -> m s (v s)    -- | Extract string contents from an Emacs value.-  extractString :: WithCallStack => EmacsRef m s -> m s BS.ByteString+  extractText :: WithCallStack => v s -> m s Text +  -- | Extract string contents from an Emacs value as utf8-encoded short bytestring.+  extractShortByteString :: WithCallStack => v s -> m s BSS.ShortByteString+   -- | Convert a utf8-encoded ByteString into an Emacs value.-  makeString :: WithCallStack => BS.ByteString -> m s (EmacsRef m s)+  makeString :: WithCallStack => BS.ByteString -> m s (v s)     -- | Extract a user pointer from an Emacs value.-  extractUserPtr :: WithCallStack => EmacsRef m s -> m s (Ptr a)+  extractUserPtr :: WithCallStack => v 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.+    => FinalizerPtr a -- ^ Finalisation action that will be executed when user pointer gets garbage-collected by Emacs.     -> Ptr a-    -> m s (EmacsRef m s)+    -> m s (v s)    -- | Set user pointer to a new value-  assignUserPtr :: WithCallStack => EmacsRef m s -> Ptr a -> m s ()+  assignUserPtr :: WithCallStack => v s -> Ptr a -> m s ()    -- | Extract a finaliser from an user_ptr.   extractUserPtrFinaliser-    :: WithCallStack => EmacsRef m s -> m s (UserPtrFinaliser a)+    :: WithCallStack => v s -> m s (FinalizerPtr a)    -- | Assign new finaliser into an user_ptr.   assignUserPtrFinaliser-    :: WithCallStack => EmacsRef m s -> UserPtrFinaliser a -> m s ()+    :: WithCallStack => v s -> FinalizerPtr a -> m s ()    -- | Extract an element from an Emacs vector.-  vecGet :: WithCallStack => EmacsRef m s -> Int -> m s (EmacsRef m s)+  vecGet :: WithCallStack => v s -> Int -> m s (v s) +  -- | Extract an element from an Emacs vector without checking for errors.+  unsafeVecGet :: WithCallStack => v s -> Int -> m s (v s)+   -- | Assign an element into an Emacs vector.   vecSet     :: WithCallStack-    => EmacsRef m s -- ^ Vector-    -> Int          -- ^ Index-    -> EmacsRef m s -- ^ New value+    => v s -- ^ Vector+    -> Int -- ^ Index+    -> v s -- ^ New value     -> m s ()    -- | Get size of an Emacs vector.-  vecSize :: WithCallStack => EmacsRef m s -> m s Int+  vecSize :: WithCallStack => v s -> m s Int++  -- | Check whether user pressed 'C-g' and we should abort our operation.+  processInput :: WithCallStack => m s ProcessInput.Result

@@ -0,0 +1,333 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Emacs.Module.Monad.Common+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnboxedTuples     #-}++module Emacs.Module.Monad.Common+  ( EmacsRes(..)+  , NonLocalState(..)+  , withNonLocalState+  , unpackEnumFuncallExit+  , unpackEnumFuncallExitSafe+  , Emacs.Module.Monad.Common.nonLocalExitGet+  , nonLocalExitSignal+  , extractText+  , extractShortByteString+  , checkNonLocalExitSignal+  , checkNonLocalExitFull+  , extractSignalInfo+  , extractTextUnsafe+  ) where++import Control.Exception+import Control.Monad.Primitive+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Short qualified as SBS+import Data.Text (Text)+import Data.Text.Array qualified as TA+import Data.Text.Internal qualified as T+import Data.Traversable+import Data.Tuple.Homogenous+import Data.Void+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import GHC.Exts+import GHC.IO+import GHC.Stack (CallStack, callStack)+import Prettyprinter++#ifdef ASSERTIONS+import Data.ByteString.Internal qualified as BSI+import Data.Text.Encoding qualified as TE+import Foreign.ForeignPtr qualified as Foreign+#endif++import Data.Emacs.Module.Env.Functions+import Data.Emacs.Module.NonNullPtr+import Data.Emacs.Module.Raw.Env (EnumFuncallExit(..))+import Data.Emacs.Module.Raw.Env qualified as Env+import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value+import Data.Emacs.Module.SymbolName.Internal+import Data.Emacs.Module.SymbolName.Predefined qualified as Sym+import Emacs.Module.Assert+import Emacs.Module.Errors+import Foreign.Ptr.Builder as PtrBuilder++data EmacsRes s t a+  = EmacsSuccess a+  | EmacsExitSignal s+  | EmacsExitThrow t+  deriving (Functor, Foldable, Traversable)++data NonLocalState = NonLocalState+  { nlsErr  :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))+  , nlsData :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))+  , nlsSize :: {-# UNPACK #-} !(NonNullPtr CPtrdiff)+  }++withNonLocalState :: (NonLocalState -> IO a) -> IO a+withNonLocalState f =+  allocaNonNull $ \ !nlsErr ->+    allocaNonNull $ \ !nlsData ->+      allocaNonNull $ \ !nlsSize ->+        f NonLocalState{nlsErr, nlsData, nlsSize}++unpackEnumFuncallExit+  :: WithCallStack+  => EnumFuncallExit -> IO (FuncallExit ())+unpackEnumFuncallExit =+  either throwIO pure . unpackEnumFuncallExitSafe++unpackEnumFuncallExitSafe+  :: WithCallStack+  => EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())+unpackEnumFuncallExitSafe (EnumFuncallExit (CInt !x)) =+  case funcallExitFromNum x of+    Nothing -> Left $ mkEmacsInternalError $+      "Unknown value of enum emacs_funcall_exit:" <+> pretty x+    Just y  -> Right y++{-# INLINE nonLocalExitGet #-}+nonLocalExitGet+  :: WithCallStack+  => Env+  -> NonLocalState+  -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))+nonLocalExitGet env NonLocalState{nlsErr, nlsData} = do+  exit <- Env.nonLocalExitGet env nlsErr nlsData+  foldFuncallExitFromNum+    (unEnumFuncallExit exit)+    (throwIO $ mkEmacsInternalError $ "Unknown value of enum emacs_funcall_exit:" <+> pretty exit)+    (\x ->+      for x $ \(_ :: ()) ->+        (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData))+  -- x <- unpackEnumFuncallExit =<< Env.nonLocalExitGet env nlsErr nlsData+  -- for x $ \(_ :: ()) ->+  --   (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData)++{-# INLINE nonLocalExitSignal #-}+nonLocalExitSignal+  :: WithCallStack+  => BuilderCache (RawValue a)+  -> Env+  -> CallStack+  -> RawValue 'Unknown           -- ^ Error symbol+  -> Builder (RawValue 'Regular) -- ^ Error data+  -> IO EmacsSignal+nonLocalExitSignal cache env !emacsSignalOrigin !sym !dat = do+  listSym <- reifySymbolUnknown env Sym.list+  withPtrLenNonNull (coerceBuilderCache cache) dat $ \n args -> do+    dat'            <- Env.funcallPrimitive env listSym (fromIntegral n) args+    emacsSignalInfo <- extractSignalInfo cache env sym dat'+    Env.nonLocalExitSignal env sym dat'+    pure EmacsSignal+      { emacsSignalSym  = toUnknown sym+      , emacsSignalData = dat'+      , emacsSignalOrigin+      , emacsSignalInfo+      }++{-# INLINE extractStringWith #-}+extractStringWith+  :: WithCallStack+  => BuilderCache (RawValue a)+  -> Env+  -> NonLocalState+  -> RawValue p+  -> (Int# -> MutableByteArray# RealWorld -> IO b)+  -> IO (EmacsRes EmacsSignal Void b)+extractStringWith cache env !nls@NonLocalState{nlsSize} !x k = do+  res <- Env.copyStringContents env x nullPtr nlsSize+  if Env.isNonTruthy res+  then do+    Env.nonLocalExitClear env+    throwIO $ mkEmacsInternalError+      "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."+  else do+    I# size# <- fromIntegral <$> peek (unNonNullPtr nlsSize)+    IO $ \s1 -> case newPinnedByteArray# size# s1 of+      (# s2, mbarr# #) -> (\kk -> kk s2) (unIO (do+        !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr#)) nlsSize+        if Env.isTruthy copyPerformed+        then+          EmacsSuccess <$> k size# mbarr#+        else+         nonLocalExitGet env nls >>= \case+           FuncallExitSignal (sym, dat) -> do+             -- Important to clean up so that we can still call Emacs functions to make nil return value, etc+             Env.nonLocalExitClear env+             emacsSignalInfo <- extractSignalInfo cache env sym dat+             pure $ EmacsExitSignal $ EmacsSignal+               { emacsSignalSym    = toUnknown sym+               , emacsSignalData   = dat+               , emacsSignalOrigin = callStack+               , emacsSignalInfo+               }+           FuncallExitReturn            ->+             throwIO $ mkEmacsInternalError "Failed to unpack string"+           FuncallExitThrow{} ->+             throwIO $ mkEmacsInternalError+               "The copy string contents operation should have never exited via throw"))++{-# INLINE extractText #-}+extractText+  :: WithCallStack+  => BuilderCache (RawValue a)+  -> Env+  -> NonLocalState+  -> RawValue p+  -> IO (EmacsRes EmacsSignal Void Text)+extractText cache env nls x =+  extractStringWith cache env nls x $ \size# mbarr# ->+#ifdef ASSERTIONS+    do+      -- Should subtract 1 from size to avoid NULL terminator at the end.+      ptr <- Foreign.newForeignPtr_ (Ptr (mutableByteArrayContents# mbarr#))+      evaluate $ TE.decodeUtf8 $ BSI.BS ptr (I# (size# -# 1#))+#else+    IO $ \s1 ->+      case unsafeFreezeByteArray# mbarr# s1 of+        (# s2, barr #) ->+          -- Should subtract 1 from size to avoid NULL terminator at the end.+          (# s2, T.Text (TA.ByteArray barr) 0 (I# (size# -# 1#)) #)+#endif++{-# INLINE extractShortByteString #-}+extractShortByteString+  :: WithCallStack+  => BuilderCache (RawValue a)+  -> Env+  -> NonLocalState+  -> RawValue p+  -> IO (EmacsRes EmacsSignal Void ShortByteString)+extractShortByteString cache env nls x =+  extractStringWith cache env nls x $ \size# mbarr# ->+    IO $ \s3 ->+      -- Should subtract 1 from size to avoid NULL terminator at the end.+      case shrinkMutableByteArray# mbarr# (size# -# 1#) s3 of+        s4 ->+          case unsafeFreezeByteArray# mbarr# s4 of+            (# s5, barr #) ->+              (# s5, SBS.SBS barr #)++{-# INLINE checkNonLocalExitSignal #-}+checkNonLocalExitSignal+  :: WithCallStack+  => BuilderCache (RawValue b)+  -> Env+  -> NonLocalState+  -> Text+  -> a+  -> IO (EmacsRes EmacsSignal Void a)+checkNonLocalExitSignal cache env !nls !errMsg !res = do+  nonLocalExitGet env nls >>= \ case+    FuncallExitReturn            ->+      pure $ EmacsSuccess res+    FuncallExitSignal (sym, dat) -> do+      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc+      Env.nonLocalExitClear env+      emacsSignalInfo <- extractSignalInfo cache env sym dat+      pure $ EmacsExitSignal $ EmacsSignal+        { emacsSignalSym    = toUnknown sym+        , emacsSignalData   = dat+        , emacsSignalOrigin = callStack+        , emacsSignalInfo+        }+    FuncallExitThrow{} ->+      throwIO $ mkEmacsInternalError $+        "The operation should have never exited via throw:" <> line <> pretty errMsg++{-# INLINE checkNonLocalExitFull #-}+checkNonLocalExitFull+  :: WithCallStack+  => BuilderCache (RawValue b)+  -> Env+  -> NonLocalState+  -> a+  -> IO (EmacsRes EmacsSignal EmacsThrow a)+checkNonLocalExitFull cache env !nls !res =+  nonLocalExitGet env nls >>= \case+    FuncallExitReturn            ->+      pure $ EmacsSuccess res+    FuncallExitSignal (sym, dat) -> do+      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc+      Env.nonLocalExitClear env+      emacsSignalInfo <- extractSignalInfo cache env sym dat+      pure $ EmacsExitSignal $ EmacsSignal+        { emacsSignalSym    = toUnknown sym+        , emacsSignalData   = dat+        , emacsSignalOrigin = callStack+        , emacsSignalInfo+        }+      -- -- Important to clean up so that we can still call Emacs+      -- -- functions to make nil return value, etc+      -- Env.nonLocalExitClear env+    FuncallExitThrow (tag, value) -> do+      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc+      Env.nonLocalExitClear env+      pure $ EmacsExitThrow $ EmacsThrow+        { emacsThrowTag    = tag+        , emacsThrowValue  = value+        , emacsThrowOrigin = callStack+        }++extractSignalInfo+  :: WithCallStack+  => BuilderCache (RawValue a) -> Env -> RawValue p -> RawValue 'Regular -> IO Text+extractSignalInfo cache env !sym !dat = do+  cons          <- reifySymbolUnknown env Sym.cons+  dat'          <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple2 (toUnknown sym, toUnknown dat)) $ \n args ->+    Env.funcallPrimitive env cons (fromIntegral n) args+  prin1ToString <- reifySymbolUnknown env Sym.prin1ToString+  formatted     <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple1 dat') $ \n args ->+    Env.funcallPrimitive env prin1ToString (fromIntegral n) args+  formatRes     <- unpackEnumFuncallExit =<< Env.nonLocalExitCheck env+  case formatRes of+    FuncallExitSignal{} -> do+      Env.nonLocalExitClear env+      throwIO $ mkEmacsInternalError "Failed to format Emacs signal data"+    FuncallExitThrow{}  -> do+      Env.nonLocalExitClear env+      throwIO $ mkEmacsInternalError "Failed to format Emacs signal data"+    FuncallExitReturn   ->+      extractTextUnsafe env formatted++extractTextUnsafe+  :: WithCallStack+  => Env+  -> RawValue p+  -> IO Text+extractTextUnsafe env !x = do+  allocaNonNull $ \pSize -> do+    res <- Env.copyStringContents env x nullPtr pSize+    if Env.isNonTruthy res+    then do+      Env.nonLocalExitClear env+      throwIO $ mkEmacsInternalError+        "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."+    else do+      !size@(I# size#) <- fromIntegral <$> peek (unNonNullPtr pSize)+      IO $ \s1 -> case newPinnedByteArray# size# s1 of+        (# s2, mbarr #) -> (\k -> k s2) (unIO (do+          !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr)) pSize+          if Env.isTruthy copyPerformed+          then+            IO $ \s3 ->+              case unsafeFreezeByteArray# mbarr s3 of+                (# s4, barr #) ->+                  -- Should subtract 1 from size to avoid NULL terminator at the end.+                  (# s4, T.Text (TA.ByteArray barr) 0 (size -  1) #)+          else do+            Env.nonLocalExitClear env+            throwIO $ mkEmacsInternalError "Failed to unpack string"))

@@ -0,0 +1,125 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Foreign.Ptr.Builder+-- Copyright   :  (c) Sergey Vinokurov 2022+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE UnboxedTuples    #-}+{-# LANGUAGE UnliftedNewtypes #-}++module Foreign.Ptr.Builder+  ( Builder+  , withByteArrayLen+  , withPtrLen+  , storable+  , prim+  , Int#+  , ByteArray#++  , BuilderCache+  , coerceBuilderCache+  , withBuilderCache+  ) where++import Data.Primitive.Types as Prim+import Emacs.Module.Assert+import Foreign+import Foreign.Storable as Storable+import GHC.Exts+import GHC.IO++type Writer = Addr# -> Int# -> IO ()++data Builder a = Builder Int# Writer++instance Show (Builder a) where+  showsPrec n (Builder k _) = showParen (n >= 10) (showString "Builder " . showsPrec 11 (I# k))++instance Semigroup (Builder a) where+  {-# INLINE (<>) #-}+  Builder n f <> Builder m g =+    Builder (n +# m) (\ptr off -> f ptr off *> g ptr (off +# n))++instance Monoid (Builder a) where+  {-# INLINE mempty #-}+  mempty = Builder 0# (\_ _ -> pure ())++isPowerOfTwo :: Int# -> Bool+isPowerOfTwo x = isTrue# (and# x' y' `eqWord#` 0##)+  where+    x' = int2Word# x+    y' = int2Word# (x -# 1#)++{-# INLINE withByteArrayLen #-}+withByteArrayLen+  :: forall a b. (WithCallStack, Storable a)+  => BuilderCache a+  -> Builder a+  -> (Int# -> ByteArray# -> IO b)+  -> IO b+withByteArrayLen (BuilderCache cache#) (Builder size f) action =+  emacsAssert (isPowerOfTwo align) "Alignment should be a power of two" $+  IO $ \s0 ->+    case getSizeofMutableByteArray# cache# s0 of+      (# s1, cacheSize #) ->+        let !(# sLast1, barr# #) =+              if isTrue# (cacheSize >=# requiredSize)+              then+                case unIO (f (mutableByteArrayContents# cache#) 0#) s1 of+                  (# s2, () #) ->+                    unsafeFreezeByteArray# cache# s2+              else+                case newAlignedPinnedByteArray# requiredSize align s1 of+                  (# s2, mbarr# #) ->+                    case unIO (f (mutableByteArrayContents# mbarr#) 0#) s2 of+                      (# s3, () #) ->+                        unsafeFreezeByteArray# mbarr# s3+        in+          -- keepAlive# barr# sLast1 (unIO (action size barr#))+          -- Touch is measurably faster but unsound if the action diverges.+          case unIO (action size barr#) sLast1 of+            (# sLast2, res #) ->+              case touch# barr# sLast2 of+                sLast3 -> (# sLast3, res #)+  where+    !requiredSize  = size *# elemSize+    !(I# elemSize) = Storable.sizeOf    (undefined :: a)+    !(I# align)    = Storable.alignment (undefined :: a)++{-# INLINE withPtrLen #-}+withPtrLen+  :: forall a b. (WithCallStack, Storable a)+  => BuilderCache a -> Builder a -> (Int -> Ptr a -> IO b) -> IO b+withPtrLen cache b action =+  withByteArrayLen cache b $ \size barr ->+    action (I# size) (Ptr (byteArrayContents# barr))+++{-# INLINE storable #-}+storable :: Storable a => a -> Builder a+storable x = Builder 1# $ \addr off -> pokeElemOff (Ptr addr) (I# off) x++{-# INLINE prim #-}+prim :: Prim a => a -> Builder a+prim x = Builder 1# $ \addr off ->+  IO $ \s ->+    case Prim.writeOffAddr# addr off x s of+      s' -> (# s', () #)++newtype BuilderCache a = BuilderCache { _unBuilderCache :: MutableByteArray# RealWorld }++coerceBuilderCache :: BuilderCache a -> BuilderCache b+coerceBuilderCache = coerce++withBuilderCache :: forall a b. Storable a => Int -> (BuilderCache a -> IO b) -> IO b+withBuilderCache (I# size) f = do+  IO $ \s0 ->+    case newAlignedPinnedByteArray# (size *# elemSize) align s0 of+      (# s1, mbarr #) ->+        keepAlive# mbarr s1 (unIO (f (BuilderCache mbarr)))+  where+    !(I# elemSize) = Storable.sizeOf    (undefined :: a)+    !(I# align)    = Storable.alignment (undefined :: a)