emacs-module 0.3 → 0.4

raw patch · 15 files changed

+213/−97 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +7/−0
• emacs-module.cabal +4/−2
• src/Data/Emacs/Module/Raw/Env/TH.hs +4/−2
• src/Data/Emacs/Module/Raw/Value/Internal.hs +1/−1
• src/Data/Emacs/Module/SymbolName/Internal.hs +13/−16
• src/Data/Emacs/Module/SymbolName/Internal.hs-boot +6/−1
• src/Data/Emacs/Module/SymbolName/Internal/Type.hs +26/−0
• src/Data/Emacs/Module/SymbolName/Predefined.hs +99/−19
• src/Data/Emacs/Module/SymbolName/Predefined/Funcall.hs +0/−32
• src/Data/Emacs/Module/SymbolName/Predefined/Intern.hs +33/−0
• src/Data/Emacs/Module/SymbolName/TH.hs +8/−7
• src/Emacs/Module.hs +8/−7
• src/Emacs/Module/Errors.hs +4/−5
• src/Emacs/Module/Monad.hs +0/−1
• src/Emacs/Module/Monad/Class.hs +0/−4

@@ -1,3 +1,10 @@+# 0.4++- Breaking change: `Data.Emacs.Module.SymbolName.TH.cacheSym` second+  argument changed its type `Maybe String` -> `Maybe`, semantics stayed the same++- Fix interning of non-ASCII symbols+ # 0.3  - Add `extractByteString` function to the `EmacsMonad` class

@@ -3,7 +3,7 @@ name:   emacs-module version:-  0.3+  0.4 category: Foreign, Foreign binding  synopsis:@@ -35,6 +35,7 @@   , GHC == 9.8   , GHC == 9.10   , GHC == 9.12+  , GHC == 9.14  extra-source-files:   cbits/emacs-module.h@@ -119,7 +120,7 @@     Data.Emacs.Module.Runtime     Data.Emacs.Module.SymbolName     Data.Emacs.Module.SymbolName.Predefined-    Data.Emacs.Module.SymbolName.Predefined.Funcall+    Data.Emacs.Module.SymbolName.Predefined.Intern     Data.Emacs.Module.SymbolName.TH     Data.Emacs.Module.Value     Emacs.Module@@ -136,6 +137,7 @@     Data.Emacs.Module.Raw.Value     Data.Emacs.Module.Raw.Value.Internal     Data.Emacs.Module.SymbolName.Internal+    Data.Emacs.Module.SymbolName.Internal.Type     Data.Emacs.Module.Value.Internal     Emacs.Module.Monad.Common     Foreign.Ptr.Builder

@@ -30,7 +30,8 @@  #if MIN_VERSION_template_haskell(2, 17, 0) unwrapForall :: Type -> (Maybe ([TyVarBndr Specificity], Cxt), Type)-#else+#endif+#if !MIN_VERSION_template_haskell(2, 17, 0) unwrapForall :: Type -> (Maybe ([TyVarBndr], Cxt), Type) #endif unwrapForall (ForallT bs c t) = (Just (bs, c), t)@@ -38,7 +39,8 @@  #if MIN_VERSION_template_haskell(2, 17, 0) wrapForall :: Maybe ([TyVarBndr Specificity], Cxt) -> Type -> Type-#else+#endif+#if !MIN_VERSION_template_haskell(2, 17, 0) wrapForall :: Maybe ([TyVarBndr], Cxt) -> Type -> Type #endif wrapForall Nothing        = id

@@ -34,7 +34,7 @@ import Prettyprinter (Pretty(..))  data Pinning-  -- | Tag for global values are independent of environment ('Env') that produced it.+  -- | Tag for global values that are independent of environment ('Env') that produced it.   --   -- Can be used to e.g. cache values that are expensive to compute from scratch.   = Pinned

