packages feed

emacs-module (empty) → 0.1

raw patch · 25 files changed

+3114/−0 lines, 25 filesdep +basedep +bifunctorsdep +bytestringsetup-changed

Dependencies added: base, bifunctors, bytestring, deepseq, exceptions, monad-control, mtl, prettyprinter, resourcet, safe-exceptions-checked, template-haskell, text, transformers-base, vector, void

Files

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