├── test ├── emacs-module-test.def ├── cabal.project ├── cbits │ └── emacs_wrapper.c ├── 0001-Fix-tracking-of-freed-global-values-when-module-asse.patch ├── emacs-module-test.cabal ├── src │ └── Emacs │ │ └── TestsInit.hs └── elisp │ └── haskell-emacs-module-test.el ├── .gitignore ├── cabal.project.ci ├── src ├── Data │ └── Emacs │ │ └── Module │ │ ├── Value.hs │ │ ├── Raw │ │ ├── Value.hs │ │ ├── Value │ │ │ └── Internal.hs │ │ ├── Env │ │ │ ├── Internal.hs │ │ │ └── TH.hs │ │ └── Env.hsc │ │ ├── SymbolName │ │ ├── Internal.hs-boot │ │ ├── Predefined │ │ │ └── Funcall.hs │ │ ├── TH.hs │ │ ├── Predefined.hs │ │ └── Internal.hs │ │ ├── NonNullPtr │ │ └── Internal.hs │ │ ├── SymbolName.hs │ │ ├── GetRawValue.hs │ │ ├── Env │ │ ├── ProcessInput.hsc │ │ └── Functions.hsc │ │ ├── NonNullPtr.hs │ │ ├── Runtime.hsc │ │ ├── Doc.hs │ │ ├── Env.hs │ │ ├── Value │ │ └── Internal.hs │ │ └── Args.hs ├── Emacs │ ├── Module │ │ ├── Assert.hs │ │ ├── Monad │ │ │ ├── ValueStore.hs │ │ │ ├── Class.hs │ │ │ └── Common.hs │ │ ├── Errors.hs │ │ ├── Functions.hs │ │ └── Monad.hs │ └── Module.hs └── Foreign │ └── Ptr │ └── Builder.hs ├── LICENSE ├── .github └── workflows │ └── haskell-ci.yaml ├── Changelog.md ├── Readme.md ├── emacs-module.cabal ├── Tutorial.md └── cbits └── emacs-module.h /test/emacs-module-test.def: -------------------------------------------------------------------------------- 1 | LIBRARY emacs-module-test 2 | EXPORTS 3 | plugin_is_GPL_compatible @1 4 | emacs_module_init @2 5 | -------------------------------------------------------------------------------- /test/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ../emacs-module.cabal 3 | emacs-module-test.cabal 4 | 5 | -- program-options 6 | -- ghc-options: -g3 7 | 8 | constraints: 9 | , emacs-module +assertions +call-stacks 10 | 11 | library-profiling: False 12 | library-profiling-detail: none 13 | debug-info: True 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | 26 | *.elc 27 | -------------------------------------------------------------------------------- /cabal.project.ci: -------------------------------------------------------------------------------- 1 | packages: 2 | emacs-module.cabal 3 | test/emacs-module-test.cabal 4 | 5 | constraints: 6 | , emacs-module +assertions +module-assertions 7 | , text -simdutf 8 | , prettyprinter-combinators -enummapset 9 | 10 | package emacs-module 11 | ghc-options: -Werror 12 | 13 | package emacs-module-test 14 | ghc-options: -Werror 15 | 16 | library-profiling: False -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Value.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.RawValue 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.Value 10 | ( Value 11 | ) where 12 | 13 | import Data.Emacs.Module.Value.Internal 14 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Raw/Value.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Raw.Value 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.Raw.Value 10 | ( RawValue 11 | , unRawValue 12 | , Pinning(..) 13 | , toUnknown 14 | ) where 15 | 16 | import Data.Emacs.Module.Raw.Value.Internal 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2022 Sergey Vinokurov 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName/Internal.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Data.Emacs.Module.SymbolName.Internal 4 | ( SymbolName 5 | , mkSymbolNameCache 6 | , mkCachedSymbolName 7 | , mkSymbolNameString 8 | ) where 9 | 10 | import Data.IORef 11 | 12 | import Data.Emacs.Module.Raw.Env.Internal 13 | import Data.Emacs.Module.Raw.Value 14 | 15 | data SymbolName 16 | 17 | mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned))) 18 | 19 | mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName 20 | 21 | mkSymbolNameString :: String -> SymbolName 22 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/NonNullPtr/Internal.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.NonNullPtr.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.NonNullPtr.Internal (NonNullPtr(..)) where 10 | 11 | import Control.DeepSeq 12 | import Foreign 13 | 14 | newtype NonNullPtr a = NonNullPtr { unNonNullPtr :: Ptr a } 15 | deriving (Eq, Ord, Show, NFData, Storable) 16 | 17 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.SymbolName 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.SymbolName 10 | ( SymbolName 11 | , mkSymbolName 12 | , mkSymbolNameString 13 | , mkSymbolNameShortByteString 14 | , mkSymbolNameUnsafe 15 | , reifySymbol 16 | ) where 17 | 18 | import Data.Emacs.Module.SymbolName.Internal 19 | 20 | -------------------------------------------------------------------------------- /test/cbits/emacs_wrapper.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include "HsFFI.h" 5 | #include "Rts.h" 6 | 7 | #ifdef __cplusplus 8 | extern "C" { 9 | #endif 10 | extern HsBool initialise(struct emacs_runtime *ert); 11 | #ifdef __cplusplus 12 | } 13 | #endif 14 | 15 | int plugin_is_GPL_compatible = 1; 16 | 17 | HsBool init(void) { 18 | int argc = 0; 19 | char *argv[] = { NULL }; 20 | char **pargv = argv; 21 | 22 | // Initialise Haskell runtime 23 | { 24 | RtsConfig conf = defaultRtsConfig; 25 | conf.rts_opts_enabled = RtsOptsAll; 26 | hs_init_ghc(&argc, &pargv, conf); 27 | } 28 | return HS_BOOL_TRUE; 29 | } 30 | 31 | void deinit(void) { 32 | hs_exit(); 33 | } 34 | 35 | int 36 | emacs_module_init(struct emacs_runtime *ert) 37 | { 38 | return !(init() && initialise(ert)); 39 | } 40 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/GetRawValue.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.GetRawValue 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | 11 | module Data.Emacs.Module.GetRawValue (GetRawValue(..)) where 12 | 13 | import Data.Emacs.Module.Raw.Value 14 | import Data.Emacs.Module.Value.Internal 15 | 16 | class GetRawValue a where 17 | getRawValue :: a -> RawValue 'Regular 18 | 19 | instance GetRawValue (RawValue 'Regular) where 20 | {-# INLINE getRawValue #-} 21 | getRawValue = id 22 | 23 | instance GetRawValue (Value s) where 24 | {-# INLINE getRawValue #-} 25 | getRawValue = unValue 26 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName/Predefined/Funcall.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.SymbolName.Predefined.Funcall 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | 11 | module Data.Emacs.Module.SymbolName.Predefined.Funcall 12 | ( funcall 13 | ) where 14 | 15 | import Data.IORef 16 | import System.IO.Unsafe 17 | 18 | import Data.Emacs.Module.Raw.Env.Internal 19 | import Data.Emacs.Module.Raw.Value 20 | 21 | import {-# SOURCE #-} Data.Emacs.Module.SymbolName.Internal 22 | 23 | funcallSym :: SymbolName 24 | funcallSym = mkSymbolNameString "funcall" 25 | 26 | {-# NOINLINE funcallCache #-} 27 | funcallCache :: IORef (Env -> IO (RawValue 'Pinned)) 28 | funcallCache = unsafePerformIO $ mkSymbolNameCache funcallSym 29 | 30 | funcall :: SymbolName 31 | funcall = mkCachedSymbolName funcallCache funcallSym 32 | 33 | -------------------------------------------------------------------------------- /src/Emacs/Module/Assert.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Assert 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | 11 | module Emacs.Module.Assert 12 | ( WithCallStack 13 | , emacsAssert 14 | ) where 15 | 16 | import Data.Kind (Constraint) 17 | 18 | #ifdef CALL_STACKS 19 | import GHC.Stack (HasCallStack) 20 | #endif 21 | 22 | -- | Call stacks for all emacs-related functions in Haskell. 23 | -- Will be disabled unless this package was built with 'call-stacks' 24 | -- flag enabled. 25 | #ifdef CALL_STACKS 26 | type WithCallStack = (HasCallStack :: Constraint) 27 | #else 28 | type WithCallStack = (() :: Constraint) 29 | #endif 30 | 31 | #ifdef ASSERTIONS 32 | emacsAssert :: WithCallStack => Bool -> String -> a -> a 33 | emacsAssert True _ = id 34 | emacsAssert False msg = error $ "Assertion failed: " ++ msg 35 | #else 36 | {-# INLINE emacsAssert #-} 37 | emacsAssert :: Bool -> String -> a -> a 38 | emacsAssert _ _ = id 39 | #endif 40 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Env/ProcessInput.hsc: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Env.ProcessInput 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.Env.ProcessInput 10 | ( Result(..) 11 | , resultToNum 12 | , resultFromNum 13 | ) where 14 | 15 | import Data.Data (Data) 16 | import Language.Haskell.TH.Syntax (Lift) 17 | import Prettyprinter.Generics 18 | 19 | #include 20 | 21 | -- | Result of 'process_inputs' Emacs API call. 22 | data Result 23 | = Continue 24 | | Quit 25 | deriving (Eq, Ord, Show, Data, Generic, Lift) 26 | 27 | instance Pretty Result where 28 | pretty = ppGeneric 29 | 30 | {-# INLINE resultToNum #-} 31 | resultToNum :: Num a => Result -> a 32 | resultToNum = \case 33 | Continue -> (#const emacs_process_input_continue) 34 | Quit -> (#const emacs_process_input_quit) 35 | 36 | {-# INLINE resultFromNum #-} 37 | resultFromNum :: (Eq a, Num a) => a -> Maybe Result 38 | resultFromNum = \case 39 | (#const emacs_process_input_continue) -> Just Continue 40 | (#const emacs_process_input_quit) -> Just Quit 41 | _ -> Nothing 42 | 43 | -------------------------------------------------------------------------------- /test/0001-Fix-tracking-of-freed-global-values-when-module-asse.patch: -------------------------------------------------------------------------------- 1 | From 26e6d1a15e6f792c5a08942333d536a08918e4f9 Mon Sep 17 00:00:00 2001 2 | From: Sergey Vinokurov 3 | Date: Tue, 21 Aug 2018 09:27:06 +0100 4 | Subject: [PATCH] Fix tracking of freed global values when module assertions 5 | are enabled 6 | 7 | --- 8 | src/emacs-module.c | 6 +++--- 9 | 1 file changed, 3 insertions(+), 3 deletions(-) 10 | 11 | diff --git a/src/emacs-module.c b/src/emacs-module.c 12 | index 1b19e8033d..23c24d4181 100644 13 | --- a/src/emacs-module.c 14 | +++ b/src/emacs-module.c 15 | @@ -337,17 +337,17 @@ module_free_global_ref (emacs_env *env, emacs_value ref) 16 | for (Lisp_Object tail = global_env_private.values; CONSP (tail); 17 | tail = XCDR (tail)) 18 | { 19 | - emacs_value global = XSAVE_POINTER (XCAR (globals), 0); 20 | + emacs_value global = XSAVE_POINTER (XCAR (tail), 0); 21 | if (global == ref) 22 | { 23 | if (NILP (prev)) 24 | global_env_private.values = XCDR (globals); 25 | else 26 | - XSETCDR (prev, XCDR (globals)); 27 | + XSETCDR (prev, XCDR (tail)); 28 | return; 29 | } 30 | ++count; 31 | - prev = globals; 32 | + prev = tail; 33 | } 34 | module_abort ("Global value was not found in list of %"pD"d globals", 35 | count); 36 | -- 37 | 2.18.0 38 | 39 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName/TH.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.SymbolName.TH 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MagicHash #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | 13 | module Data.Emacs.Module.SymbolName.TH 14 | ( cacheSym 15 | ) where 16 | 17 | import Data.IORef 18 | import Data.Maybe 19 | import Language.Haskell.TH 20 | import System.IO.Unsafe 21 | 22 | import Data.Emacs.Module.Raw.Env.Internal (Env) 23 | import Data.Emacs.Module.Raw.Value 24 | import Data.Emacs.Module.SymbolName.Internal qualified as Sym 25 | 26 | cacheSym :: String -> Maybe String -> Q [Dec] 27 | cacheSym sym bindingName = do 28 | ref <- newName ("ref_" ++ binding) 29 | noinline <- pragInlD ref NoInline FunLike AllPhases 30 | refSig <- sigD ref [t| IORef (Env -> IO (RawValue 'Pinned)) |] 31 | refDecl <- valD (varP ref) (normalB [e| unsafePerformIO (Sym.mkSymbolNameCache $sym') |]) [] 32 | symSig <- sigD (mkName binding) [t| Sym.SymbolName |] 33 | symDecl <- valD (varP (mkName binding)) (normalB [e| Sym.CachedSymbol $(varE ref) $sym' |]) [] 34 | pure [noinline, refSig, refDecl, symSig, symDecl] 35 | where 36 | sym' :: ExpQ 37 | sym' = [e| Sym.mkSymbolNameString $(litE (stringL sym)) |] 38 | binding = fromMaybe sym bindingName 39 | -------------------------------------------------------------------------------- /test/emacs-module-test.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: 3 | emacs-module-test 4 | version: 5 | 0.1.0.0 6 | synopsis: 7 | Tests for the emacs-module package. 8 | license: 9 | Apache-2.0 10 | author: 11 | Sergey Vinokurov 12 | maintainer: 13 | Sergey Vinokurov 14 | 15 | build-type: 16 | Simple 17 | 18 | common ghc-options 19 | default-language: 20 | GHC2021 21 | 22 | default-extensions: 23 | ImportQualifiedPost 24 | LambdaCase 25 | 26 | ghc-options: 27 | -Weverything 28 | -Wno-all-missed-specialisations 29 | -Wno-implicit-prelude 30 | -Wno-missed-specialisations 31 | -Wno-missing-import-lists 32 | -Wno-missing-local-signatures 33 | -Wno-missing-safe-haskell-mode 34 | -Wno-redundant-constraints 35 | -Wno-safe 36 | -Wno-type-defaults 37 | -Wno-unsafe 38 | 39 | if impl(ghc >= 8.8) 40 | ghc-options: 41 | -Wno-missing-deriving-strategies 42 | 43 | if impl(ghc >= 9.2) 44 | ghc-options: 45 | -Wno-missing-kind-signatures 46 | 47 | foreign-library emacs-module-test 48 | import: ghc-options 49 | type: 50 | native-shared 51 | -- lib-version-info: 52 | -- 0:0:0 53 | c-sources: 54 | cbits/emacs_wrapper.c 55 | includes: 56 | emacs-module.h 57 | install-includes: 58 | emacs-module.h 59 | include-dirs: 60 | cbits 61 | other-modules: 62 | Emacs.TestsInit 63 | 64 | if os(Windows) 65 | options: 66 | standalone 67 | mod-def-file: 68 | emacs-module-test.def 69 | 70 | ghc-options: 71 | -threaded 72 | 73 | build-depends: 74 | , base >= 4.16 && <5 75 | , bytestring 76 | , emacs-module 77 | hs-source-dirs: 78 | src 79 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/NonNullPtr.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.NonNullPtr 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | 12 | module Data.Emacs.Module.NonNullPtr 13 | ( NonNullPtr 14 | , unNonNullPtr 15 | , mkNonNullPtr 16 | , allocaNonNull 17 | , allocaBytesNonNull 18 | , withPtrLenNonNull 19 | ) where 20 | 21 | import Data.Coerce 22 | import Foreign 23 | 24 | import Data.Emacs.Module.NonNullPtr.Internal 25 | import Emacs.Module.Assert 26 | import Foreign.Ptr.Builder 27 | 28 | mkNonNullPtr :: WithCallStack => Ptr a -> NonNullPtr a 29 | #ifdef ASSERTIONS 30 | mkNonNullPtr x 31 | | x == nullPtr = error "Assertion failed: trying to make non-null pointer from a null one" 32 | | otherwise = NonNullPtr x 33 | #else 34 | mkNonNullPtr = NonNullPtr 35 | #endif 36 | 37 | {-# INLINE allocaNonNull #-} 38 | allocaNonNull :: forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b 39 | allocaNonNull = coerce (alloca :: (Ptr a -> IO b) -> IO b) 40 | 41 | {-# INLINE allocaBytesNonNull #-} 42 | allocaBytesNonNull :: forall a b. Int -> (NonNullPtr a -> IO b) -> IO b 43 | allocaBytesNonNull = coerce (allocaBytes :: Int -> (Ptr a -> IO b) -> IO b) 44 | 45 | {-# INLINE withPtrLenNonNull #-} 46 | withPtrLenNonNull 47 | :: forall a b. (WithCallStack, Storable a) 48 | => BuilderCache a -> Builder a -> (Int -> NonNullPtr a -> IO b) -> IO b 49 | withPtrLenNonNull = 50 | coerce (withPtrLen :: BuilderCache a -> Builder a -> (Int -> Ptr a -> IO b) -> IO b) 51 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName/Predefined.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.SymbolName.Predefined 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- Some commonly used symbol names which will get initialized only 9 | -- once after they're used. 10 | ---------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE MagicHash #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | 16 | module Data.Emacs.Module.SymbolName.Predefined 17 | ( error 18 | , list 19 | , cons 20 | , car 21 | , cdr 22 | , setcar 23 | , setcdr 24 | , nil 25 | , fset 26 | , provide 27 | , t 28 | , vector 29 | , vconcat 30 | , face 31 | , propertize 32 | , concat 33 | , symbolName 34 | , prin1ToString 35 | , funcall 36 | ) where 37 | 38 | import Prelude hiding (error, concat) 39 | 40 | import Data.Emacs.Module.SymbolName.TH 41 | 42 | import Data.Emacs.Module.SymbolName.Predefined.Funcall 43 | 44 | cacheSym "error" Nothing 45 | cacheSym "list" Nothing 46 | cacheSym "cons" Nothing 47 | cacheSym "car" Nothing 48 | cacheSym "cdr" Nothing 49 | cacheSym "setcar" Nothing 50 | cacheSym "setcdr" Nothing 51 | cacheSym "nil" Nothing 52 | cacheSym "fset" Nothing 53 | cacheSym "provide" Nothing 54 | cacheSym "t" Nothing 55 | cacheSym "vector" Nothing 56 | cacheSym "vconcat" Nothing 57 | cacheSym "face" Nothing 58 | cacheSym "propertize" Nothing 59 | cacheSym "concat" Nothing 60 | cacheSym "symbol-name" (Just "symbolName") 61 | cacheSym "prin1-to-string" (Just "prin1ToString") 62 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Runtime.hsc: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Runtime 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE UnliftedFFITypes #-} 10 | 11 | module Data.Emacs.Module.Runtime 12 | ( Runtime(..) 13 | , validateRuntime 14 | , withEnvironment 15 | ) where 16 | 17 | import Control.Monad.Base 18 | 19 | import Foreign 20 | import Foreign.C.Types 21 | 22 | import Data.Emacs.Module.Env qualified as Emacs 23 | import Data.Emacs.Module.Raw.Env.Internal (Env(..)) 24 | import Data.Emacs.Module.NonNullPtr 25 | 26 | import Data.Emacs.Module.NonNullPtr.Internal 27 | 28 | #include 29 | 30 | -- | Emacs environment, right from the 'emacs-module.h'. 31 | newtype Runtime = Runtime { unRuntime :: NonNullPtr Runtime } 32 | 33 | type GetEnvironentType = Runtime -> Emacs.Env 34 | 35 | foreign import ccall unsafe "dynamic" emacs_get_environment 36 | :: FunPtr GetEnvironentType -> GetEnvironentType 37 | 38 | validateRuntime :: MonadBase IO m => Ptr Runtime -> m (Maybe Runtime) 39 | validateRuntime !ptr 40 | | ptr == nullPtr = pure Nothing 41 | | otherwise = liftBase $ do 42 | size <- (#peek struct emacs_runtime, size) ptr 43 | pure $ if expectedSize <= size then Just (Runtime (NonNullPtr ptr)) else Nothing 44 | where 45 | expectedSize :: CPtrdiff 46 | expectedSize = (#size struct emacs_runtime) 47 | 48 | withEnvironment :: Runtime -> (Emacs.Env -> IO a) -> IO a 49 | withEnvironment !runtime k = do 50 | (funPtr :: FunPtr GetEnvironentType) <- (#peek struct emacs_runtime, get_environment) (unNonNullPtr $ unRuntime runtime) 51 | k (emacs_get_environment funPtr runtime) 52 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Doc.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Doc 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- Defines type that provides function's documentation that would be visible 9 | -- in Emacs. 10 | ---------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE MagicHash #-} 13 | 14 | module Data.Emacs.Module.Doc 15 | ( Doc 16 | , mkLiteralDoc 17 | , mkTextDoc 18 | , useDocAsCString 19 | ) where 20 | 21 | import Data.String 22 | import Data.Text (Text) 23 | import Data.Text qualified as T 24 | import Data.Text.Foreign qualified as T 25 | import Foreign.C.String 26 | import GHC.Exts 27 | 28 | data Doc 29 | = StaticDoc Addr# 30 | | DynamicDoc !Text 31 | 32 | instance Show Doc where 33 | show = \case 34 | DynamicDoc x -> show x 35 | StaticDoc addr -> show (unpackCString# addr) 36 | 37 | instance IsString Doc where 38 | {-# INLINE fromString #-} 39 | fromString = mkStringDoc 40 | 41 | mkStringDoc :: String -> Doc 42 | mkStringDoc = mkTextDoc . T.pack 43 | 44 | {-# INLINE [0] mkStringDoc #-} 45 | 46 | {-# RULES 47 | "Doc string literal" forall s . 48 | mkStringDoc (unpackCString# s) = mkLiteralDoc s 49 | #-} 50 | 51 | -- | Indended to be used with unboxed string literals like this 52 | -- 53 | -- @ 54 | -- mkLiteralDoc "foo"# 55 | -- @ 56 | {-# INLINE mkLiteralDoc #-} 57 | mkLiteralDoc :: Addr# -> Doc 58 | mkLiteralDoc = StaticDoc 59 | 60 | -- | Turn abritrary bytestring into 'Doc'. 61 | {-# INLINE mkTextDoc #-} 62 | mkTextDoc :: Text -> Doc 63 | mkTextDoc = DynamicDoc 64 | 65 | {-# INLINE useDocAsCString #-} 66 | useDocAsCString :: Doc -> (CString -> IO a) -> IO a 67 | useDocAsCString doc f = case doc of 68 | StaticDoc addr -> f (Ptr addr) 69 | DynamicDoc str -> T.withCString str f 70 | 71 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Env.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Env 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE ForeignFunctionInterface #-} 10 | 11 | module Data.Emacs.Module.Env 12 | ( Env 13 | 14 | , -- * enum emacs_funcall_exit 15 | FuncallExit(..) 16 | , funcallExitToNum 17 | , funcallExitFromNum 18 | 19 | , -- * Wrappers around struct emacs_env fields 20 | EnumFuncallExit(..) 21 | , isValidEnv 22 | 23 | , makeGlobalRef 24 | , freeGlobalRef 25 | 26 | , nonLocalExitCheck 27 | , nonLocalExitGet 28 | , nonLocalExitSignal 29 | , nonLocalExitThrow 30 | , nonLocalExitClear 31 | 32 | , variadicFunctionArgs 33 | , makeFunction 34 | 35 | , funcall 36 | , funcallPrimitive 37 | , intern 38 | , typeOf 39 | , isNotNil 40 | , eq 41 | , extractInteger 42 | , makeInteger 43 | , extractFloat 44 | , makeFloat 45 | , copyStringContents 46 | , makeString 47 | , makeUserPtr 48 | , getUserPtr 49 | , setUserPtr 50 | , getUserFinaliser 51 | , setUserFinaliser 52 | , vecGet 53 | , vecSet 54 | , vecSize 55 | 56 | , -- * Expose functions to Emacs 57 | exportToEmacs 58 | , RawFunctionType 59 | , RawFunction 60 | 61 | -- * Expose Haskell data to Emacs 62 | , freeStablePtrFinaliser 63 | ) where 64 | 65 | import Foreign.ForeignPtr (FinalizerPtr) 66 | 67 | import Data.Emacs.Module.Env.Functions 68 | import Data.Emacs.Module.Raw.Env.Internal 69 | import Data.Emacs.Module.Raw.Env 70 | 71 | -- | Pass to 'makeUserPtr' so that Emacs will free the Haskell's stable 72 | -- pointer when the corresponding elisp value goes out of scope. 73 | foreign import ccall "& hs_free_stable_ptr" freeStablePtrFinaliser :: FinalizerPtr a 74 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Value/Internal.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Value.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DerivingVia #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-# LANGUAGE UnboxedTuples #-} 16 | 17 | module Data.Emacs.Module.Value.Internal 18 | ( Value(..) 19 | ) where 20 | 21 | import Control.DeepSeq 22 | import Data.Primitive.Types 23 | import Data.Vector.Generic qualified as G 24 | import Data.Vector.Generic.Mutable qualified as GM 25 | import Data.Vector.Primitive qualified as P 26 | import Data.Vector.Unboxed qualified as U 27 | #if !MIN_VERSION_vector(0, 13, 1) 28 | import Data.Vector.Unboxed.Base qualified as U 29 | #endif 30 | import GHC.Generics (Generic) 31 | import Prettyprinter (Pretty) 32 | 33 | import Data.Emacs.Module.Raw.Value 34 | 35 | -- | Value that is independent of environment ('Env') that produced it. 36 | -- Incidentally, this implies that it's "protected" against Emacs GC and 37 | -- thus will not unexpectedly go out of scope. 38 | -- 39 | -- In order to prevent memory leaks, value is registered in the Emacs 40 | -- monad than produced it and will be freed when the monad finishes. 41 | -- To make the connection clear the value is tagged with parameter 42 | -- @s@, which serves the same purpose as tag of the 'ST' monad. That 43 | -- is, it ensures that value cannot leave the scope of the monad that 44 | -- produced it. 45 | newtype Value (s :: k) = Value 46 | { unValue :: RawValue 'Regular 47 | } deriving (Show, NFData, Generic, Prim, Pretty) 48 | 49 | newtype instance U.MVector s (Value s') = MV_Value (P.MVector s (Value s')) 50 | newtype instance U.Vector (Value s') = V_Value (P.Vector (Value s')) 51 | 52 | deriving via (U.UnboxViaPrim (Value s')) instance GM.MVector U.MVector (Value s') 53 | deriving via (U.UnboxViaPrim (Value s')) instance G.Vector U.Vector (Value s') 54 | 55 | instance U.Unbox (Value s') 56 | 57 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Env/Functions.hsc: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Env.Functions 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | module Data.Emacs.Module.Env.Functions 10 | ( FuncallExit(..) 11 | , funcallExitToNum 12 | , funcallExitFromNum 13 | , foldFuncallExitFromNum 14 | ) where 15 | 16 | import Data.Data (Data) 17 | import Language.Haskell.TH.Syntax (Lift) 18 | import Prettyprinter.Generics 19 | 20 | #include 21 | 22 | -- | Possible Emacs function call outcomes. This is Haskell's version of 23 | data FuncallExit a 24 | = -- | Function has returned normally. 25 | FuncallExitReturn 26 | | -- | Function has signaled an error using @signal@. 27 | FuncallExitSignal a 28 | | -- | Function has exit using @throw@. 29 | FuncallExitThrow a 30 | deriving (Eq, Ord, Show, Data, Generic, Lift, Functor, Foldable, Traversable) 31 | 32 | instance Pretty a => Pretty (FuncallExit a) where 33 | pretty = ppGeneric 34 | 35 | {-# INLINE funcallExitToNum #-} 36 | funcallExitToNum :: Num a => FuncallExit b -> a 37 | funcallExitToNum = \case 38 | FuncallExitReturn -> (#const emacs_funcall_exit_return) 39 | FuncallExitSignal{} -> (#const emacs_funcall_exit_signal) 40 | FuncallExitThrow{} -> (#const emacs_funcall_exit_throw) 41 | 42 | {-# INLINE funcallExitFromNum #-} 43 | funcallExitFromNum :: (Eq a, Num a) => a -> Maybe (FuncallExit ()) 44 | funcallExitFromNum = \case 45 | (#const emacs_funcall_exit_return) -> Just FuncallExitReturn 46 | (#const emacs_funcall_exit_signal) -> Just $ FuncallExitSignal () 47 | (#const emacs_funcall_exit_throw) -> Just $ FuncallExitThrow () 48 | _ -> Nothing 49 | 50 | {-# INLINE foldFuncallExitFromNum #-} 51 | foldFuncallExitFromNum :: (Eq a, Num a) => a -> b -> (FuncallExit () -> b) -> b 52 | foldFuncallExitFromNum x def f = case x of 53 | (#const emacs_funcall_exit_return) -> f FuncallExitReturn 54 | (#const emacs_funcall_exit_signal) -> f $ FuncallExitSignal () 55 | (#const emacs_funcall_exit_throw) -> f $ FuncallExitThrow () 56 | _ -> def 57 | 58 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Raw/Value/Internal.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Raw.Value.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DerivingVia #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | {-# LANGUAGE UnboxedTuples #-} 15 | 16 | module Data.Emacs.Module.Raw.Value.Internal 17 | ( RawValue(..) 18 | , Pinning(..) 19 | , toUnknown 20 | ) where 21 | 22 | import Control.DeepSeq 23 | import Data.Coerce 24 | import Data.Primitive.Types 25 | import Data.Vector.Generic qualified as G 26 | import Data.Vector.Generic.Mutable qualified as GM 27 | import Data.Vector.Primitive qualified as P 28 | import Data.Vector.Unboxed qualified as U 29 | #if !MIN_VERSION_vector(0, 13, 1) 30 | import Data.Vector.Unboxed.Base qualified as U 31 | #endif 32 | import Foreign 33 | import GHC.Generics (Generic) 34 | import Prettyprinter (Pretty(..)) 35 | 36 | data Pinning 37 | -- | Tag for global values are independent of environment ('Env') that produced it. 38 | -- 39 | -- Can be used to e.g. cache values that are expensive to compute from scratch. 40 | = Pinned 41 | 42 | -- | Tag denoting regular Emacs values. Will go away after control 43 | -- returns to Emacs. 44 | | Regular 45 | 46 | -- | Tag denoting either global or regular emacs values. Cannot tell 47 | -- them apart, just pass to Emacs. 48 | | Unknown 49 | 50 | toUnknown :: RawValue p -> RawValue 'Unknown 51 | toUnknown = coerce 52 | 53 | -- | Basic handle on an Emacs value. 54 | newtype RawValue (p :: Pinning) = RawValue { unRawValue :: Ptr (RawValue p) } 55 | deriving (Show, NFData, Generic, Storable, Prim) 56 | 57 | instance Pretty (RawValue p) where 58 | pretty = pretty . show . unRawValue 59 | 60 | newtype instance U.MVector s (RawValue p) = MV_RawValue (P.MVector s (RawValue p)) 61 | newtype instance U.Vector (RawValue p) = V_RawValue (P.Vector (RawValue p)) 62 | 63 | deriving via (U.UnboxViaPrim (RawValue p)) instance GM.MVector U.MVector (RawValue p) 64 | deriving via (U.UnboxViaPrim (RawValue p)) instance G.Vector U.Vector (RawValue p) 65 | 66 | instance U.Unbox (RawValue p) 67 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Raw/Env/Internal.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Env.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE ForeignFunctionInterface #-} 11 | {-# LANGUAGE MagicHash #-} 12 | {-# LANGUAGE UnliftedFFITypes #-} 13 | {-# LANGUAGE UnliftedNewtypes #-} 14 | 15 | {-# OPTIONS_HADDOCK not-home #-} 16 | 17 | module Data.Emacs.Module.Raw.Env.Internal 18 | ( Env(..) 19 | , Environment 20 | , toPtr 21 | , fromPtr 22 | , exportToEmacs 23 | , RawFunctionType 24 | , RawFunction(..) 25 | 26 | , freeHaskellFunPtrWrapped 27 | ) where 28 | 29 | import Foreign 30 | import Foreign.C.Types 31 | import GHC.Exts (Addr#, Ptr(..)) 32 | 33 | import Data.Emacs.Module.Raw.Value.Internal 34 | 35 | -- | Emacs environment, right from the 'emacs-module.h'. 36 | newtype Env = Env { unEnv# :: Addr# } 37 | 38 | data Environment 39 | 40 | {-# INLINE toPtr #-} 41 | toPtr :: Env -> Ptr Environment 42 | toPtr (Env x) = Ptr x 43 | 44 | {-# INLINE fromPtr #-} 45 | fromPtr :: Ptr Environment -> Env 46 | fromPtr (Ptr x) = Env x 47 | 48 | type RawFunctionType o a 49 | = Ptr Environment 50 | -> CPtrdiff -- Number of arguments 51 | -> Ptr (RawValue 'Regular) -- Actual arguments, always supplied by Emacs so never 'Pinned'. 52 | -> Ptr a -- Extra data 53 | -> IO (RawValue o) 54 | 55 | -- NB This is *the* coolest point of this library: *any* Haskell 56 | -- function (incl closures) may be exposed to C to be called later. 57 | -- The C/C++ will never have this... 58 | 59 | -- | Take Haskell function and return C pointer to function (which 60 | -- ideally needs to be cleaned up later by 'freeHaskellFunPtrWrapped'). 61 | foreign import ccall "wrapper" 62 | exportToEmacs :: RawFunctionType o a -> IO (RawFunction o a) 63 | 64 | -- | Pointer to a function that may later be called by by Emacs. 65 | newtype RawFunction o a = RawFunction { unRawFunction :: FunPtr (RawFunctionType o a) } 66 | deriving (Eq, Ord, Show) 67 | 68 | -- This function is defined in base. See what 'freeHaskellFunPtr' for a start. 69 | foreign import ccall unsafe "&freeHaskellFunctionPtr" 70 | freeHaskellFunPtrWrapped :: FinalizerPtr a 71 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yaml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: 3 | - push 4 | - pull_request 5 | 6 | defaults: 7 | run: 8 | shell: bash 9 | 10 | jobs: 11 | main: 12 | name: GHC ${{ matrix.ghc }} on ${{ matrix.os }} 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: [ubuntu-latest] 18 | ghc: 19 | - "9.2" 20 | - "9.4" 21 | - "9.6" 22 | - "9.8" 23 | - "9.10" 24 | - "9.12" 25 | include: 26 | - os: macOS-latest 27 | ghc: "9.12" 28 | - os: windows-latest 29 | ghc: "9.12" 30 | steps: 31 | - uses: actions/checkout@v5 32 | 33 | - uses: jcs090218/setup-emacs@master 34 | with: 35 | version: "29.4" 36 | 37 | - uses: haskell-actions/setup@v2 38 | id: setup-haskell-cabal 39 | with: 40 | ghc-version: ${{ matrix.ghc }} 41 | cabal-version: "latest" 42 | cabal-update: true 43 | 44 | - uses: actions/cache@v4 45 | name: Cache cabal store 46 | with: 47 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 48 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }} 49 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 50 | 51 | - name: Versions 52 | run: | 53 | cabal --version 54 | emacs --version 55 | 56 | - name: Build 57 | run: | 58 | cabal build all --builddir dist --project-file cabal.project.ci 59 | 60 | - name: Test 61 | run: | 62 | DYNAMIC_MODULE=$(find dist -name 'libemacs-module-test.*' -o -name 'emacs-module-test.dll') 63 | DYNAMIC_MODULE_DIR=$(dirname "$DYNAMIC_MODULE") 64 | DYNAMIC_MODULE_FILE=$(basename "$DYNAMIC_MODULE") 65 | echo "Emacs module is built at $DYNAMIC_MODULE" 66 | 67 | echo emacs -Q --batch --module-assertions -L "$DYNAMIC_MODULE_DIR" -L "test/elisp" -l "$DYNAMIC_MODULE_FILE" -l haskell-emacs-module-test -f ert-run-tests-batch-and-exit 68 | emacs -Q --batch --module-assertions -L "$DYNAMIC_MODULE_DIR" -L "test/elisp" -l "$DYNAMIC_MODULE_FILE" -l haskell-emacs-module-test -f ert-run-tests-batch-and-exit 69 | 70 | - name: Unpack 71 | run: | 72 | cabal sdist --ignore-project --output-directory .. 73 | cd .. 74 | cabal get emacs-module-*.tar.gz 75 | 76 | - name: Cabal check 77 | run: | 78 | cd ../emacs-module-*/ 79 | cabal check 80 | 81 | - name: Build fresh 82 | run: | 83 | cd ../emacs-module-*/ 84 | cabal build all 85 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # 0.3 2 | 3 | - Add `extractByteString` function to the `EmacsMonad` class 4 | 5 | # 0.2.1.1 6 | 7 | - Fix build with GHC 9.10.1 8 | 9 | # 0.2.1 10 | 11 | - Expose `make_unibyte_string` as `makeBinaryString` 12 | 13 | # 0.2 14 | 15 | - Major rework of the package’s core 16 | 17 | - Bump minimum required Emacs version to 28 due to exposing `process_input` from API. It allows to check whether user wants to abort and control should be returned back to Emacs ASAP 18 | 19 | - Bump minimum required `base` version to 4.14 - minimum supported GHC is 8.10 20 | 21 | - Symbols can be either statically known or dynamically known. This is mostly an optimization that doesn’t affect symbol use but client code may require updating. Statically known symbol are just pointers to statically allocated (by GHC) bytes and the pointers are simply passed to Emacs to create symbols. 22 | 23 | - Some commonly used symbols are now cached on first use so they won’t be re-interned on subsequent uses. New symbols can be defined by users. 24 | 25 | - `makeFunction` now cleans up after itself and no longer has memory leak if called a lot of times (which shouldn’t have typically happened anyway but still nice to have just in case) 26 | 27 | - `makeFunctionExtra` and `EmacsFunctionExtra` are gone. They offered to pass extra pointer into subroutine exposed to Emacs but it was never needed since arbitrary closure can be exposed. Now extra pointer is used to clean up result of `makeFunction`. 28 | 29 | - Removed `extractUnboxedVectorWith` - now regular `extractVector` produces generic vectors 30 | 31 | - Removed `extractVector` - `extractVectorWith` and similar for other vector/array types are preferable since they’re guaranteed to not create intermediate vectors/arrays 32 | 33 | - Introduce dedicated `Doc` type for function documentation that can be constructed from unboxed string literals to just pass the pointer around 34 | 35 | - `produceRef` and `EmacsReturn` are gone - vanilla `pure` and `EmacsRef` are enough 36 | 37 | - Symbol names got `IsString` instance and can be defined as string constants 38 | 39 | - Removed `UserPtrFinaliser` and `UserPtrFinaliserType`. Use `Foreign.ForeignPtr.FinalizerPtr` instead 40 | 41 | - `GlobalRef` got removed, instead `RawValue` is indexed by whether it’s going to be GC’ed after returning control back to Emacs 42 | 43 | - `funcall` and `funcallPrimitive` now accept any emacs value function rather than symbols only 44 | 45 | - `extractString` removed, `extractText` is now part of `MonadEmacs` typeclass 46 | 47 | # 0.1.1.1 48 | 49 | - Fix build with GHC 9.0+ 50 | - Switch license from BSD 3 to Apache 2.0 51 | - Bump minimum required GHC to 8.10 52 | - Bump minimum `prettyprinter` to 1.7 53 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # A Haskell package for writing Emacs modules 2 | 3 | ## Why would anyone want to write Emacs modules in Haskell? 4 | Emacs Lisp is not a young language and can go quite a long way, but 5 | it has a couple of issues that are not going to be solved any time soon: 6 | 7 | - It’s dynamically typed which makes refactoring large extensions a pain 8 | - It’s intepreted and is quite slow. It might be argued that editors don’t 9 | need much computing power, but from time to time computation-intensive 10 | tasks do occur. For example, fuzzy matching provided by the cool 11 | [flx.el](https://github.com/lewang/flx) package and used by great 12 | [ivy.el](https://github.com/abo-abo/swiper) package to quickly find things. 13 | - Somewhat related to the previous point, there’s virtually no support 14 | for parallelising computations. There’re [adavances](https://www.gnu.org/software/emacs/draft/manual/html_node/elisp/Threads.html) on adding threads 15 | to Emacs lisp, but this only provides [concurrency, but no parallelism](https://stackoverflow.com/questions/1050222/what-is-the-difference-between-concurrency-and-parallelism). 16 | 17 | Haskell is well known for solving points 1 and 3 outlined above. 18 | For me it also solves point 2 by providing enough performance and adding 19 | parallelism on top of it. 20 | 21 | If you think this might be a good idea and would like to see what 22 | this package can do for you, you can look at part of 23 | [my emacs config](https://github.com/sergv/emacs-native/tree/master/lib/Emacs) 24 | that uses this package to implement things like 25 | 26 | + Rewrite of `flx.el` that leverages parallelism 27 | + Fast search across filesystem 28 | + Concurrrent grep reimplementation (somewhat dubious since things like `ripgrep` exist) 29 | 30 | ## FAQ 31 | ### How do I start writing my own extensions? 32 | See tutorial at https://github.com/sergv/emacs-module/blob/master/Tutorial.md. 33 | 34 | Also check out 35 | [this package’s tests](https://github.com/sergv/emacs-module/blob/master/test/src/Emacs/TestsInit.hs). 36 | 37 | ### What about Windows? 38 | It works, Cabal can build a dll for you. 39 | 40 | ### How it’s related to [haskell-emacs](https://github.com/knupfer/haskell-emacs)? 41 | The `haskell-emacs` aims to address the same problem - writing Emacs 42 | extensions in Haskell, but uses different approach. It seems to use 43 | some kind of marshalling scheme to make Emacs data available in 44 | Haskell with a caveat that not all Emacs types can be converted (e.g. 45 | buffers cannot be typically serialised). Presumably, an extension 46 | built with this project will look like an executable that reads sexps 47 | from stdin and produces output on stdout. Or, possibly, as a daemon 48 | process that communicates with Emacs over network. 49 | 50 | This project is a bit different. It wraps Emacs C API for writing new 51 | extensions that can manipulate Emacs values directly, without 52 | marhsalling. In this approach, an extension will look like a shared 53 | library/dll that can be loaded by standard emacs with `(load "/tmp/libmy-ext.so")`. 54 | 55 | ## Supported GHC versions 56 | 57 | Tested with GHC `9.2`, `9.4`, `9.6`, `9.8`. 58 | -------------------------------------------------------------------------------- /src/Emacs/Module.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- This module is the entry point for writing Emacs extensions in 9 | -- Haskell. 10 | -- 11 | -- This package, though provides a lot of wrapping around Emacs's bare 12 | -- C interface, still presumes some familiarity with said interface. 13 | -- Thus, when developnig Emacs modules it's recommended to keep a 14 | -- reference of the C interface around. One such reference is 15 | -- . 16 | -- 17 | -- = Minimalistic example 18 | -- 19 | -- Consider Emacs function 20 | -- 21 | -- > (defun foo (f x y z &optional w t &rest quux) 22 | -- > (+ (funcall f (* x y z)) (* (or w 1) (or t 2)) (length quux))) 23 | -- 24 | -- With help of this package, it may be defined as 25 | -- 26 | -- 27 | -- > {-# LANGUAGE DataKinds #-} 28 | -- > {-# LANGUAGE QuasiQuotes #-} 29 | -- > 30 | -- > import Data.Maybe 31 | -- > import Data.Emacs.Module.SymbolName.TH 32 | -- > import Emacs.Module 33 | -- 34 | -- > foo 35 | -- > :: MonadEmacs m v 36 | -- > => EmacsFunction ('S ('S ('S ('S 'Z)))) ('S ('S 'Z)) 'True m v s 37 | -- > foo (R f (R x (R y (R z (O w (O t (Rest quux))))))) = do 38 | -- > x' <- extractInt x 39 | -- > y' <- extractInt y 40 | -- > z' <- extractInt z 41 | -- > w' <- traverse extractInt w 42 | -- > t' <- traverse extractInt t 43 | -- > 44 | -- > tmp <- makeInt (x' * y' * z') 45 | -- > tmp' <- extractInt =<< funcallSym "funcall" [f, tmp] 46 | -- > 47 | -- > produceRef =<< makeInt (tmp' + fromMaybe 1 w' * fromMaybe 2 t' + length quux) 48 | -- 49 | -- = Creating Emacs dynamic module 50 | -- In order to make shared object or dll callable from Emacs, 51 | -- a cabal project with foreign-library section has to be created. 52 | -- Please refer to 53 | -- for such a project. 54 | -- 55 | -- Please note that this project will need a small C file for initialising 56 | -- Haskell runtime. In the project mentioned before it's present as 57 | -- 58 | ---------------------------------------------------------------------------- 59 | 60 | module Emacs.Module 61 | ( 62 | -- * Basic bindings 63 | MonadEmacs(..) 64 | 65 | -- ** Define functions callable by Emacs 66 | , EmacsFunction 67 | , Nat(..) 68 | , R(..) 69 | , O(..) 70 | , Rest(..) 71 | , Stop(..) 72 | 73 | -- ** Error types 74 | , EmacsError(..) 75 | , EmacsInternalError(..) 76 | , reportAllErrorsToEmacs 77 | 78 | -- * Reexports 79 | , module Emacs.Module.Functions 80 | , module Data.Emacs.Module.Value 81 | , Env 82 | 83 | -- * Third-party reexports 84 | , MonadThrow(..) 85 | ) where 86 | 87 | import Control.Monad.Catch (MonadThrow(..)) 88 | 89 | import Data.Emacs.Module.Args 90 | import Data.Emacs.Module.Env (Env) 91 | import Data.Emacs.Module.Value 92 | import Emacs.Module.Errors 93 | import Emacs.Module.Functions 94 | import Emacs.Module.Monad.Class 95 | -------------------------------------------------------------------------------- /src/Emacs/Module/Monad/ValueStore.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Monad.ValueStore.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE BangPatterns #-} 10 | {-# LANGUAGE DerivingVia #-} 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE ImportQualifiedPost #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE NamedFieldPuns #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | 19 | module Data.Emacs.Module.ValueStore.Internal 20 | ( ReleaseHandle(..) 21 | , ValueStore(..) 22 | , dummyReleaseHandle 23 | , new 24 | , add 25 | , forget 26 | , traverse_ 27 | ) where 28 | 29 | import Control.DeepSeq 30 | import Control.Monad 31 | import Control.Monad.Primitive 32 | import Data.Coerce 33 | import Data.IORef 34 | import Data.Primitive.PrimArray 35 | import Data.Primitive.Types 36 | import Data.Vector.Generic qualified as G 37 | import Data.Vector.Generic.Mutable qualified as GM 38 | import Data.Vector.Primitive qualified as P 39 | import Data.Vector.Unboxed qualified as U 40 | import Data.Vector.Unboxed.Base qualified as U 41 | 42 | newtype ReleaseHandle = ReleaseHandle { unReleaseHandle :: Int } 43 | deriving (Eq, Ord, Show, NFData, Prim) 44 | 45 | newtype instance U.MVector s ReleaseHandle = MV_ReleaseHandle (P.MVector s ReleaseHandle) 46 | newtype instance U.Vector ReleaseHandle = V_ReleaseHandle (P.Vector ReleaseHandle) 47 | 48 | deriving via (U.UnboxViaPrim ReleaseHandle) instance GM.MVector U.MVector ReleaseHandle 49 | deriving via (U.UnboxViaPrim ReleaseHandle) instance G.Vector U.Vector ReleaseHandle 50 | 51 | instance U.Unbox ReleaseHandle 52 | 53 | -- | Release handle that does nothing 54 | dummyReleaseHandle :: ReleaseHandle 55 | dummyReleaseHandle = ReleaseHandle (-1) 56 | 57 | data Storage a = Storage 58 | { sFreshIdx :: {-# UNPACK #-} !Int 59 | , sCapacity :: {-# UNPACK #-} !Int 60 | , sValues :: {-# UNPACK #-} !(MutablePrimArray (PrimState IO) a) 61 | } 62 | 63 | newtype ValueStore a = ValueStore { unValueStore :: IORef (Storage a) } 64 | 65 | new :: forall a. Prim a => IO (ValueStore a) 66 | new = do 67 | (sValues :: MutablePrimArray (PrimState IO) a) <- newPrimArray initSize 68 | coerce $ newIORef $ Storage 69 | { sFreshIdx = 0 70 | , sCapacity = initSize 71 | , sValues 72 | } 73 | where 74 | initSize :: Int 75 | initSize = 16 76 | 77 | add :: Prim a => a -> ValueStore a -> IO ReleaseHandle 78 | add val (ValueStore ref) = do 79 | s@Storage{sFreshIdx, sCapacity, sValues} <- readIORef ref 80 | if sFreshIdx == sCapacity 81 | then do 82 | let !sCapacity' = sCapacity * 2 83 | sValues' <- resizeMutablePrimArray sValues sCapacity' 84 | writePrimArray sValues' sFreshIdx val 85 | writeIORef ref $ s { sFreshIdx = sFreshIdx + 1, sCapacity = sCapacity', sValues = sValues' } 86 | pure $ ReleaseHandle sFreshIdx 87 | else do 88 | writePrimArray sValues sFreshIdx val 89 | writeIORef ref $ s { sFreshIdx = sFreshIdx + 1 } 90 | pure $ ReleaseHandle sFreshIdx 91 | 92 | forget :: Prim a => ReleaseHandle -> a -> ValueStore a -> IO () 93 | forget (ReleaseHandle idx) val (ValueStore ref) = do 94 | Storage{sValues} <- readIORef ref 95 | writePrimArray sValues idx val 96 | 97 | traverse_ :: Prim a => (a -> IO ()) -> ValueStore a -> IO () 98 | traverse_ f = traversePrimArray_ f <=< unsafeFreezePrimArray . sValues <=< readIORef . unValueStore 99 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Raw/Env/TH.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Raw.Env.TH 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE TemplateHaskellQuotes #-} 11 | 12 | module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where 13 | 14 | import Control.Monad.IO.Class 15 | import Data.Bifunctor 16 | import Data.List qualified as L 17 | import Foreign.Ptr as Foreign 18 | import Language.Haskell.TH 19 | 20 | import Data.Emacs.Module.Raw.Env.Internal as Env 21 | 22 | decomposeFunctionType :: Type -> ([Type], Type) 23 | decomposeFunctionType = go [] 24 | where 25 | go :: [Type] -> Type -> ([Type], Type) 26 | go args = \case 27 | ForallT _ _ t -> go args t 28 | AppT (AppT ArrowT x) y -> go (x : args) y 29 | ret -> (reverse args, ret) 30 | 31 | #if MIN_VERSION_template_haskell(2, 17, 0) 32 | unwrapForall :: Type -> (Maybe ([TyVarBndr Specificity], Cxt), Type) 33 | #else 34 | unwrapForall :: Type -> (Maybe ([TyVarBndr], Cxt), Type) 35 | #endif 36 | unwrapForall (ForallT bs c t) = (Just (bs, c), t) 37 | unwrapForall t = (Nothing, t) 38 | 39 | #if MIN_VERSION_template_haskell(2, 17, 0) 40 | wrapForall :: Maybe ([TyVarBndr Specificity], Cxt) -> Type -> Type 41 | #else 42 | wrapForall :: Maybe ([TyVarBndr], Cxt) -> Type -> Type 43 | #endif 44 | wrapForall Nothing = id 45 | wrapForall (Just (bs, c)) = ForallT bs c 46 | 47 | wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ 48 | wrapEmacsFunc name safety peekExpr rawFuncType = do 49 | rawFuncType' <- rawFuncType 50 | let (forallCxt, rawFuncType'') = unwrapForall rawFuncType' 51 | (args, ret) = decomposeFunctionType rawFuncType'' 52 | (envArg, otherArgs) <- case args of 53 | [] -> fail $ 54 | "Raw function type must take at least one emacs_env argument: " ++ show rawFuncType' 55 | x : xs 56 | | x /= ConT ''Env.Env -> fail $ 57 | "Raw function type must take emacs_env as a first argument, but takes " ++ show x ++ " in " ++ show rawFuncType' 58 | | otherwise -> 59 | (,) <$> newName "env" <*> traverse (const (newName "x")) xs 60 | foreignFuncName <- newName $ "emacs_func_" ++ name 61 | let envPat :: PatQ 62 | envPat = varP envArg 63 | pats = envPat : map varP otherArgs 64 | body = normalB $ do 65 | funPtrVar <- newName "funPtr" 66 | [e|liftIO|] `appE` doE 67 | [ bindS (varP funPtrVar) $ peekExpr `appE` ([e| Env.toPtr |] `appE` varE envArg) 68 | , noBindS $ L.foldl' appE (varE foreignFuncName) (map varE $ funPtrVar : envArg : otherArgs) 69 | ] 70 | m <- newName "m" 71 | ret' <- case ret of 72 | AppT monad result 73 | | monad == ConT ''IO 74 | -> appT (varT m) (pure result) 75 | _ -> fail $ "Expected function that returns result in IO monad" 76 | let tv = PlainTV m SpecifiedSpec 77 | constraint = ConT ''MonadIO `AppT` (VarT m) 78 | typeSig <- sigD name' $ pure $ 79 | wrapForall (Just (maybe ([tv], [constraint]) (bimap (tv :) (constraint :)) forallCxt)) $ 80 | foldr (\x acc -> ArrowT `AppT` x `AppT` acc) ret' args 81 | mainDecl <- funD name' [clause pats body []] 82 | inlinePragma <- pragInlD name' Inline FunLike AllPhases 83 | let foreignDeclType :: TypeQ 84 | foreignDeclType = 85 | fmap (wrapForall forallCxt) $ 86 | arrowT `appT` (conT ''Foreign.FunPtr `appT` pure rawFuncType'') `appT` pure rawFuncType'' 87 | foreignDecl <- forImpD cCall safety "dynamic" foreignFuncName foreignDeclType 88 | pure [typeSig, mainDecl, inlinePragma, foreignDecl] 89 | where 90 | name' = mkName name 91 | 92 | -------------------------------------------------------------------------------- /emacs-module.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: 4 | emacs-module 5 | version: 6 | 0.3 7 | category: Foreign, Foreign binding 8 | 9 | synopsis: 10 | Utilities to write Emacs dynamic modules 11 | 12 | description: 13 | This package provides a full set of bindings to emacs-module.h that 14 | allows to develop Emacs modules in Haskell. Bindings are based on 15 | Emacs 28 version of the interface and thus should work in all 16 | subsequent versions of Emacs, but will now work with earlier versions. 17 | 18 | For pointers on how to write minimal Emacs module, please refer to 19 | tutorial https://github.com/sergv/emacs-module/blob/master/Tutorial.md. 20 | 21 | Entry point: Emacs.Module module. 22 | 23 | license: 24 | Apache-2.0 25 | license-file: 26 | LICENSE 27 | author: 28 | Sergey Vinokurov 29 | maintainer: 30 | Sergey Vinokurov 31 | tested-with: 32 | , GHC == 9.2 33 | , GHC == 9.4 34 | , GHC == 9.6 35 | , GHC == 9.8 36 | , GHC == 9.10 37 | , GHC == 9.12 38 | 39 | extra-source-files: 40 | cbits/emacs-module.h 41 | 42 | extra-doc-files: 43 | Changelog.md 44 | Readme.md 45 | 46 | build-type: 47 | Simple 48 | 49 | homepage: 50 | https://github.com/sergv/emacs-module 51 | 52 | source-repository head 53 | type: git 54 | location: https://github.com/sergv/emacs-module.git 55 | 56 | flag call-stacks 57 | description: 58 | Enable call stacks 59 | default: 60 | False 61 | manual: 62 | True 63 | 64 | flag assertions 65 | description: 66 | Enable runtime assertions 67 | default: 68 | False 69 | manual: 70 | True 71 | 72 | common ghc-options 73 | default-language: 74 | GHC2021 75 | 76 | default-extensions: 77 | LambdaCase 78 | 79 | ghc-options: 80 | -Weverything 81 | -Wno-all-missed-specialisations 82 | -Wno-implicit-prelude 83 | -Wno-missed-specialisations 84 | -Wno-missing-import-lists 85 | -Wno-missing-local-signatures 86 | -Wno-missing-safe-haskell-mode 87 | -Wno-redundant-constraints 88 | -Wno-safe 89 | -Wno-type-defaults 90 | -Wno-unsafe 91 | 92 | if impl(ghc >= 8.8) 93 | ghc-options: 94 | -Wno-missing-deriving-strategies 95 | 96 | if impl(ghc >= 9.2) 97 | ghc-options: 98 | -Wno-missing-kind-signatures 99 | 100 | if impl(ghc >= 9.8) 101 | ghc-options: 102 | -Wno-missing-role-annotations 103 | -Wno-missing-poly-kind-signatures 104 | 105 | library 106 | import: ghc-options 107 | if flag(call-stacks) 108 | cpp-options: -DCALL_STACKS 109 | if flag(assertions) 110 | cpp-options: -DASSERTIONS 111 | exposed-modules: 112 | Data.Emacs.Module.Args 113 | Data.Emacs.Module.Doc 114 | Data.Emacs.Module.Env 115 | Data.Emacs.Module.Env.Functions 116 | Data.Emacs.Module.Env.ProcessInput 117 | Data.Emacs.Module.GetRawValue 118 | Data.Emacs.Module.NonNullPtr 119 | Data.Emacs.Module.Runtime 120 | Data.Emacs.Module.SymbolName 121 | Data.Emacs.Module.SymbolName.Predefined 122 | Data.Emacs.Module.SymbolName.Predefined.Funcall 123 | Data.Emacs.Module.SymbolName.TH 124 | Data.Emacs.Module.Value 125 | Emacs.Module 126 | Emacs.Module.Assert 127 | Emacs.Module.Errors 128 | Emacs.Module.Functions 129 | Emacs.Module.Monad 130 | Emacs.Module.Monad.Class 131 | other-modules: 132 | Data.Emacs.Module.NonNullPtr.Internal 133 | Data.Emacs.Module.Raw.Env 134 | Data.Emacs.Module.Raw.Env.Internal 135 | Data.Emacs.Module.Raw.Env.TH 136 | Data.Emacs.Module.Raw.Value 137 | Data.Emacs.Module.Raw.Value.Internal 138 | Data.Emacs.Module.SymbolName.Internal 139 | Data.Emacs.Module.Value.Internal 140 | Emacs.Module.Monad.Common 141 | Foreign.Ptr.Builder 142 | hs-source-dirs: 143 | src 144 | build-depends: 145 | , base >= 4.16 && < 5 146 | , bytestring 147 | , deepseq 148 | , exceptions 149 | , filepath >= 1.5 150 | , monad-control 151 | , monad-interleave >= 0.2 152 | , mtl >= 2.3 153 | , os-string 154 | , primitive 155 | , prettyprinter >= 1.7 156 | , prettyprinter-combinators >= 0.1.1 157 | , text >= 2.0.1 158 | , template-haskell 159 | , transformers-base 160 | , tuples-homogenous-h98 161 | , vector >= 0.13 162 | , void 163 | 164 | includes: 165 | emacs-module.h 166 | install-includes: 167 | emacs-module.h 168 | include-dirs: 169 | cbits 170 | build-tool-depends: 171 | hsc2hs:hsc2hs -------------------------------------------------------------------------------- /src/Foreign/Ptr/Builder.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Foreign.Ptr.Builder 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE MagicHash #-} 10 | {-# LANGUAGE UnboxedTuples #-} 11 | {-# LANGUAGE UnliftedNewtypes #-} 12 | 13 | module Foreign.Ptr.Builder 14 | ( Builder 15 | , withByteArrayLen 16 | , withPtrLen 17 | , storable 18 | , prim 19 | , Int# 20 | , ByteArray# 21 | 22 | , BuilderCache 23 | , coerceBuilderCache 24 | , withBuilderCache 25 | ) where 26 | 27 | import Data.Primitive.Types as Prim 28 | import Emacs.Module.Assert 29 | import Foreign 30 | import Foreign.Storable as Storable 31 | import GHC.Exts 32 | import GHC.IO 33 | 34 | type Writer = Addr# -> Int# -> IO () 35 | 36 | data Builder a = Builder Int# Writer 37 | 38 | instance Show (Builder a) where 39 | showsPrec n (Builder k _) = showParen (n >= 10) (showString "Builder " . showsPrec 11 (I# k)) 40 | 41 | instance Semigroup (Builder a) where 42 | {-# INLINE (<>) #-} 43 | Builder n f <> Builder m g = 44 | Builder (n +# m) (\ptr off -> f ptr off *> g ptr (off +# n)) 45 | 46 | instance Monoid (Builder a) where 47 | {-# INLINE mempty #-} 48 | mempty = Builder 0# (\_ _ -> pure ()) 49 | 50 | isPowerOfTwo :: Int# -> Bool 51 | isPowerOfTwo x = isTrue# (and# x' y' `eqWord#` 0##) 52 | where 53 | x' = int2Word# x 54 | y' = int2Word# (x -# 1#) 55 | 56 | {-# INLINE withByteArrayLen #-} 57 | withByteArrayLen 58 | :: forall a b. (WithCallStack, Storable a) 59 | => BuilderCache a 60 | -> Builder a 61 | -> (Int# -> ByteArray# -> IO b) 62 | -> IO b 63 | withByteArrayLen (BuilderCache cache#) (Builder size f) action = 64 | emacsAssert (isPowerOfTwo align) "Alignment should be a power of two" $ 65 | IO $ \s0 -> 66 | case getSizeofMutableByteArray# cache# s0 of 67 | (# s1, cacheSize #) -> 68 | let !(# sLast1, barr# #) = 69 | if isTrue# (cacheSize >=# requiredSize) 70 | then 71 | case unIO (f (mutableByteArrayContents# cache#) 0#) s1 of 72 | (# s2, () #) -> 73 | unsafeFreezeByteArray# cache# s2 74 | else 75 | case newAlignedPinnedByteArray# requiredSize align s1 of 76 | (# s2, mbarr# #) -> 77 | case unIO (f (mutableByteArrayContents# mbarr#) 0#) s2 of 78 | (# s3, () #) -> 79 | unsafeFreezeByteArray# mbarr# s3 80 | in 81 | -- keepAlive# barr# sLast1 (unIO (action size barr#)) 82 | -- Touch is measurably faster but unsound if the action diverges. 83 | case unIO (action size barr#) sLast1 of 84 | (# sLast2, res #) -> 85 | case touch# barr# sLast2 of 86 | sLast3 -> (# sLast3, res #) 87 | where 88 | !requiredSize = size *# elemSize 89 | !(I# elemSize) = Storable.sizeOf (undefined :: a) 90 | !(I# align) = Storable.alignment (undefined :: a) 91 | 92 | {-# INLINE withPtrLen #-} 93 | withPtrLen 94 | :: forall a b. (WithCallStack, Storable a) 95 | => BuilderCache a -> Builder a -> (Int -> Ptr a -> IO b) -> IO b 96 | withPtrLen cache b action = 97 | withByteArrayLen cache b $ \size barr -> 98 | action (I# size) (Ptr (byteArrayContents# barr)) 99 | 100 | 101 | {-# INLINE storable #-} 102 | storable :: Storable a => a -> Builder a 103 | storable x = Builder 1# $ \addr off -> pokeElemOff (Ptr addr) (I# off) x 104 | 105 | {-# INLINE prim #-} 106 | prim :: Prim a => a -> Builder a 107 | prim x = Builder 1# $ \addr off -> 108 | IO $ \s -> 109 | case Prim.writeOffAddr# addr off x s of 110 | s' -> (# s', () #) 111 | 112 | newtype BuilderCache a = BuilderCache { _unBuilderCache :: MutableByteArray# RealWorld } 113 | 114 | coerceBuilderCache :: BuilderCache a -> BuilderCache b 115 | coerceBuilderCache = coerce 116 | 117 | withBuilderCache :: forall a b. Storable a => Int -> (BuilderCache a -> IO b) -> IO b 118 | withBuilderCache (I# size) f = do 119 | IO $ \s0 -> 120 | case newAlignedPinnedByteArray# (size *# elemSize) align s0 of 121 | (# s1, mbarr #) -> 122 | keepAlive# mbarr s1 (unIO (f (BuilderCache mbarr))) 123 | where 124 | !(I# elemSize) = Storable.sizeOf (undefined :: a) 125 | !(I# align) = Storable.alignment (undefined :: a) 126 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/SymbolName/Internal.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.SymbolName.Internal 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MagicHash #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UnliftedNewtypes #-} 13 | 14 | {-# OPTIONS_HADDOCK not-home #-} 15 | 16 | module Data.Emacs.Module.SymbolName.Internal 17 | ( Static(..) 18 | , Dynamic(..) 19 | , SymbolName(..) 20 | , mkSymbolName 21 | , mkSymbolNameString 22 | , mkSymbolNameShortByteString 23 | , mkSymbolNameUnsafe 24 | 25 | , mkSymbolNameCache 26 | , mkCachedSymbolName 27 | , reifySymbolRaw 28 | , reifySymbolUnknown 29 | , reifySymbol 30 | ) where 31 | 32 | import Data.ByteString.Internal qualified as BS 33 | import Data.ByteString.Short qualified as BSS 34 | import Data.Char 35 | import Data.Coerce 36 | import Data.IORef 37 | import Data.String 38 | import Data.Text (Text) 39 | import Data.Text qualified as T 40 | import Data.Text.Encoding qualified as TE 41 | import Data.Text.Encoding.Error qualified as TE 42 | import Data.Text.Foreign qualified as T 43 | import Foreign.C.Types 44 | import Foreign.Storable 45 | import GHC.Exts (Addr#, unpackCString#) 46 | import GHC.Ptr 47 | import Prettyprinter 48 | import System.IO.Unsafe 49 | 50 | import Data.Emacs.Module.NonNullPtr 51 | import Data.Emacs.Module.Raw.Env qualified as Raw 52 | import Data.Emacs.Module.Raw.Env.Internal 53 | import Data.Emacs.Module.Raw.Value 54 | import Emacs.Module.Assert 55 | 56 | import Data.Emacs.Module.SymbolName.Predefined.Funcall 57 | 58 | -- | Symbols that are known at compile time. 59 | -- 60 | -- Will just pass pointer to 0-terminated statically-allocated string 61 | -- to Emacs API when used. 62 | newtype Static = Static { unStatic :: Ptr CChar } 63 | deriving (Eq, Ord, Show) 64 | 65 | newtype Dynamic = Dynamic { unDynamic :: Text } 66 | deriving (Eq, Ord, Show, Pretty) 67 | 68 | data SymbolName 69 | = StaticSymbol {-# UNPACK #-} !(Ptr CChar) 70 | | DynamicSymbol {-# UNPACK #-} !Text 71 | | CachedSymbol (IORef (Env -> IO (RawValue 'Pinned))) SymbolName 72 | deriving (Eq) 73 | 74 | instance Show SymbolName where 75 | show = \case 76 | StaticSymbol (Ptr addr) 77 | -> show $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr 78 | DynamicSymbol str -> show str 79 | CachedSymbol _ sym -> show sym 80 | 81 | instance Pretty SymbolName where 82 | pretty = \case 83 | StaticSymbol (Ptr addr) 84 | -> pretty $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr 85 | DynamicSymbol str -> pretty str 86 | CachedSymbol _ sym -> pretty sym 87 | 88 | mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned))) 89 | mkSymbolNameCache = go 90 | where 91 | go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned))) 92 | go !name = 93 | unsafeFixIO $ \ ref -> 94 | newIORef $ \env -> do 95 | !global <- Raw.makeGlobalRef env =<< reifySymbolRaw env name 96 | writeIORef ref $ \_env -> pure global 97 | pure global 98 | 99 | {-# INLINE mkCachedSymbolName #-} 100 | mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName 101 | mkCachedSymbolName = CachedSymbol 102 | 103 | -- | Should be applied to unboxed string literals like this 104 | -- 105 | -- @ 106 | -- mkSymbolNameUnsafe "foo"# 107 | -- @ 108 | -- 109 | -- Can be safely applied to non-literals (e.g. arbitrary pointers) if 110 | -- it's guaranteed that address points to a null-terminated strings. 111 | -- Otherwise behaviour is undefined. 112 | -- 113 | -- The string literal must only contain ASCII symbols. This condition 114 | -- is required by the Emacs API and results in undefined behaviour if 115 | -- violated. 116 | {-# INLINE mkSymbolNameUnsafe #-} 117 | mkSymbolNameUnsafe :: Addr# -> SymbolName 118 | mkSymbolNameUnsafe addr = StaticSymbol (Ptr addr) 119 | 120 | {-# INLINE mkSymbolName #-} 121 | mkSymbolName :: Text -> SymbolName 122 | mkSymbolName = DynamicSymbol 123 | 124 | {-# INLINE mkSymbolNameShortByteString #-} 125 | mkSymbolNameShortByteString :: BSS.ShortByteString -> SymbolName 126 | mkSymbolNameShortByteString = DynamicSymbol . TE.decodeUtf8With TE.lenientDecode . BSS.fromShort 127 | 128 | {-# INLINE [0] mkSymbolNameString #-} 129 | mkSymbolNameString :: String -> SymbolName 130 | mkSymbolNameString = mkSymbolName . T.pack 131 | 132 | instance IsString SymbolName where 133 | {-# INLINE fromString #-} 134 | fromString = mkSymbolNameString 135 | 136 | {-# RULES 137 | "SymbolName string literal" forall s . 138 | mkSymbolNameString (unpackCString# s) = mkSymbolNameUnsafe s 139 | #-} 140 | 141 | {-# INLINE reifySymbolRaw #-} 142 | reifySymbolRaw :: Env -> SymbolName -> IO (RawValue 'Regular) 143 | reifySymbolRaw env sym = reifySymbol env sym id coerce 144 | 145 | {-# INLINE reifySymbolUnknown #-} 146 | reifySymbolUnknown :: Env -> SymbolName -> IO (RawValue 'Unknown) 147 | reifySymbolUnknown env sym = reifySymbol env sym coerce coerce 148 | 149 | {-# INLINE reifySymbol #-} 150 | reifySymbol 151 | :: WithCallStack 152 | => Env -> SymbolName -> (RawValue 'Regular -> a) -> (RawValue 'Pinned -> a) -> IO a 153 | reifySymbol env sym f g = case sym of 154 | StaticSymbol addr -> 155 | f <$> Raw.intern env addr 156 | DynamicSymbol str 157 | -- If it's only ASCII then can run FFI intern, otherwise have to go via funcall 158 | -- TODO: cache this check 159 | | T.all (\c -> ord c < 128) str -> 160 | f <$> T.withCString str (Raw.intern env) 161 | | otherwise -> 162 | T.withCStringLen str $ \(ptr, len) -> do 163 | str' <- emacsAssert (len >= 0) "Symbol text length must be non-negative" $ 164 | Raw.makeString env ptr (fromIntegral len) 165 | funcall' <- reifySymbolUnknown env funcall 166 | allocaNonNull $ \args -> do 167 | poke (unNonNullPtr args) str' 168 | f <$> Raw.funcallPrimitive env funcall' 1 args 169 | 170 | CachedSymbol ref _ -> 171 | g <$> ((\k -> k env) =<< readIORef ref) 172 | -------------------------------------------------------------------------------- /test/src/Emacs/TestsInit.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Emacs.TestsInit 3 | -- Copyright : (c) Sergey Vinokurov 2018 4 | -- License : Apache-2.0 (see LICENSE) 5 | -- Maintainer : serg.foo@gmail.com 6 | ---------------------------------------------------------------------------- 7 | 8 | {-# LANGUAGE CPP #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE ForeignFunctionInterface #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | 15 | module Emacs.TestsInit () where 16 | 17 | import Data.ByteString.Char8 qualified as C8 18 | import Data.Functor 19 | import Data.Maybe 20 | import Foreign hiding (void) 21 | import Foreign.C 22 | 23 | import Data.Emacs.Module.Args 24 | import Data.Emacs.Module.Runtime (Runtime) 25 | import Data.Emacs.Module.Runtime qualified as Runtime 26 | import Data.Emacs.Module.SymbolName.Predefined qualified as Sym 27 | import Emacs.Module 28 | import Emacs.Module.Assert 29 | import Emacs.Module.Monad 30 | 31 | foreign export ccall initialise :: Ptr Runtime -> IO CBool 32 | 33 | true, false :: CBool 34 | true = CBool 1 35 | false = CBool 0 36 | 37 | initialise :: WithCallStack => Ptr Runtime -> IO CBool 38 | initialise runtime = do 39 | runtime' <- Runtime.validateRuntime runtime 40 | case runtime' of 41 | Nothing -> pure false 42 | Just runtime'' -> 43 | Runtime.withEnvironment runtime'' $ \env -> do 44 | res <- reportAllErrorsToEmacs env (pure False) $ runEmacsM env initialise' 45 | pure $ if res then true else false 46 | 47 | initialise' 48 | :: (WithCallStack, MonadEmacs m v) 49 | => m s Bool 50 | initialise' = do 51 | bindFunction "haskell-emacs-module-tests-apply2" =<< 52 | makeFunction apply2 "Apply a function twice." 53 | bindFunction "haskell-emacs-module-tests-apply2-alt" =<< 54 | makeFunction apply2Alt "Apply a function twice." 55 | bindFunction "haskell-emacs-module-tests-add" =<< 56 | makeFunction add "Add two numbers." 57 | bindFunction "haskell-emacs-module-tests-get-rest" =<< 58 | makeFunction getRest "Just return the &rest argument." 59 | bindFunction "haskell-emacs-module-tests-append-lots-of-strings" =<< 60 | makeFunction appendLotsOfStrings "Append foo string N times to itself." 61 | bindFunction "haskell-emacs-module-tests-append-lots-of-vectors" =<< 62 | makeFunction appendLotsOfVectors "Append [1 2 3] vector N times to itself." 63 | bindFunction "haskell-emacs-module-tests-replicate" =<< 64 | makeFunction emacsReplicate "Replicate an item N times" 65 | bindFunction "haskell-emacs-module-tests-grow-list" =<< 66 | makeFunction emacsGrowList "Append list with itself" 67 | bindFunction "haskell-emacs-module-tests-incorrect-vector-assignment" =<< 68 | makeFunction emacsIncorrectVectorAssignment "vecSet that should result in error" 69 | pure True 70 | 71 | apply2 72 | :: (WithCallStack, MonadEmacs m v) 73 | => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s 74 | apply2 (R f (R x Stop)) = do 75 | y <- funcall f [x] 76 | funcall f [y] 77 | 78 | apply2Alt 79 | :: (WithCallStack, MonadEmacs m v) 80 | => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s 81 | apply2Alt (R f (R x Stop)) = do 82 | funcallSym <- intern Sym.funcall 83 | y <- funcall funcallSym [f, x] 84 | res <- funcall funcallSym [f, y] 85 | pure res 86 | 87 | add 88 | :: (WithCallStack, MonadEmacs m v) 89 | => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s 90 | add (R x (R y Stop)) = 91 | makeInt =<< (+) <$> extractInt x <*> extractInt y 92 | 93 | getRest 94 | :: (WithCallStack, MonadEmacs m v) 95 | => EmacsFunction ('S 'Z) 'Z 'True m v s 96 | getRest (R _req (Rest rest)) = do 97 | vectorSym <- intern Sym.vector 98 | funcall vectorSym rest 99 | 100 | appendLotsOfStrings 101 | :: forall m v s. (WithCallStack, MonadEmacs m v) 102 | => EmacsFunction ('S 'Z) 'Z 'False m v s 103 | appendLotsOfStrings (R n Stop) = do 104 | n' <- extractInt n 105 | -- foo' <- makeString "foo" 106 | empty' <- makeString "" 107 | let input :: [(m s (v s), C8.ByteString)] 108 | input = replicate n' (makeString "foo", "foo") 109 | res = appendTree concat2' input 110 | res' <- traverse fst res 111 | pure $ fromMaybe empty' res' 112 | 113 | appendLotsOfVectors 114 | :: (WithCallStack, MonadEmacs m v) 115 | => EmacsFunction ('S 'Z) 'Z 'False m v s 116 | appendLotsOfVectors (R n Stop) = do 117 | n' <- extractInt n 118 | one <- makeInt 1 119 | two <- makeInt 2 120 | three <- makeInt 3 121 | 122 | empty' <- makeVector [] 123 | 124 | let input = replicate n' (makeVector [one, two, three], [1, 2, 3]) 125 | res = appendTree vconcat2' input 126 | res' <- traverse fst res 127 | pure $ fromMaybe empty' res' 128 | 129 | emacsReplicate 130 | :: (WithCallStack, MonadEmacs m v) 131 | => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s 132 | emacsReplicate (R n (R x Stop)) = do 133 | n' <- extractInt n 134 | makeList (replicate n' x) 135 | 136 | emacsGrowList 137 | :: (WithCallStack, MonadEmacs m v) 138 | => EmacsFunction ('S 'Z) 'Z 'False m v s 139 | emacsGrowList (R xs Stop) = do 140 | ys <- extractList xs 141 | makeList $ ys ++ ys ++ ys 142 | 143 | emacsIncorrectVectorAssignment 144 | :: (WithCallStack, MonadEmacs m v) 145 | => EmacsFunction 'Z 'Z 'False m v s 146 | emacsIncorrectVectorAssignment Stop = do 147 | n <- makeInt 36 148 | vec <- makeVector $ replicate 42 n 149 | vecSet vec 42 n 150 | nil 151 | 152 | concat2' 153 | :: (WithCallStack, MonadEmacs m v) 154 | => (m s (v s), C8.ByteString) 155 | -> (m s (v s), C8.ByteString) 156 | -> (m s (v s), C8.ByteString) 157 | concat2' (x, xStr) (y, yStr) = 158 | (go, xStr <> yStr) 159 | where 160 | go = do 161 | x' <- x 162 | y' <- y 163 | gcSym <- intern "garbage-collect" 164 | void $ funcallPrimitiveUnchecked gcSym [] 165 | concat2 x' y' 166 | 167 | vconcat2' 168 | :: (WithCallStack, MonadEmacs m v) 169 | => (m s (v s), [Int]) 170 | -> (m s (v s), [Int]) 171 | -> (m s (v s), [Int]) 172 | vconcat2' (x, xs) (y, ys) = 173 | (go, xs <> ys) 174 | where 175 | go = do 176 | x' <- x 177 | y' <- y 178 | gcSym <- intern "garbage-collect" 179 | void $ funcallPrimitiveUnchecked gcSym [] 180 | vconcat2 x' y' 181 | 182 | appendTree :: (a -> a -> a) -> [a] -> Maybe a 183 | appendTree f = reduce 184 | where 185 | go [] = [] 186 | go xs@[_] = xs 187 | go (x1 : x2 : xs) = f x1 x2 : go xs 188 | 189 | reduce [] = Nothing 190 | reduce [x] = Just x 191 | reduce xs = reduce (go xs) 192 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Args.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Args 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeFamilyDependencies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Data.Emacs.Module.Args 16 | ( Nat(..) 17 | , EmacsArgs 18 | , EmacsInvocation(..) 19 | , GetArities(..) 20 | 21 | -- * Argument inference 22 | , R(..) 23 | , O(..) 24 | , Rest(..) 25 | , Stop(..) 26 | ) where 27 | 28 | import Control.Monad.Base 29 | 30 | import Data.Kind 31 | import Data.Proxy 32 | import Foreign 33 | import Foreign.C.Types (CPtrdiff) 34 | 35 | import Data.Emacs.Module.Raw.Env (variadicFunctionArgs) 36 | import Data.Emacs.Module.Raw.Value 37 | 38 | -- | Type-level Peano numbers. 39 | -- 40 | -- Indented to be used with @DataKinds@ extension enabled. 41 | data Nat = Z | S Nat 42 | 43 | class NatValue (n :: Nat) where 44 | natValue :: Proxy n -> Int 45 | 46 | instance NatValue 'Z where 47 | {-# INLINE natValue #-} 48 | natValue _ = 0 49 | 50 | instance forall n. NatValue n => NatValue ('S n) where 51 | {-# INLINE natValue #-} 52 | natValue _ = 1 + natValue (Proxy @n) 53 | 54 | -- | Required argument of an exported function. 55 | data R a b = R !a !b 56 | 57 | -- | Optional argument of an exported function. 58 | data O a b = O !(Maybe a) !b 59 | 60 | -- | All other arguments of an exported function as a list. 61 | newtype Rest a = Rest [a] 62 | 63 | -- | End of argument list of an exported funciton. 64 | data Stop a = Stop 65 | 66 | -- | Specification of the arguments that exposed functions can receive from Emacs. 67 | -- 68 | -- This type family allows to declaratively specify how many required and 69 | -- optional arguments a function can take and whether it accepts rest arguments. 70 | -- It's a direct translation of argument lists in Emacs lisp, e.g. 71 | -- 72 | -- > (defun foo (x y z &optional w t &rest quux) 73 | -- > (+ (* x y z) (* (or w 1) (or t 2)) (length quux))) 74 | -- 75 | -- The function above has 3 required arguments, 2 optional and also has 76 | -- rest arguments. The type family below has two 'Nat's and one 'Bool' 77 | -- to provide that info. 78 | type family EmacsArgs (req :: Nat) (opt :: Nat) (rest :: Bool) (a :: Type) = (r :: Type) | r -> req opt rest a where 79 | EmacsArgs ('S n) opt rest a = R a (EmacsArgs n opt rest a) 80 | EmacsArgs 'Z ('S k) rest a = O a (EmacsArgs 'Z k rest a) 81 | EmacsArgs 'Z 'Z 'True a = Rest a 82 | EmacsArgs 'Z 'Z 'False a = Stop a 83 | 84 | class EmacsInvocation req opt rest where 85 | supplyEmacsArgs 86 | :: MonadBase IO m 87 | => Int 88 | -> Ptr (RawValue 'Regular) 89 | -> (RawValue 'Regular -> m a) 90 | -> (EmacsArgs req opt rest a -> m b) 91 | -> m b 92 | 93 | instance EmacsInvocation 'Z 'Z 'False where 94 | {-# INLINE supplyEmacsArgs #-} 95 | supplyEmacsArgs _nargs _startPtr _mkInput f = f Stop 96 | 97 | instance EmacsInvocation 'Z 'Z 'True where 98 | {-# INLINE supplyEmacsArgs #-} 99 | supplyEmacsArgs 100 | :: MonadBase IO m 101 | => Int 102 | -> Ptr (RawValue 'Regular) 103 | -> (RawValue 'Regular -> m a) 104 | -> (Rest a -> m b) 105 | -> m b 106 | supplyEmacsArgs nargs startPtr mkArg f = 107 | case nargs of 108 | 0 -> f (Rest []) 109 | n -> f . Rest =<< traverse mkArg =<< liftBase (peekArray n startPtr) 110 | 111 | {-# INLINE advanceEmacsValuePtr #-} 112 | advanceEmacsValuePtr :: forall p. Ptr (RawValue p) -> Ptr (RawValue p) 113 | advanceEmacsValuePtr = 114 | (`plusPtr` (sizeOf (undefined :: RawValue p))) 115 | 116 | instance EmacsInvocation 'Z n rest => EmacsInvocation 'Z ('S n) rest where 117 | {-# INLINE supplyEmacsArgs #-} 118 | supplyEmacsArgs 119 | :: forall m a b. MonadBase IO m 120 | => Int 121 | -> Ptr (RawValue 'Regular) 122 | -> (RawValue 'Regular -> m a) 123 | -> (O a (EmacsArgs 'Z n rest a) -> m b) 124 | -> m b 125 | supplyEmacsArgs nargs startPtr mkArg f = 126 | case nargs of 127 | 0 -> supplyEmacsArgs nargs startPtr mkArg (f . O Nothing) 128 | _ -> do 129 | arg <- mkArg =<< liftBase (peek startPtr) 130 | supplyEmacsArgs 131 | (nargs - 1) 132 | (advanceEmacsValuePtr startPtr) 133 | mkArg 134 | (f . O (Just arg)) 135 | 136 | instance EmacsInvocation n opt rest => EmacsInvocation ('S n) opt rest where 137 | {-# INLINE supplyEmacsArgs #-} 138 | supplyEmacsArgs 139 | :: MonadBase IO m 140 | => Int 141 | -> Ptr (RawValue 'Regular) 142 | -> (RawValue 'Regular -> m a) 143 | -> (R a (EmacsArgs n opt rest a) -> m b) 144 | -> m b 145 | supplyEmacsArgs nargs startPtr mkArg f = do 146 | arg <- mkArg =<< liftBase (peek startPtr) 147 | supplyEmacsArgs (nargs - 1) (advanceEmacsValuePtr startPtr) mkArg (f . R arg) 148 | 149 | 150 | -- | Helper to retrieve number of arguments a function takes for Emacs. 151 | class GetArities (req :: Nat) (opt :: Nat) (rest :: Bool) where 152 | arities :: Proxy req -> Proxy opt -> Proxy rest -> (CPtrdiff, CPtrdiff) 153 | 154 | instance (NatValue req, NatValue opt) => GetArities req opt 'False where 155 | {-# INLINE arities #-} 156 | arities preq popt _ = (req, req + opt) 157 | where 158 | req = fromIntegral (natValue preq) 159 | opt = fromIntegral (natValue popt) 160 | 161 | instance NatValue req => GetArities req opt 'True where 162 | {-# INLINE arities #-} 163 | arities preq _ _ = 164 | (fromIntegral (natValue preq), variadicFunctionArgs) 165 | 166 | 167 | -- data Args (req :: Nat) (opt :: Nat) (rest :: Bool) (a :: Type) where 168 | -- NoArgs :: Args 'Z 'Z 'False a 169 | -- ReqArg :: a -> Args req opt rest a -> Args ('S req) opt rest a 170 | -- OptArg :: Maybe a -> Args req opt rest a -> Args req ('S opt) rest a 171 | -- RestArgs :: [a] -> Args 'Z 'Z 'True a 172 | -- 173 | -- deriving instance Functor (Args req opt rest) 174 | -- deriving instance Foldable (Args req opt rest) 175 | -- deriving instance Traversable (Args req opt rest) 176 | 177 | -- class GetArgs (req :: Nat) (opt :: Nat) (rest :: Bool) where 178 | -- getArgs :: Storable a => Int -> Ptr a -> IO (Args req opt rest a) 179 | -- 180 | -- instance GetArgs 'Z 'Z 'False where 181 | -- {-# INLINE getArgs #-} 182 | -- getArgs !_nargs _startPtr = pure NoArgs 183 | -- 184 | -- instance GetArgs 'Z 'Z 'True where 185 | -- {-# INLINE getArgs #-} 186 | -- getArgs !nargs startPtr = 187 | -- case nargs of 188 | -- 0 -> pure $ RestArgs [] 189 | -- n -> RestArgs <$> peekArray n startPtr 190 | -- 191 | -- instance (GetArgs req n rest, DefaultArgs req n rest) => GetArgs req ('S n) rest where 192 | -- {-# INLINE getArgs #-} 193 | -- getArgs :: forall a. Storable a => Int -> Ptr a -> IO (Args req ('S n) rest a) 194 | -- getArgs !nargs startPtr = do 195 | -- case nargs of 196 | -- 0 -> pure $ OptArg Nothing defaultArgs 197 | -- _ -> OptArg <$> (Just <$> peek startPtr) <*> getArgs (nargs - 1) (plusPtr startPtr (sizeOf (undefined :: a))) 198 | -- 199 | -- instance GetArgs n opt rest => GetArgs ('S n) opt rest where 200 | -- {-# INLINE getArgs #-} 201 | -- getArgs :: forall a. Storable a => Int -> Ptr a -> IO (Args ('S n) opt rest a) 202 | -- getArgs !nargs startPtr = do 203 | -- ReqArg <$> peek startPtr <*> getArgs (nargs - 1) (plusPtr startPtr (sizeOf (undefined :: a))) 204 | -- 205 | -- 206 | -- class DefaultArgs (req :: Nat) (opt :: Nat) (rest :: Bool) where 207 | -- defaultArgs :: Args req opt rest a 208 | -- 209 | -- instance DefaultArgs 'Z 'Z 'False where 210 | -- {-# INLINE defaultArgs #-} 211 | -- defaultArgs = NoArgs 212 | -- 213 | -- instance DefaultArgs 'Z 'Z 'True where 214 | -- {-# INLINE defaultArgs #-} 215 | -- defaultArgs = RestArgs [] 216 | -- 217 | -- instance DefaultArgs req n rest => DefaultArgs req ('S n) rest where 218 | -- {-# INLINE defaultArgs #-} 219 | -- defaultArgs = OptArg Nothing defaultArgs 220 | -------------------------------------------------------------------------------- /src/Emacs/Module/Monad/Class.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Monad.Class 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE FunctionalDependencies #-} 11 | {-# LANGUAGE QuantifiedConstraints #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module Emacs.Module.Monad.Class 15 | ( EmacsFunction 16 | , MonadEmacs(..) 17 | ) where 18 | 19 | import Control.Monad.Interleave 20 | import Control.Monad.Primitive 21 | import Data.ByteString qualified as BS 22 | import Data.ByteString.Short qualified as BSS 23 | import Data.Int 24 | import Data.Kind 25 | import Data.Text (Text) 26 | import Data.Vector.Unboxed qualified as U 27 | import Foreign.ForeignPtr (FinalizerPtr) 28 | import Foreign.Ptr (Ptr) 29 | 30 | import Data.Emacs.Module.Args 31 | import Data.Emacs.Module.Doc qualified as Doc 32 | import Data.Emacs.Module.Env.Functions 33 | import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput 34 | import Data.Emacs.Module.Raw.Value 35 | import Data.Emacs.Module.SymbolName 36 | import Emacs.Module.Assert 37 | 38 | -- | Basic Haskell function that can be called by Emacs. 39 | type EmacsFunction req opt rest (m :: k -> Type -> Type) (v :: k -> Type) (s :: k) 40 | = EmacsArgs req opt rest (v s) -> m s (v s) 41 | 42 | -- | A mtl-style typeclass for interacting with Emacs. Typeclass functions 43 | -- are mostly direct translations of emacs interface provided by 'emacs-module.h'. 44 | -- 45 | -- For more functions please refer to "Emacs.Module.Functions" module. 46 | class 47 | ( forall s. Monad (m s) 48 | , forall s. MonadInterleave (m s) 49 | , forall s. U.Unbox (v s) 50 | , forall s. PrimMonad (m s) 51 | ) => MonadEmacs (m :: k -> Type -> Type) (v :: k -> Type) | m -> v where 52 | 53 | -- -- | Emacs value that is managed by the 'm' monad. Will be cleaned up 54 | -- -- after 'm' finishes its execution. 55 | -- type EmacsRef m :: k -> Type 56 | 57 | -- | Make a global reference to a value so that it will persist 58 | -- across different calls from Emacs into exposed functions. 59 | makeGlobalRef :: WithCallStack => v s -> m s (RawValue 'Pinned) 60 | 61 | -- | Free a global reference. 62 | freeGlobalRef :: WithCallStack => RawValue 'Pinned -> m s () 63 | 64 | -- | Check whether a non-local exit is pending. 65 | nonLocalExitCheck :: WithCallStack => m s (FuncallExit ()) 66 | 67 | -- | Check whether a non-local exit is pending and get detailed data 68 | -- in case it is. 69 | nonLocalExitGet 70 | :: WithCallStack 71 | => m s (FuncallExit (v s, v s)) 72 | 73 | -- | Equivalent to Emacs's @signal@ function. Terminates current computation. 74 | -- 75 | -- NB if a non-local exit is alredy pending, this function will not 76 | -- overwrite it. In order to do that, first use 'nonLocalExitClear'. 77 | nonLocalExitSignal 78 | :: (WithCallStack, Foldable f) 79 | => v s -- ^ Error symbol 80 | -> f (v s) -- ^ Error data, will be converted to a list as Emacs API expects. 81 | -> m s () 82 | 83 | -- | Equivalent to Emacs's @throw@ function. Terminates current computation. 84 | -- 85 | -- NB if a non-local exit is alredy pending, this function will not 86 | -- overwrite it. In order to do that, use 'nonLocalExitClear'. 87 | nonLocalExitThrow 88 | :: WithCallStack 89 | => v s -- ^ Tag 90 | -> v s -- ^ Data 91 | -> m s () 92 | 93 | -- | Clean any pending local exits. 94 | nonLocalExitClear :: WithCallStack => m s () 95 | 96 | -- | Make Haskell function available as an anonymous Emacs 97 | -- function. In order to be able to use it later from Emacs it should 98 | -- be fed into 'bindFunction'. 99 | makeFunction 100 | :: (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest) 101 | => (forall s'. EmacsFunction req opt rest m v s') -- ^ Haskell function to export 102 | -> Doc.Doc -- ^ Documentation 103 | -> m s (v s) 104 | 105 | -- | Invoke an Emacs function that may call back into Haskell. 106 | funcall 107 | :: (WithCallStack, Foldable f) 108 | => v s -- ^ Function name 109 | -> f (v s) -- ^ Arguments 110 | -> m s (v s) 111 | 112 | -- | Invoke an Emacs function. The function should be simple and 113 | -- must not call back into Haskell. 114 | funcallPrimitive 115 | :: (WithCallStack, Foldable f) 116 | => v s -- ^ Function name 117 | -> f (v s) -- ^ Arguments 118 | -> m s (v s) 119 | 120 | -- | Invoke an Emacs function. The function should be simple and 121 | -- must not call back into Haskell. 122 | -- 123 | -- Exit status is not checked - function is expected to always 124 | -- succeed. Consult Emacs side to make sure that's the case. 125 | -- Examples of safe functions: @cons@, @list@, @vector@, etc. 126 | funcallPrimitiveUnchecked 127 | :: (WithCallStack, Foldable f) 128 | => v s -- ^ Function name 129 | -> f (v s) -- ^ Arguments 130 | -> m s (v s) 131 | 132 | -- | Convert a string to an Emacs symbol. 133 | intern 134 | :: WithCallStack 135 | => SymbolName 136 | -> m s (v s) 137 | 138 | -- | Get type of an Emacs value as an Emacs symbol. 139 | typeOf 140 | :: WithCallStack 141 | => v s -> m s (v s) 142 | 143 | -- | Check whether Emacs value is not @nil@. 144 | isNotNil :: WithCallStack => v s -> m s Bool 145 | 146 | -- | Primitive equality. Tests whether two symbols, integers or 147 | -- characters are the equal, but not much more. For more complete 148 | -- equality comparison do 149 | -- 150 | -- > intern "equal" >>= \equal -> funcallPrimitiveUnchecked equal [x, y] 151 | eq 152 | :: WithCallStack 153 | => v s -> v s -> m s Bool 154 | 155 | 156 | -- | Try to unpack a wide integer from a value. 157 | extractWideInteger :: WithCallStack => v s -> m s Int64 158 | 159 | -- | Pack a wide integer for Emacs. 160 | makeWideInteger :: WithCallStack => Int64 -> m s (v s) 161 | 162 | -- | Try to unpack a floating-point number from a value. 163 | extractDouble :: WithCallStack => v s -> m s Double 164 | 165 | -- | Convert a floating-point number into Emacs value. 166 | makeDouble :: WithCallStack => Double -> m s (v s) 167 | 168 | -- | Extract string contents from an Emacs value. 169 | extractText :: WithCallStack => v s -> m s Text 170 | 171 | -- | Extract string contents from an Emacs value as utf8-encoded short bytestring. 172 | extractShortByteString :: WithCallStack => v s -> m s BSS.ShortByteString 173 | 174 | -- | Extract string contents from an Emacs value as bytestring. 175 | extractByteString :: WithCallStack => v s -> m s BS.ByteString 176 | 177 | -- | Convert a utf8-encoded ByteString into an Emacs value. 178 | makeString :: WithCallStack => BS.ByteString -> m s (v s) 179 | 180 | -- | Convert any ByteString into an Emacs unibyte string. 181 | makeBinaryString :: WithCallStack => BS.ByteString -> m s (v s) 182 | 183 | -- | Extract a user pointer from an Emacs value. 184 | extractUserPtr :: WithCallStack => v s -> m s (Ptr a) 185 | 186 | -- | Pack a user pointer into an Emacs value. 187 | makeUserPtr 188 | :: WithCallStack 189 | => FinalizerPtr a -- ^ Finalisation action that will be executed when user pointer gets garbage-collected by Emacs. 190 | -> Ptr a 191 | -> m s (v s) 192 | 193 | -- | Set user pointer to a new value 194 | assignUserPtr :: WithCallStack => v s -> Ptr a -> m s () 195 | 196 | -- | Extract a finaliser from an user_ptr. 197 | extractUserPtrFinaliser 198 | :: WithCallStack => v s -> m s (FinalizerPtr a) 199 | 200 | -- | Assign new finaliser into an user_ptr. 201 | assignUserPtrFinaliser 202 | :: WithCallStack => v s -> FinalizerPtr a -> m s () 203 | 204 | -- | Extract an element from an Emacs vector. 205 | vecGet :: WithCallStack => v s -> Int -> m s (v s) 206 | 207 | -- | Extract an element from an Emacs vector without checking for errors. 208 | unsafeVecGet :: WithCallStack => v s -> Int -> m s (v s) 209 | 210 | -- | Assign an element into an Emacs vector. 211 | vecSet 212 | :: WithCallStack 213 | => v s -- ^ Vector 214 | -> Int -- ^ Index 215 | -> v s -- ^ New value 216 | -> m s () 217 | 218 | -- | Get size of an Emacs vector. 219 | vecSize :: WithCallStack => v s -> m s Int 220 | 221 | -- | Check whether user pressed 'C-g' and we should abort our operation. 222 | processInput :: WithCallStack => m s ProcessInput.Result 223 | -------------------------------------------------------------------------------- /Tutorial.md: -------------------------------------------------------------------------------- 1 | ### Intro 2 | 3 | Emacs module is a shared library object (`.so` on Linux, `.dll` on Windows). Since Emacs module API 4 | is a C-based one, writing a module in Haskell will likely involve FFI. 5 | 6 | If at any point this tutorial doesn’t work you could refer to tests 7 | for this package (at https://github.com/sergv/emacs-module/tree/master/test) 8 | that will contain all the pieces of creating shared library object with Haskell in 9 | hopefully working order since they’re run on CI. 10 | 11 | ### Preparations 12 | 13 | For starters, module will need to initialize Haskell RTS. This cannot be done from Haskell 14 | so C will need to be used: 15 | 16 | ```c 17 | #include 18 | 19 | #include 20 | #include "HsFFI.h" 21 | #include "Rts.h" 22 | 23 | #ifdef __cplusplus 24 | extern "C" { 25 | #endif 26 | extern HsBool initialise(struct emacs_runtime *ert); 27 | #ifdef __cplusplus 28 | } 29 | #endif 30 | 31 | int plugin_is_GPL_compatible = 1; 32 | 33 | HsBool init(void) { 34 | int argc = 0; 35 | char *argv[] = { NULL }; 36 | char **pargv = argv; 37 | 38 | // Initialise Haskell runtime, can pass RTS options to the module via argv. 39 | { 40 | RtsConfig conf = defaultRtsConfig; 41 | conf.rts_opts_enabled = RtsOptsAll; 42 | hs_init_ghc(&argc, &pargv, conf); 43 | } 44 | return HS_BOOL_TRUE; 45 | } 46 | 47 | void deinit(void) { 48 | hs_exit(); 49 | } 50 | 51 | int 52 | emacs_module_init(struct emacs_runtime *ert) 53 | { 54 | return !(init() && initialise(ert)); 55 | } 56 | ``` 57 | 58 | The `plugin_is_GPL_compatible` is required by Emacs, without it will refuse to load your module. 59 | Another mandatory bit is `emacs_module_init` function which will be called upon module load. 60 | Here it will initialize Haskell’s RTS and call `initialise` which will be exported from Haskell. 61 | 62 | It should be noted that `hs_init` could be called somewhere else. If multiple Haskell modules are 63 | created as literally show in this tutorial they could not be used together because each of 64 | them will call `hs_init` upon loading by Emacs but they’ll share single Haskell runtime for which 65 | `hs_init` should be called only once. In that case the call to `hs_init` should be factored out, 66 | but this won’t be shown in this tutorial. 67 | 68 | I recommend building shared library with cabal. For than following 69 | minimalistic cabal file should work (put in into `emacs_wrapper.c`): 70 | 71 | ```cabal 72 | cabal-version: 3.0 73 | name: 74 | emacs-module-example 75 | version: 76 | 0.1.0.0 77 | 78 | build-type: 79 | Simple 80 | 81 | common ghc-options 82 | default-language: 83 | GHC2021 84 | 85 | default-extensions: 86 | ImportQualifiedPost 87 | LambdaCase 88 | 89 | ghc-options: 90 | -Weverything 91 | -Wno-all-missed-specialisations 92 | -Wno-implicit-prelude 93 | -Wno-missed-specialisations 94 | -Wno-missing-import-lists 95 | -Wno-missing-local-signatures 96 | -Wno-missing-safe-haskell-mode 97 | -Wno-redundant-constraints 98 | -Wno-safe 99 | -Wno-type-defaults 100 | -Wno-unsafe 101 | 102 | if impl(ghc >= 8.8) 103 | ghc-options: 104 | -Wno-missing-deriving-strategies 105 | 106 | if impl(ghc >= 9.2) 107 | ghc-options: 108 | -Wno-missing-kind-signatures 109 | 110 | foreign-library emacs-module-example 111 | import: ghc-options 112 | type: 113 | native-shared 114 | lib-version-info: 115 | 0:0:0 116 | c-sources: 117 | cbits/emacs_wrapper.c 118 | includes: 119 | emacs-module.h 120 | install-includes: 121 | emacs-module.h 122 | include-dirs: 123 | cbits 124 | other-modules: 125 | Emacs.Example 126 | 127 | if os(Windows) 128 | options: 129 | standalone 130 | mod-def-file: 131 | emacs-module-example.def 132 | 133 | ghc-options: 134 | -threaded 135 | 136 | build-depends: 137 | , base >= 4.16 && <5 138 | , emacs-module >= 0.2 139 | hs-source-dirs: 140 | src 141 | ``` 142 | 143 | The `foreign-library` section will direct cabal to create shared library. For Windows users 144 | it’s important to provide following def file that will specify exported names. Without it the DLL 145 | will fail to link because GHC will export every symbol and hit a limit. 146 | 147 | ``` 148 | LIBRARY emacs-module-example 149 | EXPORTS 150 | plugin_is_GPL_compatible @1 151 | emacs_module_init @2 152 | ``` 153 | 154 | Users on other systems can safely ignore the def file and remove corresponding part from cabal file. 155 | 156 | ### Haskell part 157 | 158 | Put following source under `src/Emacs/Example.hs`: 159 | 160 | ```haskell 161 | {-# LANGUAGE DataKinds #-} 162 | {-# LANGUAGE OverloadedStrings #-} 163 | 164 | module Emacs.Example () where 165 | 166 | import Foreign 167 | import Foreign.C 168 | 169 | import Data.Emacs.Module.Args 170 | import Data.Emacs.Module.Runtime (Runtime) 171 | import Data.Emacs.Module.Runtime qualified as Runtime 172 | import Emacs.Module 173 | import Emacs.Module.Monad 174 | 175 | foreign export ccall initialise :: Ptr Runtime -> IO CBool 176 | 177 | true, false :: CBool 178 | true = CBool 1 179 | false = CBool 0 180 | 181 | initialise :: Ptr Runtime -> IO CBool 182 | initialise runtime = do 183 | runtime' <- Runtime.validateRuntime runtime 184 | case runtime' of 185 | Nothing -> pure false 186 | Just runtime'' -> 187 | Runtime.withEnvironment runtime'' $ \env -> do 188 | res <- reportAllErrorsToEmacs env (pure False) $ runEmacsM env initialise' 189 | pure $ if res then true else false 190 | 191 | initialise' 192 | :: MonadEmacs m v 193 | => m s Bool 194 | initialise' = do 195 | bindFunction "haskell-emacs-module-example" =<< 196 | makeFunction example "Add arguments and call a function on the sum." 197 | pure True 198 | 199 | example 200 | :: MonadEmacs m v 201 | => EmacsFunction ('S ('S ('S 'Z))) 'Z 'False m v s 202 | example (R f (R x (R y Stop))) = do 203 | z <- makeInt =<< (+) <$> extractInt x <*> extractInt y 204 | funcall f [z] 205 | ``` 206 | 207 | This will export the `initialise` symbol that we mentioned in `emacs_wrapper.c`. It will 208 | follow Emacs module initialisation protocol of checking the size of the runtime struct that 209 | Emacs passed in. The `emacs-module` package requires at least Emacs 28. For earlier Emacs versions 210 | the runtime struct will be smaller that expected and thus the check will rule out loading under 211 | older Emacs versions. 212 | 213 | After the check it will call the `initialise'` function which gives names to Haskell implementations 214 | in Emacs so that they can be called from elisp. The `makeFunction` creates an unammed function 215 | object that will call specified Haskell function. The `bindFunction` takes function object 216 | and associates it with a name in the elisp environment. 217 | 218 | And finally, the `example` function that could be called from elisp. It needs to be of type 219 | `EmacsFunction A B C m v s` that has quite a few parameters. Their meanings are: 220 | - `A` - number of required arguments that the function will receive, 221 | specified as Peano numeral on typelevel. If elisp provides less 222 | arguments that required an error will be thrown without reaching Haskell. 223 | - `B` - number of optional arguments that the function will receive, 224 | specified as Peano numeral on typelevel. If elisp provides less 225 | arguments that required the remaining optional arguments will be 226 | `nil`. Corresponds to `&optional` annotation in elisp. 227 | - `C` - type-level boolean that denotes whether function accepts `&rest` arguments, similar to elisp. 228 | - `m` - underlying monad, can be either kept abstract by using MTL-style `MonadEmacs` or can 229 | be concrete, in which case specify EmacsM. 230 | - `v` - type of Emacs values the monad handles 231 | - `s` - type-level threading marker similar to the one in the `ST` monad. Makes it impossible 232 | to share values between different runs of the Emacs interaction monad. This is because all 233 | the values created during particular run will be garbage-collected when Haskell returns control 234 | back to Emacs. This can be overcome by using `makeGlobalRef` function, please see package docs. 235 | 236 | The `example` function receives 3 required arguments which are 237 | pattern-matched as `(R f (R x (R y Stop)))`. It expects `x` and `y` to be integers which 238 | it extracts via `extractInt` that takes an Emacs value and returns a Haskell `Int` value. 239 | Sum of the `x` and `y` in converted back to Emacs value and fed into the `f` argument which 240 | is expected to be a function. 241 | 242 | The sample project can be build by `cabal build`. It will print where the shared library 243 | was placed. On my system it’s `dist-newstyle/build/x86_64-linux/ghc-9.6.1/emacs-module-example-0.1.0.0/f/emacs-module-example/build/emacs-module-example/libemacs-module-example.so`. Now we can 244 | direct Emacs to load example module and call the Haskell function as `(haskell-emacs-module-example (lambda (x) (* x x)) 10 20)`: 245 | 246 | ``` 247 | $ emacs --no-init -Q --batch -l dist-newstyle/build/x86_64-linux/ghc-9.6.1/emacs-module-example-0.1.0.0/f/emacs-module-example/build/emacs-module-example/libemacs-module-example.so --eval '(message "Result = %s" (haskell-emacs-module-example (lambda (x) (* x x)) 10 20))' 248 | Result = 900 249 | ``` 250 | -------------------------------------------------------------------------------- /test/elisp/haskell-emacs-module-test.el: -------------------------------------------------------------------------------- 1 | ;; haskell-emacs-module-test.el --- -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) Sergey Vinokurov 4 | ;; 5 | ;; Author: Sergey Vinokurov 6 | ;; Created: 28 May 2018 7 | ;; Description: 8 | 9 | (require 'ert) 10 | 11 | (defun custom-replicate (n x) 12 | (let ((res nil)) 13 | (dotimes (i n) 14 | (push x res)) 15 | res)) 16 | 17 | (ert-deftest haskell-emacs-module-test/apply-function-twice-1 () 18 | (should (fboundp #'haskell-emacs-module-tests-apply2))) 19 | 20 | (ert-deftest haskell-emacs-module-test/apply-function-twice-2 () 21 | (should (equal (haskell-emacs-module-tests-apply2 (lambda (x) (* x 2)) 10) 22 | 40))) 23 | 24 | (ert-deftest haskell-emacs-module-test/apply-function-twice-3 () 25 | (let ((acc 0)) 26 | (should (equal (haskell-emacs-module-tests-apply2 27 | (lambda (x) (setf acc (+ acc 1)) (+ x acc)) 28 | 10) 29 | 13)) 30 | (should (equal (haskell-emacs-module-tests-apply2 31 | (lambda (x) (setf acc (+ acc 1)) (+ x acc)) 32 | 10) 33 | 17)))) 34 | 35 | (ert-deftest haskell-emacs-module-test/apply-function-twice-4 () 36 | (let* ((acc 0)) 37 | (should (equal (catch 'wat 38 | (progn 39 | (haskell-emacs-module-tests-apply2 40 | (lambda (x) 41 | (setf acc (+ acc 1)) 42 | (if (<= 2 acc) 43 | (throw 'wat x) 44 | (+ x acc))) 45 | 10) 46 | 0)) 47 | 11)))) 48 | 49 | (ert-deftest haskell-emacs-module-test/apply-function-twice-5 () 50 | (let* ((acc 0)) 51 | (should-error 52 | (haskell-emacs-module-tests-apply2 53 | (lambda (x) 54 | (setf acc (+ acc 1)) 55 | (if (<= 2 acc) 56 | (error "I'm done with you") 57 | (+ x acc))) 58 | 10) 59 | :type 'error))) 60 | 61 | (ert-deftest haskell-emacs-module-test/apply-function-twice-alt-1 () 62 | (should (fboundp #'haskell-emacs-module-tests-apply2-alt))) 63 | 64 | (ert-deftest haskell-emacs-module-test/apply-function-twice-alt-2 () 65 | (should (equal (haskell-emacs-module-tests-apply2-alt (lambda (x) (* x 2)) 10) 66 | 40))) 67 | 68 | (ert-deftest haskell-emacs-module-test/apply-function-twice-alt-3 () 69 | (let ((acc 0)) 70 | (should (equal (haskell-emacs-module-tests-apply2-alt 71 | (lambda (x) (setf acc (+ acc 1)) (+ x acc)) 72 | 10) 73 | 13)) 74 | (should (equal (haskell-emacs-module-tests-apply2-alt 75 | (lambda (x) (setf acc (+ acc 1)) (+ x acc)) 76 | 10) 77 | 17)))) 78 | 79 | (ert-deftest haskell-emacs-module-test/apply-function-twice-alt-4 () 80 | (let* ((acc 0)) 81 | (should (equal (catch 'wat 82 | (progn 83 | (haskell-emacs-module-tests-apply2-alt 84 | (lambda (x) 85 | (setf acc (+ acc 1)) 86 | (if (<= 2 acc) 87 | (throw 'wat x) 88 | (+ x acc))) 89 | 10) 90 | 0)) 91 | 11)))) 92 | 93 | (ert-deftest haskell-emacs-module-test/apply-function-twice-alt-5 () 94 | (let* ((acc 0)) 95 | (should-error 96 | (haskell-emacs-module-tests-apply2-alt 97 | (lambda (x) 98 | (setf acc (+ acc 1)) 99 | (if (<= 2 acc) 100 | (error "I'm done with you") 101 | (+ x acc))) 102 | 10) 103 | :type 'error))) 104 | 105 | (ert-deftest haskell-emacs-module-test/add-1 () 106 | (should (fboundp #'haskell-emacs-module-tests-add))) 107 | 108 | (ert-deftest haskell-emacs-module-test/add-2 () 109 | (should (equal (haskell-emacs-module-tests-add 1 2) 110 | 3))) 111 | 112 | (ert-deftest haskell-emacs-module-test/add-3 () 113 | (should (equal (haskell-emacs-module-tests-add -1 -2) 114 | -3))) 115 | 116 | (ert-deftest haskell-emacs-module-test/add-4 () 117 | (should (eq (car (should-error 118 | (haskell-emacs-module-tests-add 1 "oops") 119 | :type 'error)) 120 | 'wrong-type-argument))) 121 | 122 | ;; Test passing and interpretation of the &rest argument. 123 | 124 | (ert-deftest haskell-emacs-module-test/get-rest-1 () 125 | (should (fboundp #'haskell-emacs-module-tests-get-rest))) 126 | 127 | (ert-deftest haskell-emacs-module-test/get-rest-2 () 128 | (should (equal (haskell-emacs-module-tests-get-rest t) [])) 129 | (should 130 | (equal 131 | (haskell-emacs-module-tests-get-rest 1 2 3 "foo" t 5) 132 | [2 3 "foo" t 5]))) 133 | 134 | 135 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-01 () 136 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 0) []))) 137 | 138 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-02 () 139 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 1) [1 2 3]))) 140 | 141 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-03 () 142 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 2) [1 2 3 1 2 3]))) 143 | 144 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-04 () 145 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 3) [1 2 3 1 2 3 1 2 3]))) 146 | 147 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-05 () 148 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 10) 149 | (apply #'vconcat (custom-replicate 10 [1 2 3]))))) 150 | 151 | (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-06 () 152 | (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 100) 153 | (apply #'vconcat (custom-replicate 100 [1 2 3]))))) 154 | 155 | ;; (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-07 () 156 | ;; (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 1000) 157 | ;; (apply #'vconcat (custom-replicate 1000 [1 2 3]))))) 158 | 159 | ;; (ert-deftest haskell-emacs-module-test/append-lots-of-vectors-08 () 160 | ;; (should (equal (haskell-emacs-module-tests-append-lots-of-vectors 2000) 161 | ;; (apply #'vconcat (custom-replicate 2000 [1 2 3]))))) 162 | 163 | 164 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-01 () 165 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 0) ""))) 166 | 167 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-02 () 168 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 1) "foo"))) 169 | 170 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-03 () 171 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 2) "foofoo"))) 172 | 173 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-04 () 174 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 3) "foofoofoo"))) 175 | 176 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-05 () 177 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 10) 178 | (apply #'concat (custom-replicate 10 "foo"))))) 179 | 180 | (ert-deftest haskell-emacs-module-test/append-lots-of-strings-06 () 181 | (should (equal (haskell-emacs-module-tests-append-lots-of-strings 100) 182 | (apply #'concat (custom-replicate 100 "foo"))))) 183 | 184 | ;; (ert-deftest haskell-emacs-module-test/append-lots-of-strings-07 () 185 | ;; (should (equal (haskell-emacs-module-tests-append-lots-of-strings 1000) 186 | ;; (apply #'concat (custom-replicate 1000 "foo"))))) 187 | 188 | ;; (ert-deftest haskell-emacs-module-test/append-lots-of-strings-08 () 189 | ;; (should (equal (haskell-emacs-module-tests-append-lots-of-strings 2000) 190 | ;; (apply #'concat (custom-replicate 2000 "foo"))))) 191 | 192 | (ert-deftest haskell-emacs-module-test/replicate-01 () 193 | (should (equal (haskell-emacs-module-tests-replicate 0 '(a b c)) 194 | nil))) 195 | 196 | (ert-deftest haskell-emacs-module-test/replicate-02 () 197 | (should (equal (haskell-emacs-module-tests-replicate 1 '(a b c)) 198 | '((a b c))))) 199 | 200 | (ert-deftest haskell-emacs-module-test/replicate-03 () 201 | (should (equal (haskell-emacs-module-tests-replicate 3 '(a b c)) 202 | '((a b c) (a b c) (a b c))))) 203 | 204 | (ert-deftest haskell-emacs-module-test/grow-list-01 () 205 | (should (equal (haskell-emacs-module-tests-grow-list '()) 206 | '()))) 207 | 208 | (ert-deftest haskell-emacs-module-test/grow-list-02 () 209 | (should (equal (haskell-emacs-module-tests-grow-list '(a b c)) 210 | '(a b c a b c a b c)))) 211 | 212 | (ert-deftest haskell-emacs-module-test/grow-list-03 () 213 | (should (equal (haskell-emacs-module-tests-grow-list '(a [2 3] c)) 214 | '(a [2 3] c a [2 3] c a [2 3] c)))) 215 | 216 | (ert-deftest haskell-emacs-module-test/grow-list-04 () 217 | (should (equal (haskell-emacs-module-tests-grow-list (make-list 5000 42)) 218 | (make-list 15000 42)))) 219 | 220 | (ert-deftest haskell-emacs-module-test/incorect-vector-assigment-1 () 221 | (should (eq (car (should-error (haskell-emacs-module-tests-incorrect-vector-assignment))) 222 | 'args-out-of-range))) 223 | 224 | (provide 'haskell-emacs-module-test) 225 | 226 | ;; Local Variables: 227 | ;; End: 228 | 229 | ;; haskell-emacs-module-test.el ends here 230 | -------------------------------------------------------------------------------- /src/Emacs/Module/Errors.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Errors 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- This module defines various kinds of exception that this library 9 | ---------------------------------------------------------------------------- 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | module Emacs.Module.Errors 15 | ( EmacsThrow(..) 16 | , reportEmacsThrowToEmacs 17 | , EmacsSignal(..) 18 | , reportEmacsSignalToEmacs 19 | , EmacsError(..) 20 | , mkEmacsError 21 | , reportErrorToEmacs 22 | , EmacsInternalError(..) 23 | , mkEmacsInternalError 24 | , reportInternalErrorToEmacs 25 | , UserError(..) 26 | , mkUserError 27 | 28 | , formatSomeException 29 | , reportAnyErrorToEmacs 30 | , reportAllErrorsToEmacs 31 | ) where 32 | 33 | import Control.Applicative 34 | import Control.Exception as Exception 35 | 36 | import Data.ByteString.Char8 qualified as C8 37 | import Data.Text (Text) 38 | import Data.Text qualified as T 39 | import Data.Text.Encoding qualified as TE 40 | import Data.Void 41 | import Data.Void.Unsafe 42 | import Foreign 43 | import Foreign.C.String 44 | import GHC.Stack (CallStack, callStack, prettyCallStack) 45 | import Prettyprinter 46 | import Prettyprinter.Combinators hiding (render, ppCallStack) 47 | import Prettyprinter.Render.Text as PP 48 | 49 | import Data.Emacs.Module.Env qualified as Raw 50 | import Data.Emacs.Module.GetRawValue 51 | import Data.Emacs.Module.NonNullPtr 52 | import Data.Emacs.Module.Raw.Env.Internal (Env) 53 | import Data.Emacs.Module.Raw.Value 54 | import Data.Emacs.Module.SymbolName.Internal 55 | import Data.Emacs.Module.SymbolName.Predefined qualified as Sym 56 | import Emacs.Module.Assert 57 | 58 | -- | A Haskell exception used to signal a @throw@ exit performed by an 59 | -- Emacs function. 60 | -- 61 | -- Unlikely to be needed when developing Emacs extensions. 62 | data EmacsThrow = EmacsThrow 63 | { emacsThrowTag :: !(RawValue 'Regular) 64 | , emacsThrowValue :: !(RawValue 'Regular) 65 | , emacsThrowOrigin :: CallStack 66 | } 67 | 68 | instance Show EmacsThrow where 69 | showsPrec _ EmacsThrow{emacsThrowOrigin} 70 | = showString "EmacsThrow\n" 71 | . showString (prettyCallStack emacsThrowOrigin) 72 | 73 | instance Exception EmacsThrow 74 | 75 | reportEmacsThrowToEmacs :: Env -> EmacsThrow -> IO (RawValue 'Unknown) 76 | reportEmacsThrowToEmacs env et = do 77 | nil <- mkNil env 78 | reportEmacsThrowToEmacs' env et 79 | pure nil 80 | 81 | reportEmacsThrowToEmacs' :: Env -> EmacsThrow -> IO () 82 | reportEmacsThrowToEmacs' env EmacsThrow{emacsThrowTag, emacsThrowValue} = 83 | Raw.nonLocalExitThrow env emacsThrowTag emacsThrowValue 84 | 85 | -- | A Haskell exception used to signal a @signal@ exit performed by an 86 | -- Emacs function. 87 | -- 88 | -- Unlikely to be needed when developing Emacs extensions. 89 | data EmacsSignal = EmacsSignal 90 | { emacsSignalSym :: !(RawValue 'Unknown) 91 | , emacsSignalData :: !(RawValue 'Regular) 92 | , emacsSignalInfo :: !Text 93 | , emacsSignalOrigin :: CallStack 94 | } 95 | 96 | instance Show EmacsSignal where 97 | showsPrec _ EmacsSignal{emacsSignalInfo, emacsSignalOrigin} 98 | = showString "EmacsSignal " 99 | . showString (T.unpack emacsSignalInfo) 100 | . showChar '\n' 101 | . showString (prettyCallStack emacsSignalOrigin) 102 | 103 | instance Exception EmacsSignal 104 | 105 | reportEmacsSignalToEmacs :: Env -> EmacsSignal -> IO (RawValue 'Unknown) 106 | reportEmacsSignalToEmacs env et = do 107 | nil <- mkNil env 108 | reportEmacsSignalToEmacs' env et 109 | pure nil 110 | 111 | reportEmacsSignalToEmacs' :: Env -> EmacsSignal -> IO () 112 | reportEmacsSignalToEmacs' env EmacsSignal{emacsSignalSym, emacsSignalData} = 113 | Raw.nonLocalExitSignal env emacsSignalSym emacsSignalData 114 | 115 | -- | Error thrown to emacs by Haskell functions when anything goes awry. 116 | data UserError = UserError 117 | { userErrFunctionName :: Doc Void 118 | , userErrMsg :: Doc Void 119 | , userErrStack :: CallStack 120 | } deriving (Show) 121 | 122 | instance Exception UserError 123 | 124 | instance Pretty UserError where 125 | pretty (UserError func msg stack) = 126 | "Error in function" <+> unsafeVacuous func <> ":" <> line <> 127 | indent 2 (unsafeVacuous msg) <> line <> line <> 128 | "Location:" <> line <> 129 | indent 2 (ppCallStack stack) 130 | 131 | mkUserError 132 | :: WithCallStack 133 | => Doc Void -- ^ Function name 134 | -> Doc Void -- ^ Message body 135 | -> UserError 136 | mkUserError funcName body = UserError 137 | { userErrFunctionName = funcName 138 | , userErrMsg = body 139 | , userErrStack = callStack 140 | } 141 | 142 | -- | A high-level error thrown when an Emacs function fails. 143 | data EmacsError = EmacsError 144 | { emacsErrMsg :: Doc Void 145 | , emacsErrData :: Doc Void 146 | , emacsErrStack :: CallStack 147 | } deriving (Show) 148 | 149 | instance Exception EmacsError 150 | 151 | mkEmacsError 152 | :: WithCallStack 153 | => Doc Void -- ^ Message 154 | -> Doc Void -- ^ Error data from Emacs 155 | -> EmacsError 156 | mkEmacsError msg errData = EmacsError 157 | { emacsErrMsg = msg 158 | , emacsErrData = errData 159 | , emacsErrStack = callStack 160 | } 161 | 162 | instance Pretty EmacsError where 163 | pretty EmacsError{emacsErrMsg, emacsErrData, emacsErrStack} = 164 | "Error within Haskell<->Emacs bindings:" <> line <> 165 | indent 2 (unsafeVacuous emacsErrMsg) <> line <> line <> 166 | "Emacs error:" <> line <> 167 | indent 2 (unsafeVacuous emacsErrData) <> line <> line <> 168 | "Location:" <> line <> 169 | indent 2 (ppCallStack emacsErrStack) 170 | 171 | reportErrorToEmacs :: Env -> EmacsError -> IO (RawValue 'Unknown) 172 | reportErrorToEmacs env e = do 173 | nil <- mkNil env 174 | report render env e 175 | pure nil 176 | 177 | -- | A low-level error thrown when assumptions of this package are 178 | -- violated and it's not safe to proceed further. 179 | -- 180 | -- E.g. Emacs returned value not specified in a C enum - cannot 181 | -- really process it in a meaningful way. 182 | data EmacsInternalError = EmacsInternalError 183 | { emacsInternalErrMsg :: Doc Void 184 | , emacsInternalErrStack :: CallStack 185 | } 186 | 187 | instance Exception EmacsInternalError 188 | 189 | instance Show EmacsInternalError where 190 | showsPrec _ (EmacsInternalError msg stack) 191 | = showString (renderString ("EmacsInternalError" ## msg <> line <> ppCallStack stack)) 192 | 193 | mkEmacsInternalError 194 | :: WithCallStack 195 | => Doc Void -- ^ Error message 196 | -> EmacsInternalError 197 | mkEmacsInternalError msg = EmacsInternalError 198 | { emacsInternalErrMsg = msg 199 | , emacsInternalErrStack = callStack 200 | } 201 | 202 | reportInternalErrorToEmacs :: Env -> EmacsInternalError -> IO (RawValue 'Unknown) 203 | reportInternalErrorToEmacs env e = do 204 | nil <- mkNil env 205 | report render env e 206 | pure nil 207 | 208 | instance Pretty EmacsInternalError where 209 | pretty EmacsInternalError{emacsInternalErrMsg, emacsInternalErrStack} = 210 | "Internal error within Haskell<->Emacs bindings:" <> line <> 211 | indent 2 (unsafeVacuous emacsInternalErrMsg) <> line <> line <> 212 | "Location:" <> line <> 213 | indent 2 (ppCallStack emacsInternalErrStack) 214 | 215 | formatSomeException :: SomeException -> Text 216 | formatSomeException e = 217 | case pretty @EmacsError <$> fromException e <|> 218 | pretty @EmacsInternalError <$> fromException e of 219 | Just formatted -> render' formatted 220 | Nothing -> 221 | PP.renderStrict $ layoutPretty defaultLayoutOptions $ 222 | "Error within Haskell<->Emacs bindings:" <> line <> 223 | indent 2 (pretty (show e)) 224 | 225 | reportAnyErrorToEmacs :: Env -> SomeException -> IO (RawValue 'Unknown) 226 | reportAnyErrorToEmacs env !e = do 227 | !nil <- mkNil env 228 | report formatSomeException env e 229 | pure nil 230 | 231 | -- | Catch all errors this package might throw in an IO action 232 | -- and make Emacs aware of them. 233 | -- 234 | -- This is a convenience function intended to be used around exported 235 | -- @initialise@ entry point into an Emacs module. 236 | reportAllErrorsToEmacs 237 | :: Env 238 | -> IO a -- ^ Result to return on error. 239 | -> IO a 240 | -> IO a 241 | reportAllErrorsToEmacs env resultOnErr x 242 | = Exception.handle (\e -> report formatSomeException env e *> resultOnErr) 243 | $ Exception.handle (\et -> reportEmacsThrowToEmacs' env et *> resultOnErr) 244 | $ Exception.handle (\et -> reportEmacsSignalToEmacs' env et *> resultOnErr) x 245 | 246 | report :: (e -> Text) -> Env -> e -> IO () 247 | report format env err = do 248 | errSym <- reifySymbolRaw env Sym.error 249 | listSym <- reifySymbolRaw env Sym.list 250 | withTextAsCString0AndLen (format err) $ \str len -> do 251 | str' <- Raw.makeString env str (fromIntegral len) 252 | alloca $ \argsPtr -> do 253 | poke argsPtr str' 254 | errData <- Raw.funcallPrimitive env (getRawValue listSym) 1 (mkNonNullPtr argsPtr) 255 | -- The 'nonLocalExitSignal' function does not overwrite pending 256 | -- signals, so it's ok to use it here without checking whether an 257 | -- error is already going on. 258 | Raw.nonLocalExitSignal env errSym errData 259 | 260 | withTextAsCString0AndLen :: Text -> (CString -> Int -> IO a) -> IO a 261 | withTextAsCString0AndLen str f = 262 | C8.useAsCString utf8 (\ptr -> f ptr (C8.length utf8)) 263 | where 264 | utf8 = TE.encodeUtf8 str 265 | 266 | mkNil :: WithCallStack => Env -> IO (RawValue 'Unknown) 267 | mkNil env = reifySymbolUnknown env Sym.nil 268 | 269 | render :: Pretty a => a -> Text 270 | render = render' . pretty 271 | 272 | render' :: Doc Void -> Text 273 | render' = PP.renderStrict . layoutPretty defaultLayoutOptions 274 | 275 | ppCallStack :: CallStack -> Doc ann 276 | ppCallStack = pretty . prettyCallStack 277 | -------------------------------------------------------------------------------- /src/Emacs/Module/Functions.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Functions 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- Wrappers around some Emacs functions, independent of concrete monad. 9 | ---------------------------------------------------------------------------- 10 | 11 | {-# LANGUAGE CPP #-} 12 | 13 | #if defined(mingw32_HOST_OS) || defined(__MINGW32__) 14 | # define WINDOWS 1 15 | #endif 16 | 17 | module Emacs.Module.Functions 18 | ( funcallPrimitiveSym 19 | , funcallPrimitiveUncheckedSym 20 | , funcallPrimitiveSym_ 21 | , bindFunction 22 | , provide 23 | , makeUserPtrFromStablePtr 24 | , extractStablePtrFromUserPtr 25 | -- * Haskell<->Emacs datatype conversions 26 | , extractInt 27 | , extractOsPath 28 | , makeInt 29 | , makeText 30 | , makeShortByteString 31 | , extractBool 32 | , makeBool 33 | -- * Vectors 34 | , extractVectorWith 35 | , extractVectorMutableWith 36 | , extractVectorAsPrimArrayWith 37 | , makeVector 38 | , vconcat2 39 | -- * Lists 40 | , cons 41 | , car 42 | , cdr 43 | , nil 44 | , setcar 45 | , setcdr 46 | , makeList 47 | , extractList 48 | , extractListWith 49 | , foldlEmacsListWith 50 | , unfoldEmacsListWith 51 | -- * Strings 52 | , addFaceProp 53 | , propertize 54 | , concat2 55 | , valueToText 56 | , symbolName 57 | 58 | -- * Reexports 59 | , MonadMask 60 | ) where 61 | 62 | import Control.Monad 63 | import Control.Monad.Catch 64 | import Control.Monad.Interleave 65 | import Control.Monad.Primitive (PrimState) 66 | import Data.ByteString.Short (ShortByteString) 67 | import Data.ByteString.Short qualified as BSS 68 | import Data.Foldable 69 | import Data.Primitive.PrimArray 70 | import Data.Primitive.Types 71 | import Data.Text (Text) 72 | import Data.Text.Encoding qualified as TE 73 | import Data.Tuple.Homogenous 74 | import Data.Vector.Generic qualified as G 75 | import Data.Vector.Generic.Mutable qualified as GM 76 | import Foreign.StablePtr 77 | import System.OsPath 78 | import System.OsString.Internal.Types 79 | 80 | import Data.Emacs.Module.Env qualified as Env 81 | import Data.Emacs.Module.SymbolName 82 | import Data.Emacs.Module.SymbolName.Predefined qualified as Sym 83 | import Emacs.Module.Assert 84 | import Emacs.Module.Monad.Class 85 | 86 | -- | Call a function by its name, similar to 'funcallPrimitive'. 87 | {-# INLINE funcallPrimitiveSym #-} 88 | funcallPrimitiveSym 89 | :: (WithCallStack, MonadEmacs m v, Foldable f) 90 | => SymbolName -> f (v s) -> m s (v s) 91 | funcallPrimitiveSym func args = do 92 | func' <- intern func 93 | funcallPrimitive func' args 94 | 95 | -- | Call a function by its name, similar to 'funcallPrimitiveUnchecked'. 96 | {-# INLINE funcallPrimitiveUncheckedSym #-} 97 | funcallPrimitiveUncheckedSym 98 | :: (WithCallStack, MonadEmacs m v, Foldable f) 99 | => SymbolName -> f (v s) -> m s (v s) 100 | funcallPrimitiveUncheckedSym func args = do 101 | func' <- intern func 102 | funcallPrimitiveUnchecked func' args 103 | 104 | -- | Call a function by its name and ignore its result, similar to 'funcallPrimitiveSym'. 105 | {-# INLINE funcallPrimitiveSym_ #-} 106 | funcallPrimitiveSym_ 107 | :: (WithCallStack, MonadEmacs m v, Foldable f) 108 | => SymbolName -> f (v s) -> m s () 109 | funcallPrimitiveSym_ func args = 110 | void $ funcallPrimitiveSym func args 111 | 112 | {-# INLINABLE bindFunction #-} 113 | -- | Assign a name to function value. 114 | bindFunction 115 | :: (WithCallStack, MonadEmacs m v) 116 | => SymbolName -- ^ Name 117 | -> v s -- ^ Function value 118 | -> m s () 119 | bindFunction name def = do 120 | name' <- intern name 121 | funcallPrimitiveSym_ Sym.fset [name', def] 122 | 123 | {-# INLINE provide #-} 124 | -- | Signal to Emacs that certain feature is being provided. Returns provided 125 | -- symbol. 126 | provide 127 | :: (WithCallStack, MonadEmacs m v) 128 | => SymbolName -- ^ Feature to provide 129 | -> m s () 130 | provide sym = do 131 | sym' <- intern sym 132 | void $ funcallPrimitiveUncheckedSym Sym.provide [sym'] 133 | 134 | {-# INLINE makeUserPtrFromStablePtr #-} 135 | -- | Pack a stable pointer as Emacs @user_ptr@. 136 | makeUserPtrFromStablePtr 137 | :: (WithCallStack, MonadEmacs m v) 138 | => StablePtr a 139 | -> m s (v s) 140 | makeUserPtrFromStablePtr = 141 | makeUserPtr Env.freeStablePtrFinaliser . castStablePtrToPtr 142 | 143 | {-# INLINE extractStablePtrFromUserPtr #-} 144 | extractStablePtrFromUserPtr 145 | :: (WithCallStack, MonadEmacs m v) 146 | => v s 147 | -> m s (StablePtr a) 148 | extractStablePtrFromUserPtr = 149 | fmap castPtrToStablePtr . extractUserPtr 150 | 151 | {-# INLINE extractInt #-} 152 | -- | Try to obtain an 'Int' from Emacs value. 153 | -- 154 | -- This function will fail if Emacs value is not an integer or 155 | -- contains value too big to fit into 'Int' on current architecture. 156 | extractInt 157 | :: (WithCallStack, MonadEmacs m v) => v s -> m s Int 158 | extractInt x = do 159 | y <- extractWideInteger x 160 | emacsAssert 161 | (y <= fromIntegral (maxBound :: Int)) 162 | ("Integer is too wide to fit into Int: " ++ show y) 163 | (pure (fromIntegral y)) 164 | 165 | extractOsPath 166 | :: (WithCallStack, MonadEmacs m v) => v s -> m s OsPath 167 | extractOsPath x = do 168 | #ifdef WINDOWS 169 | OsString . WindowsString . BSS.toShort . TE.encodeUtf16LE <$> extractText x 170 | #else 171 | OsString . PosixString <$> extractShortByteString x 172 | #endif 173 | 174 | {-# INLINE makeInt #-} 175 | -- | Pack an 'Int' integer for Emacs. 176 | makeInt 177 | :: (WithCallStack, MonadEmacs m v) => Int -> m s (v s) 178 | makeInt = makeWideInteger . fromIntegral 179 | 180 | {-# INLINE makeText #-} 181 | -- | Convert a Text into an Emacs string value. 182 | makeText 183 | :: (WithCallStack, MonadEmacs m v) 184 | => Text -> m s (v s) 185 | makeText = makeString . TE.encodeUtf8 186 | 187 | {-# INLINE makeShortByteString #-} 188 | -- | Convert a ShortByteString into an Emacs string value. 189 | makeShortByteString 190 | :: (WithCallStack, MonadEmacs m v) 191 | => ShortByteString -> m s (v s) 192 | makeShortByteString = makeString . BSS.fromShort 193 | 194 | 195 | {-# INLINE extractBool #-} 196 | -- | Extract a boolean from an Emacs value. 197 | extractBool 198 | :: (WithCallStack, MonadEmacs m v) 199 | => v s -> m s Bool 200 | extractBool = isNotNil 201 | 202 | {-# INLINE makeBool #-} 203 | -- | Convert a Bool into an Emacs string value. 204 | makeBool 205 | :: (WithCallStack, MonadEmacs m v) 206 | => Bool -> m s (v s) 207 | makeBool b = if b then intern Sym.t else nil 208 | 209 | {-# INLINE extractVectorWith #-} 210 | -- | Get all elements form an Emacs vector. 211 | extractVectorWith 212 | :: (WithCallStack, MonadEmacs m v, G.Vector w a) 213 | => (v s -> m s a) -> v s -> m s (w a) 214 | extractVectorWith f xs = do 215 | n <- vecSize xs 216 | G.generateM n $ f <=< unsafeVecGet xs 217 | 218 | {-# INLINE extractVectorMutableWith #-} 219 | -- | Get all elements form an Emacs vector. 220 | extractVectorMutableWith 221 | :: (WithCallStack, MonadEmacs m v, GM.MVector w a) 222 | => (v s -> m s a) -> v s -> m s (w (PrimState (m s)) a) 223 | extractVectorMutableWith f xs = do 224 | n <- vecSize xs 225 | GM.generateM n $ f <=< unsafeVecGet xs 226 | 227 | {-# INLINE extractVectorAsPrimArrayWith #-} 228 | -- | Get all elements form an Emacs vector. 229 | extractVectorAsPrimArrayWith 230 | :: (WithCallStack, MonadEmacs m v, Prim a) 231 | => (v s -> m s a) -> v s -> m s (PrimArray a) 232 | extractVectorAsPrimArrayWith f xs = do 233 | n <- vecSize xs 234 | generatePrimArrayA n $ f <=< unsafeVecGet xs 235 | 236 | {-# INLINE makeVector #-} 237 | -- | Create an Emacs vector. 238 | makeVector 239 | :: (WithCallStack, MonadEmacs m v, Foldable f) 240 | => f (v s) 241 | -> m s (v s) 242 | makeVector = funcallPrimitiveUncheckedSym Sym.vector 243 | 244 | {-# INLINE vconcat2 #-} 245 | -- | Concatenate two vectors. 246 | vconcat2 247 | :: (WithCallStack, MonadEmacs m v) 248 | => v s 249 | -> v s 250 | -> m s (v s) 251 | vconcat2 x y = 252 | funcallPrimitiveSym Sym.vconcat (Tuple2 (x, y)) 253 | 254 | {-# INLINE cons #-} 255 | -- | Make a cons pair out of two values. 256 | cons 257 | :: (WithCallStack, MonadEmacs m v) 258 | => v s -- ^ car 259 | -> v s -- ^ cdr 260 | -> m s (v s) 261 | cons x y = funcallPrimitiveUncheckedSym Sym.cons (Tuple2 (x, y)) 262 | 263 | {-# INLINE car #-} 264 | -- | Take first element of a pair. 265 | 266 | car 267 | :: (WithCallStack, MonadEmacs m v) 268 | => v s 269 | -> m s (v s) 270 | car = funcallPrimitiveUncheckedSym Sym.car . Tuple1 271 | 272 | {-# INLINE cdr #-} 273 | -- | Take second element of a pair. 274 | cdr 275 | :: (WithCallStack, MonadEmacs m v) 276 | => v s 277 | -> m s (v s) 278 | cdr = funcallPrimitiveUncheckedSym Sym.cdr . Tuple1 279 | 280 | {-# INLINE nil #-} 281 | -- | A @nil@ symbol aka empty list. 282 | nil 283 | :: (WithCallStack, MonadEmacs m v) 284 | => m s (v s) 285 | nil = intern Sym.nil 286 | 287 | {-# INLINE setcar #-} 288 | -- | Mutate first element of a cons pair. 289 | setcar 290 | :: (WithCallStack, MonadEmacs m v) 291 | => v s -- ^ Cons pair 292 | -> v s -- ^ New value 293 | -> m s () 294 | setcar x y = funcallPrimitiveSym_ Sym.setcar (Tuple2 (x, y)) 295 | 296 | {-# INLINE setcdr #-} 297 | -- | Mutate second element of a cons pair. 298 | setcdr 299 | :: (WithCallStack, MonadEmacs m v) 300 | => v s -- ^ Cons pair 301 | -> v s -- ^ New value 302 | -> m s () 303 | setcdr x y = funcallPrimitiveSym_ Sym.setcdr (Tuple2 (x, y)) 304 | 305 | -- {-# INLINE makeList #-} 306 | -- -- | Construct vanilla Emacs list from a Haskell list. 307 | -- makeList 308 | -- :: (WithCallStack, MonadEmacs m v, Foldable f) 309 | -- => f (v s) 310 | -- -> m s (v s) 311 | -- makeList = unfoldEmacsListWith (pure . go) . toList 312 | -- where 313 | -- go = \case 314 | -- [] -> Nothing 315 | -- y : ys -> Just (y, ys) 316 | 317 | {-# INLINE makeList #-} 318 | -- | Construct vanilla Emacs list from a Haskell list. 319 | makeList 320 | :: (WithCallStack, MonadEmacs m v, Foldable f) 321 | => f (v s) 322 | -> m s (v s) 323 | makeList xs = do 324 | nilVal <- nil 325 | mkListLoop (reverse (toList xs)) nilVal 326 | where 327 | mkListLoop ys res = case ys of 328 | [] -> pure res 329 | z : zs -> mkListLoop zs =<< cons z res 330 | 331 | {-# INLINE extractList #-} 332 | -- | Extract vanilla Emacs list as Haskell list. 333 | extractList 334 | :: (WithCallStack, MonadEmacs m v) 335 | => v s 336 | -> m s [v s] 337 | extractList = extractListWith pure 338 | 339 | {-# INLINE extractListWith #-} 340 | -- | Extract vanilla Emacs list as a Haskell list. 341 | extractListWith 342 | :: (WithCallStack, MonadEmacs m v) 343 | => (v s -> m s a) 344 | -> v s 345 | -> m s [a] 346 | extractListWith f = extractListLoop 347 | where 348 | extractListLoop xs = unsafeInterleave $ do 349 | nonNil <- isNotNil xs 350 | if nonNil 351 | then 352 | (:) <$> (f =<< car xs) <*> (extractListLoop =<< cdr xs) 353 | else 354 | pure [] 355 | 356 | {-# INLINE foldlEmacsListWith #-} 357 | -- | Fold Emacs list starting from the left. 358 | foldlEmacsListWith 359 | :: (WithCallStack, MonadEmacs m v) 360 | => (a -> v s -> m s a) 361 | -> a 362 | -> v s 363 | -> m s a 364 | foldlEmacsListWith f = go 365 | where 366 | go acc xs = do 367 | nonNil <- isNotNil xs 368 | if nonNil 369 | then do 370 | acc' <- f acc =<< car xs 371 | go acc' =<< cdr xs 372 | else pure acc 373 | 374 | {-# INLINE unfoldEmacsListWith #-} 375 | -- | Fold Emacs list starting from the left. 376 | unfoldEmacsListWith 377 | :: (WithCallStack, MonadEmacs m v) 378 | => (a -> m s (Maybe (v s, a))) 379 | -> a 380 | -> m s (v s) 381 | unfoldEmacsListWith f accum = do 382 | accum' <- f accum 383 | nilVal <- nil 384 | case accum' of 385 | Nothing -> pure nilVal 386 | Just (x, accum'') -> do 387 | cell <- cons x nilVal 388 | go nilVal accum'' cell 389 | pure cell 390 | where 391 | go nilVal = go' 392 | where 393 | go' acc cell = do 394 | f acc >>= \case 395 | Nothing -> pure () 396 | Just (x, acc'') -> do 397 | cell' <- cons x nilVal 398 | setcdr cell cell' 399 | go' acc'' cell' 400 | 401 | {-# INLINE addFaceProp #-} 402 | -- | Add new 'face property to a string. 403 | addFaceProp 404 | :: (WithCallStack, MonadEmacs m v) 405 | => v s -- ^ String to add face to 406 | -> SymbolName -- ^ Face name 407 | -> m s (v s) -- ^ Propertised string 408 | addFaceProp str face = do 409 | face' <- intern face 410 | propertize str [(Sym.face, face')] 411 | 412 | {-# INLINE propertize #-} 413 | -- | Add new 'face property to a string. 414 | propertize 415 | :: (WithCallStack, MonadEmacs m v) 416 | => v s -- ^ String to add properties to 417 | -> [(SymbolName, v s)] -- ^ Properties 418 | -> m s (v s) -- ^ Propertised string 419 | propertize str props = do 420 | props' <- traverse (\(name, val) -> (\name' -> [name', val]) <$> intern name) props 421 | funcallPrimitiveSym Sym.propertize (str : concat props') 422 | 423 | {-# INLINE concat2 #-} 424 | -- | Concatenate two strings. 425 | concat2 426 | :: (WithCallStack, MonadEmacs m v) 427 | => v s 428 | -> v s 429 | -> m s (v s) 430 | concat2 x y = 431 | funcallPrimitiveSym Sym.concat (Tuple2 (x, y)) 432 | 433 | {-# INLINE valueToText #-} 434 | -- | Convert an Emacs value into a string using @prin1-to-string@. 435 | valueToText 436 | :: (WithCallStack, MonadEmacs m v) 437 | => v s 438 | -> m s Text 439 | valueToText = 440 | extractText <=< funcallPrimitiveUncheckedSym Sym.prin1ToString . Tuple1 441 | 442 | {-# INLINE symbolName #-} 443 | -- | Wrapper around Emacs @symbol-name@ function - take a symbol 444 | -- and produce an Emacs string with its textual name. 445 | symbolName 446 | :: (WithCallStack, MonadEmacs m v) 447 | => v s 448 | -> m s (v s) 449 | symbolName = funcallPrimitiveSym Sym.symbolName . Tuple1 450 | -------------------------------------------------------------------------------- /src/Emacs/Module/Monad/Common.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Monad.Common 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE MagicHash #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE UnboxedTuples #-} 14 | 15 | module Emacs.Module.Monad.Common 16 | ( EmacsRes(..) 17 | , NonLocalState(..) 18 | , withNonLocalState 19 | , unpackEnumFuncallExit 20 | , unpackEnumFuncallExitSafe 21 | , Emacs.Module.Monad.Common.nonLocalExitGet 22 | , nonLocalExitSignal 23 | , extractText 24 | , extractShortByteString 25 | , extractByteString 26 | , checkNonLocalExitSignal 27 | , checkNonLocalExitFull 28 | , extractSignalInfo 29 | , extractTextUnsafe 30 | ) where 31 | 32 | import Control.Exception 33 | import Control.Monad.Primitive 34 | import Data.ByteString qualified as BS 35 | import Data.ByteString.Internal qualified as BSI 36 | import Data.ByteString.Short (ShortByteString) 37 | import Data.ByteString.Short qualified as SBS 38 | import Data.Text (Text) 39 | import Data.Text.Array qualified as TA 40 | import Data.Text.Internal qualified as T 41 | import Data.Traversable 42 | import Data.Tuple.Homogenous 43 | import Data.Void 44 | import Foreign.C.Types 45 | import Foreign.Ptr 46 | import Foreign.Storable 47 | import GHC.Exts 48 | import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(PlainPtr)) 49 | import GHC.IO 50 | import GHC.Stack (CallStack, callStack) 51 | import Prettyprinter 52 | 53 | #ifdef ASSERTIONS 54 | import Data.Text.Encoding qualified as TE 55 | import Foreign.ForeignPtr qualified as Foreign 56 | #endif 57 | 58 | import Data.Emacs.Module.Env.Functions 59 | import Data.Emacs.Module.NonNullPtr 60 | import Data.Emacs.Module.Raw.Env (EnumFuncallExit(..)) 61 | import Data.Emacs.Module.Raw.Env qualified as Env 62 | import Data.Emacs.Module.Raw.Env.Internal 63 | import Data.Emacs.Module.Raw.Value 64 | import Data.Emacs.Module.SymbolName.Internal 65 | import Data.Emacs.Module.SymbolName.Predefined qualified as Sym 66 | import Emacs.Module.Assert 67 | import Emacs.Module.Errors 68 | import Foreign.Ptr.Builder as PtrBuilder 69 | 70 | data EmacsRes s t a 71 | = EmacsSuccess a 72 | | EmacsExitSignal s 73 | | EmacsExitThrow t 74 | deriving (Functor, Foldable, Traversable) 75 | 76 | data NonLocalState = NonLocalState 77 | { nlsErr :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular)) 78 | , nlsData :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular)) 79 | , nlsSize :: {-# UNPACK #-} !(NonNullPtr CPtrdiff) 80 | } 81 | 82 | withNonLocalState :: (NonLocalState -> IO a) -> IO a 83 | withNonLocalState f = 84 | allocaNonNull $ \ !nlsErr -> 85 | allocaNonNull $ \ !nlsData -> 86 | allocaNonNull $ \ !nlsSize -> 87 | f NonLocalState{nlsErr, nlsData, nlsSize} 88 | 89 | unpackEnumFuncallExit 90 | :: WithCallStack 91 | => EnumFuncallExit -> IO (FuncallExit ()) 92 | unpackEnumFuncallExit = 93 | either throwIO pure . unpackEnumFuncallExitSafe 94 | 95 | unpackEnumFuncallExitSafe 96 | :: WithCallStack 97 | => EnumFuncallExit -> Either EmacsInternalError (FuncallExit ()) 98 | unpackEnumFuncallExitSafe (EnumFuncallExit (CInt !x)) = 99 | case funcallExitFromNum x of 100 | Nothing -> Left $ mkEmacsInternalError $ 101 | "Unknown value of enum emacs_funcall_exit:" <+> pretty x 102 | Just y -> Right y 103 | 104 | {-# INLINE nonLocalExitGet #-} 105 | nonLocalExitGet 106 | :: WithCallStack 107 | => Env 108 | -> NonLocalState 109 | -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular)) 110 | nonLocalExitGet env NonLocalState{nlsErr, nlsData} = do 111 | exit <- Env.nonLocalExitGet env nlsErr nlsData 112 | foldFuncallExitFromNum 113 | (unEnumFuncallExit exit) 114 | (throwIO $ mkEmacsInternalError $ "Unknown value of enum emacs_funcall_exit:" <+> pretty exit) 115 | (\x -> 116 | for x $ \(_ :: ()) -> 117 | (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData)) 118 | -- x <- unpackEnumFuncallExit =<< Env.nonLocalExitGet env nlsErr nlsData 119 | -- for x $ \(_ :: ()) -> 120 | -- (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData) 121 | 122 | {-# INLINE nonLocalExitSignal #-} 123 | nonLocalExitSignal 124 | :: WithCallStack 125 | => BuilderCache (RawValue a) 126 | -> Env 127 | -> CallStack 128 | -> RawValue 'Unknown -- ^ Error symbol 129 | -> Builder (RawValue 'Regular) -- ^ Error data 130 | -> IO EmacsSignal 131 | nonLocalExitSignal cache env !emacsSignalOrigin !sym !dat = do 132 | listSym <- reifySymbolUnknown env Sym.list 133 | withPtrLenNonNull (coerceBuilderCache cache) dat $ \n args -> do 134 | dat' <- Env.funcallPrimitive env listSym (fromIntegral n) args 135 | emacsSignalInfo <- extractSignalInfo cache env sym dat' 136 | Env.nonLocalExitSignal env sym dat' 137 | pure EmacsSignal 138 | { emacsSignalSym = toUnknown sym 139 | , emacsSignalData = dat' 140 | , emacsSignalOrigin 141 | , emacsSignalInfo 142 | } 143 | 144 | {-# INLINE extractStringWith #-} 145 | extractStringWith 146 | :: WithCallStack 147 | => BuilderCache (RawValue a) 148 | -> Env 149 | -> NonLocalState 150 | -> RawValue p 151 | -> (Int# -> MutableByteArray# RealWorld -> IO b) 152 | -> IO (EmacsRes EmacsSignal Void b) 153 | extractStringWith cache env !nls@NonLocalState{nlsSize} !x k = do 154 | res <- Env.copyStringContents env x nullPtr nlsSize 155 | if Env.isNonTruthy res 156 | then do 157 | Env.nonLocalExitClear env 158 | throwIO $ mkEmacsInternalError 159 | "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string." 160 | else do 161 | I# size# <- fromIntegral <$> peek (unNonNullPtr nlsSize) 162 | IO $ \s1 -> case newPinnedByteArray# size# s1 of 163 | (# s2, mbarr# #) -> (\kk -> kk s2) (unIO (do 164 | !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr#)) nlsSize 165 | if Env.isTruthy copyPerformed 166 | then 167 | EmacsSuccess <$> k size# mbarr# 168 | else 169 | nonLocalExitGet env nls >>= \case 170 | FuncallExitSignal (sym, dat) -> do 171 | -- Important to clean up so that we can still call Emacs functions to make nil return value, etc 172 | Env.nonLocalExitClear env 173 | emacsSignalInfo <- extractSignalInfo cache env sym dat 174 | pure $ EmacsExitSignal $ EmacsSignal 175 | { emacsSignalSym = toUnknown sym 176 | , emacsSignalData = dat 177 | , emacsSignalOrigin = callStack 178 | , emacsSignalInfo 179 | } 180 | FuncallExitReturn -> 181 | throwIO $ mkEmacsInternalError "Failed to unpack string" 182 | FuncallExitThrow{} -> 183 | throwIO $ mkEmacsInternalError 184 | "The copy string contents operation should have never exited via throw")) 185 | 186 | {-# INLINE extractText #-} 187 | extractText 188 | :: WithCallStack 189 | => BuilderCache (RawValue a) 190 | -> Env 191 | -> NonLocalState 192 | -> RawValue p 193 | -> IO (EmacsRes EmacsSignal Void Text) 194 | extractText cache env nls x = 195 | extractStringWith cache env nls x $ \size# mbarr# -> 196 | #ifdef ASSERTIONS 197 | do 198 | -- Should subtract 1 from size to avoid NULL terminator at the end. 199 | ptr <- Foreign.newForeignPtr_ (Ptr (mutableByteArrayContents# mbarr#)) 200 | evaluate $ TE.decodeUtf8 $ BSI.BS ptr (I# (size# -# 1#)) 201 | #endif 202 | #ifndef ASSERTIONS 203 | IO $ \s1 -> 204 | case unsafeFreezeByteArray# mbarr# s1 of 205 | (# s2, barr #) -> 206 | -- Should subtract 1 from size to avoid NULL terminator at the end. 207 | (# s2, T.Text (TA.ByteArray barr) 0 (I# (size# -# 1#)) #) 208 | #endif 209 | 210 | {-# INLINE extractShortByteString #-} 211 | extractShortByteString 212 | :: WithCallStack 213 | => BuilderCache (RawValue a) 214 | -> Env 215 | -> NonLocalState 216 | -> RawValue p 217 | -> IO (EmacsRes EmacsSignal Void ShortByteString) 218 | extractShortByteString cache env nls x = 219 | extractStringWith cache env nls x $ \size# mbarr# -> 220 | IO $ \s3 -> 221 | -- Should subtract 1 from size to avoid NULL terminator at the end. 222 | case shrinkMutableByteArray# mbarr# (size# -# 1#) s3 of 223 | s4 -> 224 | case unsafeFreezeByteArray# mbarr# s4 of 225 | (# s5, barr #) -> 226 | (# s5, SBS.SBS barr #) 227 | 228 | {-# INLINE extractByteString #-} 229 | extractByteString 230 | :: WithCallStack 231 | => BuilderCache (RawValue a) 232 | -> Env 233 | -> NonLocalState 234 | -> RawValue p 235 | -> IO (EmacsRes EmacsSignal Void BS.ByteString) 236 | extractByteString cache env nls x = 237 | extractStringWith cache env nls x $ \size# mbarr# -> evaluate $ BSI.BS 238 | (ForeignPtr 239 | (mutableByteArrayContents# mbarr#) 240 | (PlainPtr mbarr#)) 241 | -- Should subtract 1 from size to avoid NULL terminator at the end. 242 | (I# (size# -# 1#)) 243 | 244 | {-# INLINE checkNonLocalExitSignal #-} 245 | checkNonLocalExitSignal 246 | :: WithCallStack 247 | => BuilderCache (RawValue b) 248 | -> Env 249 | -> NonLocalState 250 | -> Text 251 | -> a 252 | -> IO (EmacsRes EmacsSignal Void a) 253 | checkNonLocalExitSignal cache env !nls !errMsg !res = do 254 | nonLocalExitGet env nls >>= \ case 255 | FuncallExitReturn -> 256 | pure $ EmacsSuccess res 257 | FuncallExitSignal (sym, dat) -> do 258 | -- Important to clean up so that we can still call Emacs functions to make nil return value, etc 259 | Env.nonLocalExitClear env 260 | emacsSignalInfo <- extractSignalInfo cache env sym dat 261 | pure $ EmacsExitSignal $ EmacsSignal 262 | { emacsSignalSym = toUnknown sym 263 | , emacsSignalData = dat 264 | , emacsSignalOrigin = callStack 265 | , emacsSignalInfo 266 | } 267 | FuncallExitThrow{} -> 268 | throwIO $ mkEmacsInternalError $ 269 | "The operation should have never exited via throw:" <> line <> pretty errMsg 270 | 271 | {-# INLINE checkNonLocalExitFull #-} 272 | checkNonLocalExitFull 273 | :: WithCallStack 274 | => BuilderCache (RawValue b) 275 | -> Env 276 | -> NonLocalState 277 | -> a 278 | -> IO (EmacsRes EmacsSignal EmacsThrow a) 279 | checkNonLocalExitFull cache env !nls !res = 280 | nonLocalExitGet env nls >>= \case 281 | FuncallExitReturn -> 282 | pure $ EmacsSuccess res 283 | FuncallExitSignal (sym, dat) -> do 284 | -- Important to clean up so that we can still call Emacs functions to make nil return value, etc 285 | Env.nonLocalExitClear env 286 | emacsSignalInfo <- extractSignalInfo cache env sym dat 287 | pure $ EmacsExitSignal $ EmacsSignal 288 | { emacsSignalSym = toUnknown sym 289 | , emacsSignalData = dat 290 | , emacsSignalOrigin = callStack 291 | , emacsSignalInfo 292 | } 293 | -- -- Important to clean up so that we can still call Emacs 294 | -- -- functions to make nil return value, etc 295 | -- Env.nonLocalExitClear env 296 | FuncallExitThrow (tag, value) -> do 297 | -- Important to clean up so that we can still call Emacs functions to make nil return value, etc 298 | Env.nonLocalExitClear env 299 | pure $ EmacsExitThrow $ EmacsThrow 300 | { emacsThrowTag = tag 301 | , emacsThrowValue = value 302 | , emacsThrowOrigin = callStack 303 | } 304 | 305 | extractSignalInfo 306 | :: WithCallStack 307 | => BuilderCache (RawValue a) -> Env -> RawValue p -> RawValue 'Regular -> IO Text 308 | extractSignalInfo cache env !sym !dat = do 309 | cons <- reifySymbolUnknown env Sym.cons 310 | dat' <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple2 (toUnknown sym, toUnknown dat)) $ \n args -> 311 | Env.funcallPrimitive env cons (fromIntegral n) args 312 | prin1ToString <- reifySymbolUnknown env Sym.prin1ToString 313 | formatted <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple1 dat') $ \n args -> 314 | Env.funcallPrimitive env prin1ToString (fromIntegral n) args 315 | formatRes <- unpackEnumFuncallExit =<< Env.nonLocalExitCheck env 316 | case formatRes of 317 | FuncallExitSignal{} -> do 318 | Env.nonLocalExitClear env 319 | throwIO $ mkEmacsInternalError "Failed to format Emacs signal data" 320 | FuncallExitThrow{} -> do 321 | Env.nonLocalExitClear env 322 | throwIO $ mkEmacsInternalError "Failed to format Emacs signal data" 323 | FuncallExitReturn -> 324 | extractTextUnsafe env formatted 325 | 326 | extractTextUnsafe 327 | :: WithCallStack 328 | => Env 329 | -> RawValue p 330 | -> IO Text 331 | extractTextUnsafe env !x = do 332 | allocaNonNull $ \pSize -> do 333 | res <- Env.copyStringContents env x nullPtr pSize 334 | if Env.isNonTruthy res 335 | then do 336 | Env.nonLocalExitClear env 337 | throwIO $ mkEmacsInternalError 338 | "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string." 339 | else do 340 | !size@(I# size#) <- fromIntegral <$> peek (unNonNullPtr pSize) 341 | IO $ \s1 -> case newPinnedByteArray# size# s1 of 342 | (# s2, mbarr #) -> (\k -> k s2) (unIO (do 343 | !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr)) pSize 344 | if Env.isTruthy copyPerformed 345 | then 346 | IO $ \s3 -> 347 | case unsafeFreezeByteArray# mbarr s3 of 348 | (# s4, barr #) -> 349 | -- Should subtract 1 from size to avoid NULL terminator at the end. 350 | (# s4, T.Text (TA.ByteArray barr) 0 (size - 1) #) 351 | else do 352 | Env.nonLocalExitClear env 353 | throwIO $ mkEmacsInternalError "Failed to unpack string")) 354 | -------------------------------------------------------------------------------- /src/Data/Emacs/Module/Raw/Env.hsc: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Emacs.Module.Raw.Env 4 | -- Copyright : (c) Sergey Vinokurov 2018 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | -- 8 | -- Low-level and, hopefully, low-overhead wrappers around @struct emacs_env@. 9 | ---------------------------------------------------------------------------- 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE ForeignFunctionInterface #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE UnliftedFFITypes #-} 15 | 16 | {-# OPTIONS_HADDOCK not-home #-} 17 | 18 | module Data.Emacs.Module.Raw.Env 19 | ( EnumFuncallExit(..) 20 | , EnumProcessInputResult(..) 21 | , Env 22 | , CBoolean 23 | , isTruthy 24 | , isNonTruthy 25 | , isValidEnv 26 | 27 | , makeGlobalRef 28 | , freeGlobalRef 29 | 30 | , nonLocalExitCheck 31 | , nonLocalExitGet 32 | , nonLocalExitSignal 33 | , nonLocalExitThrow 34 | , nonLocalExitClear 35 | 36 | , variadicFunctionArgs 37 | , makeFunction 38 | 39 | , funcall 40 | , funcallPrimitive 41 | , intern 42 | , typeOf 43 | , isNotNil 44 | , eq 45 | 46 | , extractInteger 47 | , makeInteger 48 | , extractFloat 49 | , makeFloat 50 | , copyStringContents 51 | , makeString 52 | , makeUnibyteString 53 | , makeUserPtr 54 | , getUserPtr 55 | , setUserPtr 56 | , getUserFinaliser 57 | , setUserFinaliser 58 | , vecGet 59 | , vecSet 60 | , vecSize 61 | , setFunctionFinalizer 62 | , processInput 63 | ) where 64 | 65 | import Control.Monad.IO.Class 66 | 67 | import Data.Coerce 68 | import Foreign 69 | import Foreign.C 70 | import Prettyprinter 71 | 72 | import Data.Emacs.Module.NonNullPtr 73 | import Data.Emacs.Module.Raw.Env.Internal as Env 74 | import Data.Emacs.Module.Raw.Env.TH 75 | import Data.Emacs.Module.Raw.Value 76 | import Data.Emacs.Module.Raw.Value.Internal 77 | 78 | import Data.Emacs.Module.NonNullPtr.Internal 79 | 80 | #include 81 | 82 | newtype EnumFuncallExit = EnumFuncallExit { unEnumFuncallExit :: CInt } 83 | 84 | instance Pretty EnumFuncallExit where 85 | pretty (EnumFuncallExit (CInt x)) = pretty x 86 | 87 | newtype EnumProcessInputResult = EnumProcessInputResult { unEnumProcessInputResult :: CInt } 88 | 89 | instance Pretty EnumProcessInputResult where 90 | pretty (EnumProcessInputResult (CInt x)) = pretty x 91 | 92 | -- | A wrapper around C value that denotes true or false. 93 | newtype CBoolean = CBoolean (#type bool) 94 | 95 | {-# INLINE isTruthy #-} 96 | -- | Check whether a 'CBoolean' denotes true. 97 | isTruthy :: CBoolean -> Bool 98 | isTruthy (CBoolean a) = a /= 0 99 | 100 | {-# INLINE isNonTruthy #-} 101 | -- | Check whether a 'CBoolean' denotes false. 102 | isNonTruthy :: CBoolean -> Bool 103 | isNonTruthy (CBoolean a) = a == 0 104 | 105 | 106 | 107 | {-# INLINE isValidEnv #-} 108 | -- | Check wheter passed @emacs_env@ structure has expected size so that 109 | -- we will be able to access all of its fields. 110 | isValidEnv :: MonadIO m => Env -> m Bool 111 | isValidEnv env = liftIO $ do 112 | realSize <- (#peek emacs_env, size) (Env.toPtr env) 113 | pure $ expectedSize <= realSize 114 | where 115 | expectedSize :: CPtrdiff 116 | expectedSize = (#size struct emacs_env_28) 117 | 118 | $(wrapEmacsFunc "makeGlobalRefTH" Unsafe 119 | [e| (#peek emacs_env, make_global_ref) |] 120 | [t| forall p. Env -> RawValue p -> IO (RawValue 'Pinned) |]) 121 | 122 | {-# INLINE makeGlobalRef #-} 123 | makeGlobalRef 124 | :: forall m p. MonadIO m 125 | => Env 126 | -> RawValue p 127 | -> m (RawValue 'Pinned) 128 | makeGlobalRef env x = 129 | liftIO $ makeGlobalRefTH env x 130 | 131 | 132 | $(wrapEmacsFunc "freeGlobalRefTH" Unsafe 133 | [e| (#peek emacs_env, free_global_ref) |] 134 | [t| Env -> RawValue 'Pinned -> IO () |]) 135 | 136 | {-# INLINE freeGlobalRef #-} 137 | freeGlobalRef 138 | :: forall m. MonadIO m 139 | => Env 140 | -> RawValue 'Pinned 141 | -> m () 142 | freeGlobalRef env x = 143 | liftIO $ freeGlobalRefTH env x 144 | 145 | 146 | $(wrapEmacsFunc "nonLocalExitCheckTH" Unsafe 147 | [e| (#peek emacs_env, non_local_exit_check) |] 148 | [t| Env -> IO EnumFuncallExit |]) 149 | 150 | {-# INLINE nonLocalExitCheck #-} 151 | nonLocalExitCheck 152 | :: MonadIO m 153 | => Env 154 | -> m EnumFuncallExit 155 | nonLocalExitCheck = nonLocalExitCheckTH 156 | 157 | 158 | $(wrapEmacsFunc "nonLocalExitGetTH" Unsafe 159 | [e| (#peek emacs_env, non_local_exit_get) |] 160 | [t| Env -> NonNullPtr (RawValue 'Regular) -> NonNullPtr (RawValue 'Regular) -> IO EnumFuncallExit |]) 161 | 162 | {-# INLINE nonLocalExitGet #-} 163 | nonLocalExitGet 164 | :: MonadIO m 165 | => Env 166 | -> NonNullPtr (RawValue 'Regular) -- ^ Symbol output 167 | -> NonNullPtr (RawValue 'Regular) -- ^ Data output 168 | -> m EnumFuncallExit 169 | nonLocalExitGet = nonLocalExitGetTH 170 | 171 | 172 | $(wrapEmacsFunc "nonLocalExitSignalTH" Unsafe 173 | [e| (#peek emacs_env, non_local_exit_signal) |] 174 | [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO () |]) 175 | 176 | {-# INLINE nonLocalExitSignal #-} 177 | nonLocalExitSignal 178 | :: MonadIO m 179 | => Env 180 | -> RawValue p1 -- ^ Error symbol 181 | -> RawValue p2 -- ^ Error data 182 | -> m () 183 | nonLocalExitSignal = nonLocalExitSignalTH 184 | 185 | 186 | $(wrapEmacsFunc "nonLocalExitThrowTH" Unsafe 187 | [e| (#peek emacs_env, non_local_exit_throw) |] 188 | [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO () |]) 189 | 190 | {-# INLINE nonLocalExitThrow #-} 191 | nonLocalExitThrow 192 | :: MonadIO m 193 | => Env 194 | -> RawValue p1 -- ^ Tag, a symbol 195 | -> RawValue p2 -- ^ Value 196 | -> m () 197 | nonLocalExitThrow = nonLocalExitThrowTH 198 | 199 | 200 | $(wrapEmacsFunc "nonLocalExitClearTH" Unsafe 201 | [e| (#peek emacs_env, non_local_exit_clear) |] 202 | [t| Env -> IO () |]) 203 | 204 | {-# INLINE nonLocalExitClear #-} 205 | nonLocalExitClear 206 | :: MonadIO m 207 | => Env 208 | -> m () 209 | nonLocalExitClear = nonLocalExitClearTH 210 | 211 | 212 | variadicFunctionArgs :: CPtrdiff 213 | variadicFunctionArgs = (#const emacs_variadic_function) 214 | 215 | $(wrapEmacsFunc "makeFunctionTH" Unsafe 216 | [e| (#peek emacs_env, make_function) |] 217 | [t| forall a o. Env -> CPtrdiff -> CPtrdiff -> FunPtr (RawFunctionType o a) -> CString -> Ptr a -> IO (RawValue 'Regular) |]) 218 | 219 | {-# INLINE makeFunction #-} 220 | makeFunction 221 | :: forall m o a. MonadIO m 222 | => Env 223 | -> CPtrdiff -- ^ Minimum arity 224 | -> CPtrdiff -- ^ Maximum arity 225 | -> RawFunction o a -- ^ Implementation 226 | -> CString -- ^ Documentation 227 | -> Ptr a -- ^ Extra data 228 | -> m (RawValue 'Regular) 229 | makeFunction = 230 | coerce 231 | (makeFunctionTH :: 232 | Env 233 | -> CPtrdiff 234 | -> CPtrdiff 235 | -> FunPtr (RawFunctionType o a) 236 | -> CString 237 | -> Ptr a 238 | -> m (RawValue 'Regular)) 239 | 240 | 241 | $(wrapEmacsFunc "funcallTH" Safe 242 | [e| (#peek emacs_env, funcall) |] 243 | [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> NonNullPtr (RawValue p2) -> IO (RawValue 'Regular) |]) 244 | 245 | {-# INLINE funcall #-} 246 | funcall 247 | :: MonadIO m 248 | => Env 249 | -> RawValue p1 -- ^ Function 250 | -> CPtrdiff -- ^ Number of arguments 251 | -> NonNullPtr (RawValue p2) -- ^ Actual arguments 252 | -> m (RawValue 'Regular) 253 | funcall = funcallTH 254 | 255 | 256 | $(wrapEmacsFunc "funcallPrimitiveTH" Unsafe 257 | [e| (#peek emacs_env, funcall) |] 258 | [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> NonNullPtr (RawValue p2) -> IO (RawValue 'Regular) |]) 259 | 260 | {-# INLINE funcallPrimitive #-} 261 | funcallPrimitive 262 | :: MonadIO m 263 | => Env 264 | -> RawValue p1 -- ^ Function 265 | -> CPtrdiff -- ^ Number of arguments 266 | -> NonNullPtr (RawValue p2) -- ^ Actual arguments 267 | -> m (RawValue 'Regular) 268 | funcallPrimitive = funcallPrimitiveTH 269 | 270 | 271 | $(wrapEmacsFunc "internTH" Unsafe 272 | [e| (#peek emacs_env, intern) |] 273 | [t| Env -> CString -> IO (RawValue 'Regular) |]) 274 | 275 | {-# INLINE intern #-} 276 | intern 277 | :: MonadIO m 278 | => Env 279 | -> CString 280 | -> m (RawValue 'Regular) 281 | intern = internTH 282 | 283 | 284 | $(wrapEmacsFunc "typeOfTH" Unsafe 285 | [e| (#peek emacs_env, type_of) |] 286 | [t| forall p. Env -> RawValue p -> IO (RawValue 'Regular) |]) 287 | 288 | {-# INLINE typeOf #-} 289 | typeOf 290 | :: MonadIO m 291 | => Env 292 | -> RawValue p 293 | -> m (RawValue 'Regular) 294 | typeOf = typeOfTH 295 | 296 | 297 | $(wrapEmacsFunc "isNotNilTH" Unsafe 298 | [e| (#peek emacs_env, is_not_nil) |] 299 | [t| forall p. Env -> RawValue p -> IO CBoolean |]) 300 | 301 | {-# INLINE isNotNil #-} 302 | isNotNil 303 | :: MonadIO m 304 | => Env 305 | -> RawValue p 306 | -> m CBoolean 307 | isNotNil = isNotNilTH 308 | 309 | 310 | $(wrapEmacsFunc "eqTH" Unsafe 311 | [e| (#peek emacs_env, eq) |] 312 | [t| forall p1 p2. Env -> RawValue p1 -> RawValue p2 -> IO CBoolean |]) 313 | 314 | {-# INLINE eq #-} 315 | eq 316 | :: MonadIO m 317 | => Env 318 | -> RawValue p1 319 | -> RawValue p2 320 | -> m CBoolean 321 | eq = eqTH 322 | 323 | 324 | $(wrapEmacsFunc "extractIntegerTH" Unsafe 325 | [e| (#peek emacs_env, extract_integer) |] 326 | [t| forall p. Env -> RawValue p -> IO CIntMax |]) 327 | 328 | {-# INLINE extractInteger #-} 329 | extractInteger 330 | :: MonadIO m 331 | => Env 332 | -> RawValue p 333 | -> m CIntMax 334 | extractInteger = extractIntegerTH 335 | 336 | 337 | $(wrapEmacsFunc "makeIntegerTH" Unsafe 338 | [e| (#peek emacs_env, make_integer) |] 339 | [t| Env -> CIntMax -> IO (RawValue 'Regular) |]) 340 | 341 | {-# INLINE makeInteger #-} 342 | makeInteger 343 | :: MonadIO m 344 | => Env 345 | -> CIntMax 346 | -> m (RawValue 'Regular) 347 | makeInteger = makeIntegerTH 348 | 349 | 350 | $(wrapEmacsFunc "extractFloatTH" Unsafe 351 | [e| (#peek emacs_env, extract_float) |] 352 | [t| forall p. Env -> RawValue p -> IO CDouble |]) 353 | 354 | {-# INLINE extractFloat #-} 355 | extractFloat 356 | :: MonadIO m 357 | => Env 358 | -> RawValue p 359 | -> m CDouble 360 | extractFloat = extractFloatTH 361 | 362 | 363 | $(wrapEmacsFunc "makeFloatTH" Unsafe 364 | [e| (#peek emacs_env, make_float) |] 365 | [t| Env -> CDouble -> IO (RawValue 'Regular) |]) 366 | 367 | {-# INLINE makeFloat #-} 368 | makeFloat 369 | :: MonadIO m 370 | => Env 371 | -> CDouble 372 | -> m (RawValue 'Regular) 373 | makeFloat = makeFloatTH 374 | 375 | 376 | $(wrapEmacsFunc "copyStringContentsTH" Unsafe 377 | [e| (#peek emacs_env, copy_string_contents) |] 378 | [t| forall p. Env -> RawValue p -> CString -> NonNullPtr CPtrdiff -> IO CBoolean |]) 379 | 380 | {-# INLINE copyStringContents #-} 381 | -- | Copy the content of the Lisp string VALUE to BUFFER as an utf8 382 | -- null-terminated string. 383 | -- 384 | -- SIZE must point to the total size of the buffer. If BUFFER is 385 | -- NULL or if SIZE is not big enough, write the required buffer size 386 | -- to SIZE and return true. 387 | -- 388 | -- Note that SIZE must include the last null byte (e.g. "abc" needs 389 | -- a buffer of size 4). 390 | -- 391 | -- Return true if the string was successfully copied. 392 | copyStringContents 393 | :: MonadIO m 394 | => Env 395 | -> RawValue p -- ^ Emacs value that holds a string 396 | -> CString -- ^ Destination, may be NULL 397 | -> NonNullPtr CPtrdiff -- ^ SIZE pointer 398 | -> m CBoolean 399 | copyStringContents = copyStringContentsTH 400 | 401 | 402 | $(wrapEmacsFunc "makeStringTH" Unsafe 403 | [e| (#peek emacs_env, make_string) |] 404 | [t| Env -> CString -> CPtrdiff -> IO (RawValue 'Regular) |]) 405 | 406 | {-# INLINE makeString #-} 407 | makeString 408 | :: MonadIO m 409 | => Env 410 | -> CString -- ^ Utf8-encoded string, may contain null bytes and is 411 | -- not required to be terminated with one. 412 | -> CPtrdiff -- ^ Length. 413 | -> m (RawValue 'Regular) 414 | makeString = makeStringTH 415 | 416 | 417 | $(wrapEmacsFunc "makeUnibyteStringTH" Unsafe 418 | [e| (#peek emacs_env, make_unibyte_string) |] 419 | [t| Env -> CString -> CPtrdiff -> IO (RawValue 'Regular) |]) 420 | 421 | {-# INLINE makeUnibyteString #-} 422 | makeUnibyteString 423 | :: MonadIO m 424 | => Env 425 | -> CString -- ^ Any string, may contain anything bytes and is 426 | -- not required to be terminated with null byte. 427 | -> CPtrdiff -- ^ Length. 428 | -> m (RawValue 'Regular) 429 | makeUnibyteString = makeUnibyteStringTH 430 | 431 | 432 | $(wrapEmacsFunc "makeUserPtrTH" Unsafe 433 | [e| (#peek emacs_env, make_user_ptr) |] 434 | [t| forall a. Env -> FinalizerPtr a -> Ptr a -> IO (RawValue 'Regular) |]) 435 | 436 | {-# INLINE makeUserPtr #-} 437 | makeUserPtr 438 | :: forall m a. MonadIO m 439 | => Env 440 | -> FinalizerPtr a 441 | -> Ptr a 442 | -> m (RawValue 'Regular) 443 | makeUserPtr = makeUserPtrTH 444 | 445 | 446 | $(wrapEmacsFunc "getUserPtrTH" Unsafe 447 | [e| (#peek emacs_env, get_user_ptr) |] 448 | [t| forall p a. Env -> RawValue p -> IO (Ptr a) |]) 449 | 450 | {-# INLINE getUserPtr #-} 451 | getUserPtr 452 | :: MonadIO m 453 | => Env 454 | -> RawValue p 455 | -> m (Ptr a) 456 | getUserPtr = getUserPtrTH 457 | 458 | 459 | $(wrapEmacsFunc "setUserPtrTH" Unsafe 460 | [e| (#peek emacs_env, set_user_ptr) |] 461 | [t| forall p a. Env -> RawValue p -> Ptr a -> IO () |]) 462 | 463 | {-# INLINE setUserPtr #-} 464 | setUserPtr 465 | :: MonadIO m 466 | => Env 467 | -> RawValue p 468 | -> Ptr a 469 | -> m () 470 | setUserPtr = setUserPtrTH 471 | 472 | 473 | $(wrapEmacsFunc "getUserFinaliserTH" Unsafe 474 | [e| (#peek emacs_env, get_user_finalizer) |] 475 | [t| forall p a. Env -> RawValue p -> IO (FinalizerPtr a) |]) 476 | 477 | {-# INLINE getUserFinaliser #-} 478 | getUserFinaliser 479 | :: MonadIO m 480 | => Env 481 | -> RawValue p 482 | -> m (FinalizerPtr a) 483 | getUserFinaliser = getUserFinaliserTH 484 | 485 | 486 | $(wrapEmacsFunc "setUserFinaliserTH" Unsafe 487 | [e| (#peek emacs_env, set_user_finalizer) |] 488 | [t| forall p a. Env -> RawValue p -> FinalizerPtr a -> IO () |]) 489 | 490 | {-# INLINE setUserFinaliser #-} 491 | setUserFinaliser 492 | :: MonadIO m 493 | => Env 494 | -> RawValue p 495 | -> FinalizerPtr a 496 | -> m () 497 | setUserFinaliser = setUserFinaliserTH 498 | 499 | 500 | $(wrapEmacsFunc "vecGetTH" Unsafe 501 | [e| (#peek emacs_env, vec_get) |] 502 | [t| forall p. Env -> RawValue p -> CPtrdiff -> IO (RawValue 'Regular) |]) 503 | 504 | {-# INLINE vecGet #-} 505 | vecGet 506 | :: MonadIO m 507 | => Env 508 | -> RawValue p 509 | -> CPtrdiff 510 | -> m (RawValue 'Regular) 511 | vecGet = vecGetTH 512 | 513 | 514 | $(wrapEmacsFunc "vecSetTH" Unsafe 515 | [e| (#peek emacs_env, vec_set) |] 516 | [t| forall p1 p2. Env -> RawValue p1 -> CPtrdiff -> RawValue p2 -> IO () |]) 517 | 518 | {-# INLINE vecSet #-} 519 | vecSet 520 | :: MonadIO m 521 | => Env 522 | -> RawValue p1 523 | -> CPtrdiff 524 | -> RawValue p2 525 | -> m () 526 | vecSet = vecSetTH 527 | 528 | 529 | $(wrapEmacsFunc "vecSizeTH" Unsafe 530 | [e| (#peek emacs_env, vec_size) |] 531 | [t| forall p. Env -> RawValue p -> IO CPtrdiff |]) 532 | 533 | {-# INLINE vecSize #-} 534 | vecSize 535 | :: MonadIO m 536 | => Env 537 | -> RawValue p 538 | -> m CPtrdiff 539 | vecSize = vecSizeTH 540 | 541 | 542 | -- These are mostly of administrative interest. 543 | 544 | $(wrapEmacsFunc "setFunctionFinalizerTH" Unsafe 545 | [e| (#peek emacs_env, set_function_finalizer) |] 546 | [t| forall p a. Env -> RawValue p -> FinalizerPtr a -> IO () |]) 547 | 548 | {-# INLINE setFunctionFinalizer #-} 549 | setFunctionFinalizer 550 | :: MonadIO m 551 | => Env 552 | -> RawValue p 553 | -> FinalizerPtr a 554 | -> m () 555 | setFunctionFinalizer = setFunctionFinalizerTH 556 | 557 | $(wrapEmacsFunc "processInputTH" Unsafe 558 | [e| (#peek emacs_env, process_input) |] 559 | [t| Env -> IO EnumProcessInputResult |]) 560 | 561 | {-# INLINE processInput #-} 562 | -- | Processes pending input events and returns whether the module 563 | -- function should quit. 564 | processInput 565 | :: MonadIO m 566 | => Env 567 | -> m EnumProcessInputResult 568 | processInput = processInputTH 569 | 570 | -------------------------------------------------------------------------------- /src/Emacs/Module/Monad.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Emacs.Module.Monad 4 | -- Copyright : (c) Sergey Vinokurov 2022 5 | -- License : Apache-2.0 (see LICENSE) 6 | -- Maintainer : serg.foo@gmail.com 7 | ---------------------------------------------------------------------------- 8 | 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE MagicHash #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UnboxedTuples #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Emacs.Module.Monad 19 | ( module Emacs.Module.Monad.Class 20 | , EmacsM 21 | , runEmacsM 22 | ) where 23 | 24 | import Control.Exception 25 | import Control.Exception qualified as Exception 26 | import Control.Monad.Base 27 | import Control.Monad.Catch qualified as Catch 28 | import Control.Monad.Fix (MonadFix) 29 | import Control.Monad.Interleave 30 | import Control.Monad.Primitive hiding (unsafeInterleave) 31 | import Control.Monad.Reader 32 | import Control.Monad.Trans.Control 33 | import Data.ByteString qualified as BS 34 | import Data.ByteString.Short (ShortByteString) 35 | import Data.ByteString.Unsafe qualified as BSU 36 | import Data.Coerce 37 | import Data.Emacs.Module.Doc qualified as Doc 38 | import Data.Int 39 | import Data.Kind 40 | import Data.Proxy 41 | import Data.Text (Text) 42 | import Data.Void 43 | import Foreign.C.Types 44 | import Foreign.Ptr 45 | import GHC.ForeignPtr 46 | import GHC.Stack (callStack) 47 | import Prettyprinter 48 | 49 | import Data.Emacs.Module.Args 50 | import Data.Emacs.Module.Env.Functions 51 | import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput 52 | import Data.Emacs.Module.GetRawValue 53 | import Data.Emacs.Module.NonNullPtr 54 | import Data.Emacs.Module.Raw.Env qualified as Env 55 | import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType) 56 | import Data.Emacs.Module.Raw.Env.Internal qualified as Env 57 | import Data.Emacs.Module.Raw.Value 58 | import Data.Emacs.Module.SymbolName.Internal 59 | import Data.Emacs.Module.Value.Internal 60 | import Emacs.Module.Assert 61 | import Emacs.Module.Errors 62 | import Emacs.Module.Monad.Class 63 | import Emacs.Module.Monad.Common as Common 64 | import Foreign.Ptr.Builder as PtrBuilder 65 | 66 | data Environment = Environment 67 | { eEnv :: Env 68 | , eNonLocalState :: {-# UNPACK #-} !NonLocalState 69 | , eArgsCache :: BuilderCache (RawValue 'Unknown) 70 | } 71 | 72 | -- | Concrete monad for interacting with Emacs. It provides: 73 | -- 74 | -- 1. Ability to call Emacs C functions and automatically rethrows any 75 | -- errors (non-local exits) from elisp as Haskell exceptions. 76 | -- 2. Tracks ownership of any produced Emacs values and communicates 77 | -- that to Emacs, so that GC on Emacs side will not make any 78 | -- values in Haskell invalid (funnily enough, this can happen!). 79 | -- 80 | -- Parameter 's' serves to make ownership-tracking capabilities possible. 81 | -- It's use is the same as in 'Control.Monad.ST' monad. That is, it creates 82 | -- local threads so that no produced Emacs values can leave past 'runEmacsM'. 83 | newtype EmacsM (s :: k) (a :: Type) = EmacsM { unEmacsM :: ReaderT Environment IO a } 84 | deriving 85 | ( Functor 86 | , Applicative 87 | , Monad 88 | , Catch.MonadThrow 89 | , Catch.MonadCatch 90 | , Catch.MonadMask 91 | , MonadFix 92 | , PrimMonad 93 | ) 94 | 95 | instance MonadInterleave (EmacsM s) where 96 | {-# INLINE unsafeInterleave #-} 97 | unsafeInterleave (EmacsM action) = EmacsM $ do 98 | env <- ask 99 | liftBase $ unsafeInterleave $ runReaderT action env 100 | 101 | instance MonadIO (EmacsM s) where 102 | {-# INLINE liftIO #-} 103 | liftIO = EmacsM . lift 104 | 105 | instance MonadBase IO (EmacsM s) where 106 | {-# INLINE liftBase #-} 107 | liftBase = EmacsM . lift 108 | 109 | instance MonadBaseControl IO (EmacsM s) where 110 | type StM (EmacsM s) a = StM (ReaderT Environment IO) a 111 | {-# INLINE liftBaseWith #-} 112 | liftBaseWith f = EmacsM (liftBaseWith (\runInBase -> f (runInBase . unEmacsM))) 113 | {-# INLINE restoreM #-} 114 | restoreM = EmacsM . restoreM 115 | 116 | -- | Execute emacs interaction session using an environment supplied by Emacs. 117 | runEmacsM 118 | :: WithCallStack 119 | => Env 120 | -> (forall s. EmacsM s a) 121 | -> IO a 122 | runEmacsM eEnv (EmacsM action) = 123 | withNonLocalState $ \eNonLocalState -> 124 | withBuilderCache 8 $ \eArgsCache -> 125 | runReaderT action Environment { eEnv, eNonLocalState, eArgsCache } 126 | 127 | {-# INLINE withEnv #-} 128 | withEnv :: (Env -> IO a) -> EmacsM s a 129 | withEnv f = EmacsM $ do 130 | Environment{eEnv} <- ask 131 | liftBase (f eEnv) 132 | 133 | {-# INLINE withEnvCache #-} 134 | withEnvCache :: (Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a 135 | withEnvCache f = EmacsM $ do 136 | Environment{eEnv, eArgsCache} <- ask 137 | liftBase $ f eEnv (coerceBuilderCache eArgsCache) 138 | 139 | handleResult :: EmacsRes EmacsSignal EmacsThrow a -> IO a 140 | handleResult = \case 141 | EmacsSuccess x -> pure x 142 | EmacsExitSignal e -> throwIO e 143 | EmacsExitThrow e -> throwIO e 144 | 145 | handleResultNoThrow :: EmacsRes EmacsSignal Void a -> IO a 146 | handleResultNoThrow = \case 147 | EmacsSuccess x -> pure x 148 | EmacsExitSignal e -> throwIO e 149 | EmacsExitThrow e -> absurd e 150 | 151 | instance MonadEmacs EmacsM Value where 152 | 153 | {-# INLINE makeGlobalRef #-} 154 | makeGlobalRef :: WithCallStack => Value s -> EmacsM s (RawValue 'Pinned) 155 | makeGlobalRef x = withEnv $ \env -> 156 | liftBase $ Env.makeGlobalRef env $ getRawValue x 157 | 158 | {-# INLINE freeGlobalRef #-} 159 | freeGlobalRef :: WithCallStack => RawValue 'Pinned -> EmacsM s () 160 | freeGlobalRef x = withEnv $ \env -> 161 | liftBase $ Env.freeGlobalRef env x 162 | 163 | nonLocalExitCheck 164 | :: WithCallStack 165 | => EmacsM s (FuncallExit ()) 166 | nonLocalExitCheck = withEnv $ \env -> 167 | Env.nonLocalExitCheck env >>= Common.unpackEnumFuncallExit 168 | 169 | nonLocalExitGet 170 | :: WithCallStack 171 | => EmacsM s (FuncallExit (Value s, Value s)) 172 | nonLocalExitGet = EmacsM $ do 173 | Environment{eEnv, eNonLocalState} <- ask 174 | liftBase $ do 175 | res <- Common.nonLocalExitGet eEnv eNonLocalState 176 | pure $ coerce res 177 | 178 | nonLocalExitSignal 179 | :: (WithCallStack, Foldable f) 180 | => Value s -- ^ Error symbol 181 | -> f (Value s) -- ^ Error data, will be converted to a list as Emacs API expects. 182 | -> EmacsM s () 183 | nonLocalExitSignal sym errData = withEnvCache $ \env cache -> 184 | Exception.throwIO =<< Common.nonLocalExitSignal cache env callStack (coerce sym) errData' 185 | where 186 | errData' = 187 | foldMap (coerce (PtrBuilder.storable :: RawValue 'Regular -> PtrBuilder.Builder (RawValue 'Regular))) errData 188 | 189 | nonLocalExitThrow 190 | :: WithCallStack 191 | => Value s -- ^ Tag 192 | -> Value s -- ^ Data 193 | -> EmacsM s () 194 | nonLocalExitThrow tag errData = withEnv $ \env -> do 195 | Env.nonLocalExitThrow env tag' errData' 196 | Exception.throwIO EmacsThrow 197 | { emacsThrowTag = tag' 198 | , emacsThrowValue = errData' 199 | , emacsThrowOrigin = callStack 200 | } 201 | where 202 | tag' = getRawValue tag 203 | errData' = getRawValue errData 204 | 205 | nonLocalExitClear :: WithCallStack => EmacsM s () 206 | nonLocalExitClear = withEnv Env.nonLocalExitClear 207 | 208 | {-# INLINE makeFunction #-} 209 | makeFunction 210 | :: forall req opt rest s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest) 211 | => (forall s'. EmacsFunction req opt rest EmacsM Value s') 212 | -> Doc.Doc 213 | -> EmacsM s (Value s) 214 | makeFunction emacsFun doc = withEnv $ \env -> do 215 | impl' <- liftBase $ Env.exportToEmacs impl 216 | Doc.useDocAsCString doc $ \doc' -> do 217 | func <- Env.makeFunction env minArity maxArity impl' doc' (castFunPtrToPtr (Env.unRawFunction impl')) 218 | Env.setFunctionFinalizer env func Env.freeHaskellFunPtrWrapped 219 | pure $ Value func 220 | where 221 | (minArity, maxArity) = arities (Proxy @req) (Proxy @opt) (Proxy @rest) 222 | 223 | impl :: RawFunctionType 'Unknown () 224 | impl envPtr nargs argsPtr _extraPtr = do 225 | let env = Env.fromPtr envPtr 226 | Exception.handle (reportAnyErrorToEmacs env) $ 227 | Exception.handle (reportEmacsSignalToEmacs env) $ 228 | Exception.handle (reportEmacsThrowToEmacs env) $ 229 | runEmacsM env $ do 230 | res <- coerce (supplyEmacsArgs (fromIntegral nargs) argsPtr (pure . Value) emacsFun) 231 | -- Force since value may contain exceptions. 232 | liftIO $ evaluate res 233 | 234 | {-# INLINE funcall #-} 235 | funcall 236 | :: (WithCallStack, Foldable f) 237 | => Value s 238 | -> f (Value s) 239 | -> EmacsM s (Value s) 240 | funcall func args = EmacsM $ do 241 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 242 | liftBase $ 243 | coerce . handleResult 244 | =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState 245 | =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' -> 246 | Env.funcall eEnv (getRawValue func) (fromIntegral n) args') 247 | 248 | 249 | {-# INLINE funcallPrimitive #-} 250 | funcallPrimitive 251 | :: (WithCallStack, Foldable f) 252 | => Value s 253 | -> f (Value s) 254 | -> EmacsM s (Value s) 255 | funcallPrimitive func args = EmacsM $ do 256 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 257 | liftBase $ 258 | coerce . handleResult 259 | =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState 260 | =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' -> 261 | Env.funcallPrimitive eEnv (getRawValue func) (fromIntegral n) args') 262 | 263 | {-# INLINE funcallPrimitiveUnchecked #-} 264 | funcallPrimitiveUnchecked 265 | :: (WithCallStack, Foldable f) 266 | => Value s 267 | -> f (Value s) 268 | -> EmacsM s (Value s) 269 | funcallPrimitiveUnchecked func args = 270 | withEnvCache $ \env cache -> 271 | withPtrLenNonNull cache (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' -> 272 | coerce $ Env.funcallPrimitive @IO env (getRawValue func) (fromIntegral n) args' 273 | 274 | intern 275 | :: WithCallStack 276 | => SymbolName 277 | -> EmacsM s (Value s) 278 | intern sym = withEnv $ \env -> 279 | coerce $ reifySymbolUnknown env sym 280 | 281 | typeOf 282 | :: WithCallStack 283 | => Value s -> EmacsM s (Value s) 284 | typeOf x = withEnv $ \env -> 285 | coerce $ Env.typeOf @IO env (getRawValue x) 286 | 287 | {-# INLINE isNotNil #-} 288 | isNotNil :: WithCallStack => Value s -> EmacsM s Bool 289 | isNotNil x = withEnv $ \env -> 290 | Env.isTruthy <$> Env.isNotNil env (getRawValue x) 291 | 292 | eq :: Value s -> Value s -> EmacsM s Bool 293 | eq x y = withEnv $ \env -> 294 | Env.isTruthy <$> Env.eq env (getRawValue x) (getRawValue y) 295 | 296 | extractWideInteger :: WithCallStack => Value s -> EmacsM s Int64 297 | extractWideInteger x = EmacsM $ do 298 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 299 | liftBase 300 | $ handleResultNoThrow 301 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractInteger" . fromIntegral 302 | =<< Env.extractInteger eEnv (getRawValue x) 303 | 304 | makeWideInteger :: WithCallStack => Int64 -> EmacsM s (Value s) 305 | makeWideInteger x = withEnv $ \env -> 306 | coerce $ Env.makeInteger @IO env (fromIntegral x) 307 | 308 | extractDouble :: WithCallStack => Value s -> EmacsM s Double 309 | extractDouble x = EmacsM $ do 310 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 311 | liftBase 312 | $ handleResultNoThrow 313 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractFloat" . (\(CDouble y) -> y) 314 | =<< Env.extractFloat eEnv (getRawValue x) 315 | 316 | makeDouble :: WithCallStack => Double -> EmacsM s (Value s) 317 | makeDouble x = withEnv $ \env -> 318 | coerce $ Env.makeFloat @IO env (CDouble x) 319 | 320 | extractText :: WithCallStack => Value s -> EmacsM s Text 321 | extractText x = EmacsM $ do 322 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 323 | liftBase 324 | $ handleResultNoThrow 325 | =<< Common.extractText (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x) 326 | 327 | extractShortByteString :: WithCallStack => Value s -> EmacsM s ShortByteString 328 | extractShortByteString x = EmacsM $ do 329 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 330 | liftBase 331 | $ handleResultNoThrow 332 | =<< Common.extractShortByteString (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x) 333 | 334 | extractByteString :: WithCallStack => Value s -> EmacsM s BS.ByteString 335 | extractByteString x = EmacsM $ do 336 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 337 | liftBase 338 | $ handleResultNoThrow 339 | =<< Common.extractByteString (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x) 340 | 341 | makeString :: WithCallStack => BS.ByteString -> EmacsM s (Value s) 342 | makeString x = withEnv $ \env -> 343 | BSU.unsafeUseAsCStringLen x $ \(pStr, len) -> 344 | coerce $ Env.makeString @IO env pStr (fromIntegral len) 345 | 346 | makeBinaryString :: WithCallStack => BS.ByteString -> EmacsM s (Value s) 347 | makeBinaryString x = withEnv $ \env -> 348 | BSU.unsafeUseAsCStringLen x $ \(pStr, len) -> 349 | coerce $ Env.makeUnibyteString @IO env pStr (fromIntegral len) 350 | 351 | extractUserPtr :: WithCallStack => Value s -> EmacsM s (Ptr a) 352 | extractUserPtr x = EmacsM $ do 353 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 354 | liftBase 355 | $ handleResultNoThrow 356 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtr" 357 | =<< Env.getUserPtr eEnv (getRawValue x) 358 | 359 | makeUserPtr 360 | :: WithCallStack 361 | => FinalizerPtr a 362 | -> Ptr a 363 | -> EmacsM s (Value s) 364 | makeUserPtr fin ptr = withEnv $ \env -> 365 | coerce $ Env.makeUserPtr @IO env fin ptr 366 | 367 | assignUserPtr :: WithCallStack => Value s -> Ptr a -> EmacsM s () 368 | assignUserPtr dest ptr = EmacsM $ do 369 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 370 | -- callWithResultMayFailSignalWaitSideEffect (SetUserPtr (getRawValue dest) ptr) 371 | liftBase $ 372 | handleResultNoThrow 373 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtr" 374 | =<< Env.setUserPtr eEnv (getRawValue dest) ptr 375 | 376 | extractUserPtrFinaliser 377 | :: WithCallStack => Value s -> EmacsM s (FinalizerPtr a) 378 | extractUserPtrFinaliser x = EmacsM $ do 379 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 380 | liftBase $ 381 | handleResultNoThrow 382 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtrFinaliser" 383 | =<< Env.getUserFinaliser eEnv (getRawValue x) 384 | 385 | assignUserPtrFinaliser 386 | :: WithCallStack => Value s -> FinalizerPtr a -> EmacsM s () 387 | assignUserPtrFinaliser x fin = EmacsM $ do 388 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 389 | liftBase $ 390 | handleResultNoThrow 391 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtrFinaliser" 392 | =<< Env.setUserFinaliser eEnv (getRawValue x) fin 393 | 394 | vecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s) 395 | vecGet vec n = EmacsM $ do 396 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 397 | liftBase $ 398 | coerce . handleResultNoThrow 399 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecGet" 400 | =<< Env.vecGet eEnv (getRawValue vec) (fromIntegral n) 401 | 402 | unsafeVecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s) 403 | unsafeVecGet vec n = EmacsM $ do 404 | Environment{eEnv} <- ask 405 | liftBase $ 406 | coerce $ 407 | Env.vecGet @IO eEnv (getRawValue vec) (fromIntegral n) 408 | 409 | vecSet 410 | :: WithCallStack 411 | => Value s -- ^ Vector 412 | -> Int -- ^ Index 413 | -> Value s -- ^ New value 414 | -> EmacsM s () 415 | vecSet vec n x = EmacsM $ do 416 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 417 | liftBase $ 418 | handleResultNoThrow 419 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSet" 420 | =<< Env.vecSet eEnv (getRawValue vec) (fromIntegral n) (getRawValue x) 421 | 422 | vecSize :: WithCallStack => Value s -> EmacsM s Int 423 | vecSize vec = EmacsM $ do 424 | Environment{eEnv, eNonLocalState, eArgsCache} <- ask 425 | liftBase $ 426 | handleResultNoThrow 427 | =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSize" . fromIntegral 428 | =<< Env.vecSize eEnv (getRawValue vec) 429 | 430 | processInput :: WithCallStack => EmacsM s ProcessInput.Result 431 | processInput = 432 | withEnv $ \env -> do 433 | Env.EnumProcessInputResult (CInt x) <- Env.processInput env 434 | case ProcessInput.resultFromNum x of 435 | Nothing -> 436 | throwIO $ mkEmacsInternalError $ 437 | "Unknown value of enum emacs_process_input_result" <+> pretty x 438 | Just y -> pure y 439 | -------------------------------------------------------------------------------- /cbits/emacs-module.h: -------------------------------------------------------------------------------- 1 | /* emacs-module.h - GNU Emacs module API. 2 | 3 | Copyright (C) 2015-2022 Free Software Foundation, Inc. 4 | 5 | This file is part of GNU Emacs. 6 | 7 | GNU Emacs is free software: you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation, either version 3 of the License, or (at 10 | your option) any later version. 11 | 12 | GNU Emacs is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with GNU Emacs. If not, see . */ 19 | 20 | /* 21 | This file defines the Emacs module API. Please see the chapter 22 | `Dynamic Modules' in the GNU Emacs Lisp Reference Manual for 23 | information how to write modules and use this header file. 24 | */ 25 | 26 | #ifndef EMACS_MODULE_H 27 | #define EMACS_MODULE_H 28 | 29 | #include 30 | #include 31 | #include 32 | 33 | #ifndef __cplusplus 34 | #include 35 | #endif 36 | 37 | #define EMACS_MAJOR_VERSION 28 38 | 39 | #if defined __cplusplus && __cplusplus >= 201103L 40 | # define EMACS_NOEXCEPT noexcept 41 | #else 42 | # define EMACS_NOEXCEPT 43 | #endif 44 | 45 | #if defined __cplusplus && __cplusplus >= 201703L 46 | # define EMACS_NOEXCEPT_TYPEDEF noexcept 47 | #else 48 | # define EMACS_NOEXCEPT_TYPEDEF 49 | #endif 50 | 51 | #if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) 52 | # define EMACS_ATTRIBUTE_NONNULL(...) \ 53 | __attribute__ ((__nonnull__ (__VA_ARGS__))) 54 | #elif (defined __has_attribute \ 55 | && (!defined __clang_minor__ \ 56 | || 3 < __clang_major__ + (5 <= __clang_minor__))) 57 | # if __has_attribute (__nonnull__) 58 | # define EMACS_ATTRIBUTE_NONNULL(...) \ 59 | __attribute__ ((__nonnull__ (__VA_ARGS__))) 60 | # endif 61 | #endif 62 | #ifndef EMACS_ATTRIBUTE_NONNULL 63 | # define EMACS_ATTRIBUTE_NONNULL(...) 64 | #endif 65 | 66 | #ifdef __cplusplus 67 | extern "C" { 68 | #endif 69 | 70 | /* Current environment. */ 71 | typedef struct emacs_env_28 emacs_env; 72 | 73 | /* Opaque pointer representing an Emacs Lisp value. 74 | BEWARE: Do not assume NULL is a valid value! */ 75 | typedef struct emacs_value_tag *emacs_value; 76 | 77 | enum { emacs_variadic_function = -2 }; 78 | 79 | /* Struct passed to a module init function (emacs_module_init). */ 80 | struct emacs_runtime 81 | { 82 | /* Structure size (for version checking). */ 83 | ptrdiff_t size; 84 | 85 | /* Private data; users should not touch this. */ 86 | struct emacs_runtime_private *private_members; 87 | 88 | /* Return an environment pointer. */ 89 | emacs_env *(*get_environment) (struct emacs_runtime *runtime) 90 | EMACS_ATTRIBUTE_NONNULL (1); 91 | }; 92 | 93 | /* Type aliases for function pointer types used in the module API. 94 | Note that we don't use these aliases directly in the API to be able 95 | to mark the function arguments as 'noexcept' before C++20. 96 | However, users can use them if they want. */ 97 | 98 | /* Function prototype for the module Lisp functions. These must not 99 | throw C++ exceptions. */ 100 | typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs, 101 | emacs_value *args, 102 | void *data) 103 | EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); 104 | 105 | /* Function prototype for module user-pointer and function finalizers. 106 | These must not throw C++ exceptions. */ 107 | typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF; 108 | 109 | /* Possible Emacs function call outcomes. */ 110 | enum emacs_funcall_exit 111 | { 112 | /* Function has returned normally. */ 113 | emacs_funcall_exit_return = 0, 114 | 115 | /* Function has signaled an error using `signal'. */ 116 | emacs_funcall_exit_signal = 1, 117 | 118 | /* Function has exit using `throw'. */ 119 | emacs_funcall_exit_throw = 2 120 | }; 121 | 122 | /* Possible return values for emacs_env.process_input. */ 123 | enum emacs_process_input_result 124 | { 125 | /* Module code may continue */ 126 | emacs_process_input_continue = 0, 127 | 128 | /* Module code should return control to Emacs as soon as possible. */ 129 | emacs_process_input_quit = 1 130 | }; 131 | 132 | /* Define emacs_limb_t so that it is likely to match GMP's mp_limb_t. 133 | This micro-optimization can help modules that use mpz_export and 134 | mpz_import, which operate more efficiently on mp_limb_t. It's OK 135 | (if perhaps a bit slower) if the two types do not match, and 136 | modules shouldn't rely on the two types matching. */ 137 | typedef size_t emacs_limb_t; 138 | #define EMACS_LIMB_MAX SIZE_MAX 139 | 140 | struct emacs_env_25 141 | { 142 | /* Structure size (for version checking). */ 143 | ptrdiff_t size; 144 | 145 | /* Private data; users should not touch this. */ 146 | struct emacs_env_private *private_members; 147 | 148 | /* Memory management. */ 149 | 150 | emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) 151 | EMACS_ATTRIBUTE_NONNULL(1); 152 | 153 | void (*free_global_ref) (emacs_env *env, emacs_value global_value) 154 | EMACS_ATTRIBUTE_NONNULL(1); 155 | 156 | /* Non-local exit handling. */ 157 | 158 | enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) 159 | EMACS_ATTRIBUTE_NONNULL(1); 160 | 161 | void (*non_local_exit_clear) (emacs_env *env) 162 | EMACS_ATTRIBUTE_NONNULL(1); 163 | 164 | enum emacs_funcall_exit (*non_local_exit_get) 165 | (emacs_env *env, emacs_value *symbol, emacs_value *data) 166 | EMACS_ATTRIBUTE_NONNULL(1, 2, 3); 167 | 168 | void (*non_local_exit_signal) (emacs_env *env, 169 | emacs_value symbol, emacs_value data) 170 | EMACS_ATTRIBUTE_NONNULL(1); 171 | 172 | void (*non_local_exit_throw) (emacs_env *env, 173 | emacs_value tag, emacs_value value) 174 | EMACS_ATTRIBUTE_NONNULL(1); 175 | 176 | /* Function registration. */ 177 | 178 | emacs_value (*make_function) (emacs_env *env, 179 | ptrdiff_t min_arity, 180 | ptrdiff_t max_arity, 181 | emacs_value (*func) (emacs_env *env, 182 | ptrdiff_t nargs, 183 | emacs_value* args, 184 | void *data) 185 | EMACS_NOEXCEPT 186 | EMACS_ATTRIBUTE_NONNULL(1), 187 | const char *docstring, 188 | void *data) 189 | EMACS_ATTRIBUTE_NONNULL(1, 4); 190 | 191 | emacs_value (*funcall) (emacs_env *env, 192 | emacs_value func, 193 | ptrdiff_t nargs, 194 | emacs_value* args) 195 | EMACS_ATTRIBUTE_NONNULL(1); 196 | 197 | emacs_value (*intern) (emacs_env *env, const char *name) 198 | EMACS_ATTRIBUTE_NONNULL(1, 2); 199 | 200 | /* Type conversion. */ 201 | 202 | emacs_value (*type_of) (emacs_env *env, emacs_value arg) 203 | EMACS_ATTRIBUTE_NONNULL(1); 204 | 205 | bool (*is_not_nil) (emacs_env *env, emacs_value arg) 206 | EMACS_ATTRIBUTE_NONNULL(1); 207 | 208 | bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) 209 | EMACS_ATTRIBUTE_NONNULL(1); 210 | 211 | intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) 212 | EMACS_ATTRIBUTE_NONNULL(1); 213 | 214 | emacs_value (*make_integer) (emacs_env *env, intmax_t n) 215 | EMACS_ATTRIBUTE_NONNULL(1); 216 | 217 | double (*extract_float) (emacs_env *env, emacs_value arg) 218 | EMACS_ATTRIBUTE_NONNULL(1); 219 | 220 | emacs_value (*make_float) (emacs_env *env, double d) 221 | EMACS_ATTRIBUTE_NONNULL(1); 222 | 223 | /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 224 | null-terminated string. 225 | 226 | SIZE must point to the total size of the buffer. If BUFFER is 227 | NULL or if SIZE is not big enough, write the required buffer size 228 | to SIZE and return true. 229 | 230 | Note that SIZE must include the last null byte (e.g. "abc" needs 231 | a buffer of size 4). 232 | 233 | Return true if the string was successfully copied. */ 234 | 235 | bool (*copy_string_contents) (emacs_env *env, 236 | emacs_value value, 237 | char *buf, 238 | ptrdiff_t *len) 239 | EMACS_ATTRIBUTE_NONNULL(1, 4); 240 | 241 | /* Create a Lisp string from a utf8 encoded string. */ 242 | emacs_value (*make_string) (emacs_env *env, 243 | const char *str, ptrdiff_t len) 244 | EMACS_ATTRIBUTE_NONNULL(1, 2); 245 | 246 | /* Embedded pointer type. */ 247 | emacs_value (*make_user_ptr) (emacs_env *env, 248 | void (*fin) (void *) EMACS_NOEXCEPT, 249 | void *ptr) 250 | EMACS_ATTRIBUTE_NONNULL(1); 251 | 252 | void *(*get_user_ptr) (emacs_env *env, emacs_value arg) 253 | EMACS_ATTRIBUTE_NONNULL(1); 254 | void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) 255 | EMACS_ATTRIBUTE_NONNULL(1); 256 | 257 | void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) 258 | (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); 259 | void (*set_user_finalizer) (emacs_env *env, emacs_value arg, 260 | void (*fin) (void *) EMACS_NOEXCEPT) 261 | EMACS_ATTRIBUTE_NONNULL(1); 262 | 263 | /* Vector functions. */ 264 | emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) 265 | EMACS_ATTRIBUTE_NONNULL(1); 266 | 267 | void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, 268 | emacs_value value) 269 | EMACS_ATTRIBUTE_NONNULL(1); 270 | 271 | ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) 272 | EMACS_ATTRIBUTE_NONNULL(1); 273 | }; 274 | 275 | struct emacs_env_26 276 | { 277 | /* Structure size (for version checking). */ 278 | ptrdiff_t size; 279 | 280 | /* Private data; users should not touch this. */ 281 | struct emacs_env_private *private_members; 282 | 283 | /* Memory management. */ 284 | 285 | emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) 286 | EMACS_ATTRIBUTE_NONNULL(1); 287 | 288 | void (*free_global_ref) (emacs_env *env, emacs_value global_value) 289 | EMACS_ATTRIBUTE_NONNULL(1); 290 | 291 | /* Non-local exit handling. */ 292 | 293 | enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) 294 | EMACS_ATTRIBUTE_NONNULL(1); 295 | 296 | void (*non_local_exit_clear) (emacs_env *env) 297 | EMACS_ATTRIBUTE_NONNULL(1); 298 | 299 | enum emacs_funcall_exit (*non_local_exit_get) 300 | (emacs_env *env, emacs_value *symbol, emacs_value *data) 301 | EMACS_ATTRIBUTE_NONNULL(1, 2, 3); 302 | 303 | void (*non_local_exit_signal) (emacs_env *env, 304 | emacs_value symbol, emacs_value data) 305 | EMACS_ATTRIBUTE_NONNULL(1); 306 | 307 | void (*non_local_exit_throw) (emacs_env *env, 308 | emacs_value tag, emacs_value value) 309 | EMACS_ATTRIBUTE_NONNULL(1); 310 | 311 | /* Function registration. */ 312 | 313 | emacs_value (*make_function) (emacs_env *env, 314 | ptrdiff_t min_arity, 315 | ptrdiff_t max_arity, 316 | emacs_value (*func) (emacs_env *env, 317 | ptrdiff_t nargs, 318 | emacs_value* args, 319 | void *data) 320 | EMACS_NOEXCEPT 321 | EMACS_ATTRIBUTE_NONNULL(1), 322 | const char *docstring, 323 | void *data) 324 | EMACS_ATTRIBUTE_NONNULL(1, 4); 325 | 326 | emacs_value (*funcall) (emacs_env *env, 327 | emacs_value func, 328 | ptrdiff_t nargs, 329 | emacs_value* args) 330 | EMACS_ATTRIBUTE_NONNULL(1); 331 | 332 | emacs_value (*intern) (emacs_env *env, const char *name) 333 | EMACS_ATTRIBUTE_NONNULL(1, 2); 334 | 335 | /* Type conversion. */ 336 | 337 | emacs_value (*type_of) (emacs_env *env, emacs_value arg) 338 | EMACS_ATTRIBUTE_NONNULL(1); 339 | 340 | bool (*is_not_nil) (emacs_env *env, emacs_value arg) 341 | EMACS_ATTRIBUTE_NONNULL(1); 342 | 343 | bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) 344 | EMACS_ATTRIBUTE_NONNULL(1); 345 | 346 | intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) 347 | EMACS_ATTRIBUTE_NONNULL(1); 348 | 349 | emacs_value (*make_integer) (emacs_env *env, intmax_t n) 350 | EMACS_ATTRIBUTE_NONNULL(1); 351 | 352 | double (*extract_float) (emacs_env *env, emacs_value arg) 353 | EMACS_ATTRIBUTE_NONNULL(1); 354 | 355 | emacs_value (*make_float) (emacs_env *env, double d) 356 | EMACS_ATTRIBUTE_NONNULL(1); 357 | 358 | /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 359 | null-terminated string. 360 | 361 | SIZE must point to the total size of the buffer. If BUFFER is 362 | NULL or if SIZE is not big enough, write the required buffer size 363 | to SIZE and return true. 364 | 365 | Note that SIZE must include the last null byte (e.g. "abc" needs 366 | a buffer of size 4). 367 | 368 | Return true if the string was successfully copied. */ 369 | 370 | bool (*copy_string_contents) (emacs_env *env, 371 | emacs_value value, 372 | char *buf, 373 | ptrdiff_t *len) 374 | EMACS_ATTRIBUTE_NONNULL(1, 4); 375 | 376 | /* Create a Lisp string from a utf8 encoded string. */ 377 | emacs_value (*make_string) (emacs_env *env, 378 | const char *str, ptrdiff_t len) 379 | EMACS_ATTRIBUTE_NONNULL(1, 2); 380 | 381 | /* Embedded pointer type. */ 382 | emacs_value (*make_user_ptr) (emacs_env *env, 383 | void (*fin) (void *) EMACS_NOEXCEPT, 384 | void *ptr) 385 | EMACS_ATTRIBUTE_NONNULL(1); 386 | 387 | void *(*get_user_ptr) (emacs_env *env, emacs_value arg) 388 | EMACS_ATTRIBUTE_NONNULL(1); 389 | void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) 390 | EMACS_ATTRIBUTE_NONNULL(1); 391 | 392 | void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) 393 | (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); 394 | void (*set_user_finalizer) (emacs_env *env, emacs_value arg, 395 | void (*fin) (void *) EMACS_NOEXCEPT) 396 | EMACS_ATTRIBUTE_NONNULL(1); 397 | 398 | /* Vector functions. */ 399 | emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) 400 | EMACS_ATTRIBUTE_NONNULL(1); 401 | 402 | void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, 403 | emacs_value value) 404 | EMACS_ATTRIBUTE_NONNULL(1); 405 | 406 | ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) 407 | EMACS_ATTRIBUTE_NONNULL(1); 408 | 409 | /* Returns whether a quit is pending. */ 410 | bool (*should_quit) (emacs_env *env) 411 | EMACS_ATTRIBUTE_NONNULL(1); 412 | }; 413 | 414 | struct emacs_env_27 415 | { 416 | /* Structure size (for version checking). */ 417 | ptrdiff_t size; 418 | 419 | /* Private data; users should not touch this. */ 420 | struct emacs_env_private *private_members; 421 | 422 | /* Memory management. */ 423 | 424 | emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) 425 | EMACS_ATTRIBUTE_NONNULL(1); 426 | 427 | void (*free_global_ref) (emacs_env *env, emacs_value global_value) 428 | EMACS_ATTRIBUTE_NONNULL(1); 429 | 430 | /* Non-local exit handling. */ 431 | 432 | enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) 433 | EMACS_ATTRIBUTE_NONNULL(1); 434 | 435 | void (*non_local_exit_clear) (emacs_env *env) 436 | EMACS_ATTRIBUTE_NONNULL(1); 437 | 438 | enum emacs_funcall_exit (*non_local_exit_get) 439 | (emacs_env *env, emacs_value *symbol, emacs_value *data) 440 | EMACS_ATTRIBUTE_NONNULL(1, 2, 3); 441 | 442 | void (*non_local_exit_signal) (emacs_env *env, 443 | emacs_value symbol, emacs_value data) 444 | EMACS_ATTRIBUTE_NONNULL(1); 445 | 446 | void (*non_local_exit_throw) (emacs_env *env, 447 | emacs_value tag, emacs_value value) 448 | EMACS_ATTRIBUTE_NONNULL(1); 449 | 450 | /* Function registration. */ 451 | 452 | emacs_value (*make_function) (emacs_env *env, 453 | ptrdiff_t min_arity, 454 | ptrdiff_t max_arity, 455 | emacs_value (*func) (emacs_env *env, 456 | ptrdiff_t nargs, 457 | emacs_value* args, 458 | void *data) 459 | EMACS_NOEXCEPT 460 | EMACS_ATTRIBUTE_NONNULL(1), 461 | const char *docstring, 462 | void *data) 463 | EMACS_ATTRIBUTE_NONNULL(1, 4); 464 | 465 | emacs_value (*funcall) (emacs_env *env, 466 | emacs_value func, 467 | ptrdiff_t nargs, 468 | emacs_value* args) 469 | EMACS_ATTRIBUTE_NONNULL(1); 470 | 471 | emacs_value (*intern) (emacs_env *env, const char *name) 472 | EMACS_ATTRIBUTE_NONNULL(1, 2); 473 | 474 | /* Type conversion. */ 475 | 476 | emacs_value (*type_of) (emacs_env *env, emacs_value arg) 477 | EMACS_ATTRIBUTE_NONNULL(1); 478 | 479 | bool (*is_not_nil) (emacs_env *env, emacs_value arg) 480 | EMACS_ATTRIBUTE_NONNULL(1); 481 | 482 | bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) 483 | EMACS_ATTRIBUTE_NONNULL(1); 484 | 485 | intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) 486 | EMACS_ATTRIBUTE_NONNULL(1); 487 | 488 | emacs_value (*make_integer) (emacs_env *env, intmax_t n) 489 | EMACS_ATTRIBUTE_NONNULL(1); 490 | 491 | double (*extract_float) (emacs_env *env, emacs_value arg) 492 | EMACS_ATTRIBUTE_NONNULL(1); 493 | 494 | emacs_value (*make_float) (emacs_env *env, double d) 495 | EMACS_ATTRIBUTE_NONNULL(1); 496 | 497 | /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 498 | null-terminated string. 499 | 500 | SIZE must point to the total size of the buffer. If BUFFER is 501 | NULL or if SIZE is not big enough, write the required buffer size 502 | to SIZE and return true. 503 | 504 | Note that SIZE must include the last null byte (e.g. "abc" needs 505 | a buffer of size 4). 506 | 507 | Return true if the string was successfully copied. */ 508 | 509 | bool (*copy_string_contents) (emacs_env *env, 510 | emacs_value value, 511 | char *buf, 512 | ptrdiff_t *len) 513 | EMACS_ATTRIBUTE_NONNULL(1, 4); 514 | 515 | /* Create a Lisp string from a utf8 encoded string. */ 516 | emacs_value (*make_string) (emacs_env *env, 517 | const char *str, ptrdiff_t len) 518 | EMACS_ATTRIBUTE_NONNULL(1, 2); 519 | 520 | /* Embedded pointer type. */ 521 | emacs_value (*make_user_ptr) (emacs_env *env, 522 | void (*fin) (void *) EMACS_NOEXCEPT, 523 | void *ptr) 524 | EMACS_ATTRIBUTE_NONNULL(1); 525 | 526 | void *(*get_user_ptr) (emacs_env *env, emacs_value arg) 527 | EMACS_ATTRIBUTE_NONNULL(1); 528 | void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) 529 | EMACS_ATTRIBUTE_NONNULL(1); 530 | 531 | void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) 532 | (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); 533 | void (*set_user_finalizer) (emacs_env *env, emacs_value arg, 534 | void (*fin) (void *) EMACS_NOEXCEPT) 535 | EMACS_ATTRIBUTE_NONNULL(1); 536 | 537 | /* Vector functions. */ 538 | emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) 539 | EMACS_ATTRIBUTE_NONNULL(1); 540 | 541 | void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, 542 | emacs_value value) 543 | EMACS_ATTRIBUTE_NONNULL(1); 544 | 545 | ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) 546 | EMACS_ATTRIBUTE_NONNULL(1); 547 | 548 | /* Returns whether a quit is pending. */ 549 | bool (*should_quit) (emacs_env *env) 550 | EMACS_ATTRIBUTE_NONNULL(1); 551 | 552 | /* Processes pending input events and returns whether the module 553 | function should quit. */ 554 | enum emacs_process_input_result (*process_input) (emacs_env *env) 555 | EMACS_ATTRIBUTE_NONNULL (1); 556 | 557 | struct timespec (*extract_time) (emacs_env *env, emacs_value arg) 558 | EMACS_ATTRIBUTE_NONNULL (1); 559 | 560 | emacs_value (*make_time) (emacs_env *env, struct timespec time) 561 | EMACS_ATTRIBUTE_NONNULL (1); 562 | 563 | bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign, 564 | ptrdiff_t *count, emacs_limb_t *magnitude) 565 | EMACS_ATTRIBUTE_NONNULL (1); 566 | 567 | emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count, 568 | const emacs_limb_t *magnitude) 569 | EMACS_ATTRIBUTE_NONNULL (1); 570 | }; 571 | 572 | struct emacs_env_28 573 | { 574 | /* Structure size (for version checking). */ 575 | ptrdiff_t size; 576 | 577 | /* Private data; users should not touch this. */ 578 | struct emacs_env_private *private_members; 579 | 580 | /* Memory management. */ 581 | 582 | emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) 583 | EMACS_ATTRIBUTE_NONNULL(1); 584 | 585 | void (*free_global_ref) (emacs_env *env, emacs_value global_value) 586 | EMACS_ATTRIBUTE_NONNULL(1); 587 | 588 | /* Non-local exit handling. */ 589 | 590 | enum emacs_funcall_exit (*non_local_exit_check) (emacs_env *env) 591 | EMACS_ATTRIBUTE_NONNULL(1); 592 | 593 | void (*non_local_exit_clear) (emacs_env *env) 594 | EMACS_ATTRIBUTE_NONNULL(1); 595 | 596 | enum emacs_funcall_exit (*non_local_exit_get) 597 | (emacs_env *env, emacs_value *symbol, emacs_value *data) 598 | EMACS_ATTRIBUTE_NONNULL(1, 2, 3); 599 | 600 | void (*non_local_exit_signal) (emacs_env *env, 601 | emacs_value symbol, emacs_value data) 602 | EMACS_ATTRIBUTE_NONNULL(1); 603 | 604 | void (*non_local_exit_throw) (emacs_env *env, 605 | emacs_value tag, emacs_value value) 606 | EMACS_ATTRIBUTE_NONNULL(1); 607 | 608 | /* Function registration. */ 609 | 610 | emacs_value (*make_function) (emacs_env *env, 611 | ptrdiff_t min_arity, 612 | ptrdiff_t max_arity, 613 | emacs_value (*func) (emacs_env *env, 614 | ptrdiff_t nargs, 615 | emacs_value* args, 616 | void *data) 617 | EMACS_NOEXCEPT 618 | EMACS_ATTRIBUTE_NONNULL(1), 619 | const char *docstring, 620 | void *data) 621 | EMACS_ATTRIBUTE_NONNULL(1, 4); 622 | 623 | emacs_value (*funcall) (emacs_env *env, 624 | emacs_value func, 625 | ptrdiff_t nargs, 626 | emacs_value* args) 627 | EMACS_ATTRIBUTE_NONNULL(1); 628 | 629 | emacs_value (*intern) (emacs_env *env, const char *name) 630 | EMACS_ATTRIBUTE_NONNULL(1, 2); 631 | 632 | /* Type conversion. */ 633 | 634 | emacs_value (*type_of) (emacs_env *env, emacs_value arg) 635 | EMACS_ATTRIBUTE_NONNULL(1); 636 | 637 | bool (*is_not_nil) (emacs_env *env, emacs_value arg) 638 | EMACS_ATTRIBUTE_NONNULL(1); 639 | 640 | bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) 641 | EMACS_ATTRIBUTE_NONNULL(1); 642 | 643 | intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) 644 | EMACS_ATTRIBUTE_NONNULL(1); 645 | 646 | emacs_value (*make_integer) (emacs_env *env, intmax_t n) 647 | EMACS_ATTRIBUTE_NONNULL(1); 648 | 649 | double (*extract_float) (emacs_env *env, emacs_value arg) 650 | EMACS_ATTRIBUTE_NONNULL(1); 651 | 652 | emacs_value (*make_float) (emacs_env *env, double d) 653 | EMACS_ATTRIBUTE_NONNULL(1); 654 | 655 | /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 656 | null-terminated string. 657 | 658 | SIZE must point to the total size of the buffer. If BUFFER is 659 | NULL or if SIZE is not big enough, write the required buffer size 660 | to SIZE and return true. 661 | 662 | Note that SIZE must include the last null byte (e.g. "abc" needs 663 | a buffer of size 4). 664 | 665 | Return true if the string was successfully copied. */ 666 | 667 | bool (*copy_string_contents) (emacs_env *env, 668 | emacs_value value, 669 | char *buf, 670 | ptrdiff_t *len) 671 | EMACS_ATTRIBUTE_NONNULL(1, 4); 672 | 673 | /* Create a Lisp string from a utf8 encoded string. */ 674 | emacs_value (*make_string) (emacs_env *env, 675 | const char *str, ptrdiff_t len) 676 | EMACS_ATTRIBUTE_NONNULL(1, 2); 677 | 678 | /* Embedded pointer type. */ 679 | emacs_value (*make_user_ptr) (emacs_env *env, 680 | void (*fin) (void *) EMACS_NOEXCEPT, 681 | void *ptr) 682 | EMACS_ATTRIBUTE_NONNULL(1); 683 | 684 | void *(*get_user_ptr) (emacs_env *env, emacs_value arg) 685 | EMACS_ATTRIBUTE_NONNULL(1); 686 | void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) 687 | EMACS_ATTRIBUTE_NONNULL(1); 688 | 689 | void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) 690 | (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); 691 | void (*set_user_finalizer) (emacs_env *env, emacs_value arg, 692 | void (*fin) (void *) EMACS_NOEXCEPT) 693 | EMACS_ATTRIBUTE_NONNULL(1); 694 | 695 | /* Vector functions. */ 696 | emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) 697 | EMACS_ATTRIBUTE_NONNULL(1); 698 | 699 | void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, 700 | emacs_value value) 701 | EMACS_ATTRIBUTE_NONNULL(1); 702 | 703 | ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) 704 | EMACS_ATTRIBUTE_NONNULL(1); 705 | 706 | /* Returns whether a quit is pending. */ 707 | bool (*should_quit) (emacs_env *env) 708 | EMACS_ATTRIBUTE_NONNULL(1); 709 | 710 | /* Processes pending input events and returns whether the module 711 | function should quit. */ 712 | enum emacs_process_input_result (*process_input) (emacs_env *env) 713 | EMACS_ATTRIBUTE_NONNULL (1); 714 | 715 | struct timespec (*extract_time) (emacs_env *env, emacs_value arg) 716 | EMACS_ATTRIBUTE_NONNULL (1); 717 | 718 | emacs_value (*make_time) (emacs_env *env, struct timespec time) 719 | EMACS_ATTRIBUTE_NONNULL (1); 720 | 721 | bool (*extract_big_integer) (emacs_env *env, emacs_value arg, int *sign, 722 | ptrdiff_t *count, emacs_limb_t *magnitude) 723 | EMACS_ATTRIBUTE_NONNULL (1); 724 | 725 | emacs_value (*make_big_integer) (emacs_env *env, int sign, ptrdiff_t count, 726 | const emacs_limb_t *magnitude) 727 | EMACS_ATTRIBUTE_NONNULL (1); 728 | 729 | void (*(*EMACS_ATTRIBUTE_NONNULL (1) 730 | get_function_finalizer) (emacs_env *env, 731 | emacs_value arg)) (void *) EMACS_NOEXCEPT; 732 | 733 | void (*set_function_finalizer) (emacs_env *env, emacs_value arg, 734 | void (*fin) (void *) EMACS_NOEXCEPT) 735 | EMACS_ATTRIBUTE_NONNULL (1); 736 | 737 | int (*open_channel) (emacs_env *env, emacs_value pipe_process) 738 | EMACS_ATTRIBUTE_NONNULL (1); 739 | 740 | void (*make_interactive) (emacs_env *env, emacs_value function, 741 | emacs_value spec) 742 | EMACS_ATTRIBUTE_NONNULL (1); 743 | 744 | /* Create a unibyte Lisp string from a string. */ 745 | emacs_value (*make_unibyte_string) (emacs_env *env, 746 | const char *str, ptrdiff_t len) 747 | EMACS_ATTRIBUTE_NONNULL(1, 2); 748 | }; 749 | 750 | /* Every module should define a function as follows. */ 751 | extern int emacs_module_init (struct emacs_runtime *runtime) 752 | EMACS_NOEXCEPT 753 | EMACS_ATTRIBUTE_NONNULL (1); 754 | 755 | #ifdef __cplusplus 756 | } 757 | #endif 758 | 759 | #endif /* EMACS_MODULE_H */ 760 | --------------------------------------------------------------------------------