@@ -13,6 +13,8 @@  {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -Wno-orphans #-}+ module Data.Emacs.Module.SymbolName.Internal   ( Static(..)   , Dynamic(..)@@ -53,7 +55,8 @@ import Data.Emacs.Module.Raw.Value import Emacs.Module.Assert -import Data.Emacs.Module.SymbolName.Predefined.Funcall+import Data.Emacs.Module.SymbolName.Internal.Type+import Data.Emacs.Module.SymbolName.Predefined.Intern qualified as Sym  -- | Symbols that are known at compile time. --@@ -65,12 +68,6 @@ newtype Dynamic = Dynamic { unDynamic :: Text }   deriving (Eq, Ord, Show, Pretty) -data SymbolName-  = StaticSymbol  {-# UNPACK #-} !(Ptr CChar)-  | DynamicSymbol {-# UNPACK #-} !Text-  | CachedSymbol  (IORef (Env -> IO (RawValue 'Pinned))) SymbolName-  deriving (Eq)- instance Show SymbolName where   show = \case     StaticSymbol (Ptr addr)@@ -90,7 +87,7 @@   where     go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))     go !name =-      unsafeFixIO $ \ ref ->+      unsafeFixIO $ \ref ->         newIORef $ \env -> do           !global <- Raw.makeGlobalRef env =<< reifySymbolRaw env name           writeIORef ref $ \_env -> pure global@@ -157,15 +154,15 @@     -- If it's only ASCII then can run FFI intern, otherwise have to go via funcall     -- TODO: cache this check     | T.all (\c -> ord c < 128) str ->-      f <$> T.withCString str (Raw.intern env)+        f <$> T.withCString str (Raw.intern env)     | otherwise                    ->-      T.withCStringLen str $ \(ptr, len) -> do-        str' <- emacsAssert (len >= 0) "Symbol text length must be non-negative" $-          Raw.makeString env ptr (fromIntegral len)-        funcall' <- reifySymbolUnknown env funcall-        allocaNonNull $ \args -> do-          poke (unNonNullPtr args) str'-          f <$> Raw.funcallPrimitive env funcall' 1 args+        T.withCStringLen str $ \(ptr, len) -> do+          str' <- emacsAssert (len >= 0) "Symbol text length must be non-negative" $+            Raw.makeString env ptr (fromIntegral len)+          intern' <- reifySymbolUnknown env Sym.intern+          allocaNonNull $ \args -> do+            poke (unNonNullPtr args) str'+            f <$> Raw.funcallPrimitive env intern' 1 args    CachedSymbol ref _ ->     g <$> ((\k -> k env) =<< readIORef ref)

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

@@ -0,0 +1,26 @@+-- |+-- Module:     Data.Emacs.Module.SymbolName.Internal.Type+-- Copyright:  (c) Sergey Vinokurov 2026+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com++{-# LANGUAGE DataKinds #-}++{-# OPTIONS_HADDOCK not-home #-}++module Data.Emacs.Module.SymbolName.Internal.Type (SymbolName(..)) where++import Data.IORef+import Data.Text (Text)+import Foreign.C.Types+import GHC.Ptr++import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value++data SymbolName+  = StaticSymbol  {-# UNPACK #-} !(Ptr CChar)+  | DynamicSymbol {-# UNPACK #-} !Text+  | CachedSymbol  (IORef (Env -> IO (RawValue 'Pinned))) SymbolName+  deriving (Eq)+

@@ -33,29 +33,109 @@   , symbolName   , prin1ToString   , funcall+  , intern   ) where  import Prelude hiding (error, concat)  import Data.Emacs.Module.SymbolName.TH -import Data.Emacs.Module.SymbolName.Predefined.Funcall+import Data.Emacs.Module.SymbolName.Internal.Type (SymbolName)+import Data.Emacs.Module.SymbolName.Predefined.Intern -cacheSym "error"           Nothing-cacheSym "list"            Nothing-cacheSym "cons"            Nothing-cacheSym "car"             Nothing-cacheSym "cdr"             Nothing-cacheSym "setcar"          Nothing-cacheSym "setcdr"          Nothing-cacheSym "nil"             Nothing-cacheSym "fset"            Nothing-cacheSym "provide"         Nothing-cacheSym "t"               Nothing-cacheSym "vector"          Nothing-cacheSym "vconcat"         Nothing-cacheSym "face"            Nothing-cacheSym "propertize"      Nothing-cacheSym "concat"          Nothing-cacheSym "symbol-name"     (Just "symbolName")-cacheSym "prin1-to-string" (Just "prin1ToString")+cacheSym "error"           "errorTH"+cacheSym "list"            "listTH"+cacheSym "cons"            "consTH"+cacheSym "car"             "carTH"+cacheSym "cdr"             "cdrTH"+cacheSym "setcar"          "setcarTH"+cacheSym "setcdr"          "setcdrTH"+cacheSym "nil"             "nilTH"+cacheSym "fset"            "fsetTH"+cacheSym "provide"         "provideTH"+cacheSym "t"               "tTH"+cacheSym "vector"          "vectorTH"+cacheSym "vconcat"         "vconcatTH"+cacheSym "face"            "faceTH"+cacheSym "propertize"      "propertizeTH"+cacheSym "concat"          "concatTH"+cacheSym "symbol-name"     "symbolNameTH"+cacheSym "prin1-to-string" "prin1ToStringTH"+cacheSym "funcall"         "funcallTH"++{-# INLINE error #-}+error :: SymbolName+error = errorTH++{-# INLINE list #-}+list :: SymbolName+list = listTH++{-# INLINE cons #-}+cons :: SymbolName+cons = consTH++{-# INLINE car #-}+car :: SymbolName+car = carTH++{-# INLINE cdr #-}+cdr :: SymbolName+cdr = cdrTH++{-# INLINE setcar #-}+setcar :: SymbolName+setcar = setcarTH++{-# INLINE setcdr #-}+setcdr :: SymbolName+setcdr = setcdrTH++{-# INLINE nil #-}+nil :: SymbolName+nil = nilTH++{-# INLINE fset #-}+fset :: SymbolName+fset = fsetTH++{-# INLINE provide #-}+provide :: SymbolName+provide = provideTH++{-# INLINE t #-}+t :: SymbolName+t = tTH++{-# INLINE vector #-}+vector :: SymbolName+vector = vectorTH++{-# INLINE vconcat #-}+vconcat :: SymbolName+vconcat = vconcatTH++{-# INLINE face #-}+face :: SymbolName+face = faceTH++{-# INLINE propertize #-}+propertize :: SymbolName+propertize = propertizeTH++{-# INLINE concat #-}+concat :: SymbolName+concat = concatTH++{-# INLINE symbolName #-}+symbolName :: SymbolName+symbolName = symbolNameTH++{-# INLINE prin1ToString #-}+prin1ToString :: SymbolName+prin1ToString = prin1ToStringTH++{-# INLINE funcall #-}+funcall :: SymbolName+funcall = funcallTH+

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

@@ -0,0 +1,33 @@+----------------------------------------------------------------------------+-- |+-- Module      :  Data.Emacs.Module.SymbolName.Predefined.Intern+-- Copyright   :  (c) Sergey Vinokurov 2026+-- License     :  Apache-2.0 (see LICENSE)+-- Maintainer  :  serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}++module Data.Emacs.Module.SymbolName.Predefined.Intern+  ( intern+  ) where++import Data.IORef+import System.IO.Unsafe++import Data.Emacs.Module.Raw.Env.Internal+import Data.Emacs.Module.Raw.Value++import {-# SOURCE #-} Data.Emacs.Module.SymbolName.Internal++internSym :: SymbolName+internSym = mkSymbolNameUnsafe "intern"#++{-# NOINLINE internCache #-}+internCache :: IORef (Env -> IO (RawValue 'Pinned))+internCache = unsafePerformIO $ mkSymbolNameCache internSym++intern :: SymbolName+intern = mkCachedSymbolName internCache internSym+

@@ -14,8 +14,10 @@   ( cacheSym   ) where +import Data.ByteString qualified as BS import Data.IORef-import Data.Maybe+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Language.Haskell.TH import System.IO.Unsafe @@ -23,16 +25,15 @@ import Data.Emacs.Module.Raw.Value import Data.Emacs.Module.SymbolName.Internal qualified as Sym -cacheSym :: String -> Maybe String -> Q [Dec]+cacheSym :: String -> String -> Q [Dec] cacheSym sym bindingName = do-  ref      <- newName ("ref_" ++ binding)+  ref      <- newName ("ref_" ++ bindingName)   noinline <- pragInlD ref NoInline FunLike AllPhases   refSig   <- sigD ref [t| IORef (Env -> IO (RawValue 'Pinned)) |]   refDecl  <- valD (varP ref) (normalB [e| unsafePerformIO (Sym.mkSymbolNameCache $sym') |]) []-  symSig   <- sigD (mkName binding) [t| Sym.SymbolName |]-  symDecl  <- valD (varP (mkName binding)) (normalB [e| Sym.CachedSymbol $(varE ref) $sym' |]) []+  symSig   <- sigD (mkName bindingName) [t| Sym.SymbolName |]+  symDecl  <- valD (varP (mkName bindingName)) (normalB [e| Sym.CachedSymbol $(varE ref) $sym' |]) []   pure [noinline, refSig, refDecl, symSig, symDecl]   where     sym' :: ExpQ-    sym' = [e| Sym.mkSymbolNameString $(litE (stringL sym)) |]-    binding = fromMaybe sym bindingName+    sym' = [e| Sym.mkSymbolNameUnsafe $(litE (StringPrimL (BS.unpack (T.encodeUtf8 (T.pack sym))))) |]

@@ -35,14 +35,15 @@ -- >   :: MonadEmacs m v -- >   => EmacsFunction ('S ('S ('S ('S 'Z)))) ('S ('S 'Z)) 'True m v s -- > foo (R f (R x (R y (R z (O w (O t (Rest quux))))))) = do--- >   x'    <- extractInt x--- >   y'    <- extractInt y--- >   z'    <- extractInt z--- >   w'    <- traverse extractInt w--- >   t'    <- traverse extractInt t+-- >   x'         <- extractInt x+-- >   y'         <- extractInt y+-- >   z'         <- extractInt z+-- >   w'         <- traverse extractInt w+-- >   t'         <- traverse extractInt t -- >--- >   tmp   <- makeInt (x' * y' * z')--- >   tmp'  <- extractInt =<< funcallSym "funcall" [f, tmp]+-- >   tmp        <- makeInt (x' * y' * z')+-- >   funcallSym <- intern "funcall"+-- >   tmp'       <- extractInt =<< funcall funcallSym [f, tmp] -- > -- >   produceRef =<< makeInt (tmp' + fromMaybe 1 w' * fromMaybe 2 t' + length quux) --

@@ -47,7 +47,6 @@ import Prettyprinter.Render.Text as PP  import Data.Emacs.Module.Env qualified as Raw-import Data.Emacs.Module.GetRawValue import Data.Emacs.Module.NonNullPtr import Data.Emacs.Module.Raw.Env.Internal (Env) import Data.Emacs.Module.Raw.Value@@ -238,10 +237,10 @@   -> IO a -- ^ Result to return on error.   -> IO a   -> IO a-reportAllErrorsToEmacs env resultOnErr x+reportAllErrorsToEmacs env resultOnErr   = Exception.handle (\e -> report formatSomeException env e *> resultOnErr)-  $ Exception.handle (\et -> reportEmacsThrowToEmacs' env et *> resultOnErr)-  $ Exception.handle (\et -> reportEmacsSignalToEmacs' env et *> resultOnErr) x+  . Exception.handle (\et -> reportEmacsThrowToEmacs' env et *> resultOnErr)+  . Exception.handle (\et -> reportEmacsSignalToEmacs' env et *> resultOnErr)  report :: (e -> Text) -> Env -> e -> IO () report format env err = do@@ -251,7 +250,7 @@     str' <- Raw.makeString env str (fromIntegral len)     alloca $ \argsPtr -> do       poke argsPtr str'-      errData <- Raw.funcallPrimitive env (getRawValue listSym) 1 (mkNonNullPtr argsPtr)+      errData <- Raw.funcallPrimitive env listSym 1 (mkNonNullPtr argsPtr)       -- The 'nonLocalExitSignal' function does not overwrite pending       -- signals, so it's ok to use it here without checking whether an       -- error is already going on.

@@ -245,7 +245,6 @@       =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->              Env.funcall eEnv (getRawValue func) (fromIntegral n) args') -   {-# INLINE funcallPrimitive #-}   funcallPrimitive     :: (WithCallStack, Foldable f)

@@ -50,10 +50,6 @@   , forall s. PrimMonad (m s)   ) => MonadEmacs (m :: k -> Type -> Type) (v :: k -> Type) | m -> v where -  -- -- | Emacs value that is managed by the 'm' monad. Will be cleaned up-  -- -- after 'm' finishes its execution.-  -- type EmacsRef m :: k -> Type-   -- | Make a global reference to a value so that it will persist   -- across different calls from Emacs into exposed functions.   makeGlobalRef :: WithCallStack => v s -> m s (RawValue 'Pinned)