haskelisp 0.1.0.0 → 0.1.0.1
raw patch · 8 files changed
+248/−202 lines, 8 filesdep −clockdep −formattingdep −turtledep ~containersdep ~logging-effectdep ~mtl
Dependencies removed: clock, formatting, turtle
Dependency ranges changed: containers, logging-effect, mtl, protolude, text
Files
- cbits/stab.c +8/−0
- haskelisp.cabal +39/−62
- src/Emacs.hs +8/−1
- src/Emacs/Command.hs +9/−9
- src/Emacs/Core.hs +79/−40
- src/Emacs/Function.hs +4/−62
- src/Emacs/Internal.hs +57/−28
- src/Emacs/Symbol.hs +44/−0
cbits/stab.c view
@@ -85,6 +85,14 @@ /* emacs_value (*make_float) (emacs_env *env, double value); */ +int _copy_string_contents(emacs_env *env,+ emacs_value value,+ char *buffer,+ ptrdiff_t *size_inout) {+ return env->copy_string_contents(env,value,buffer,size_inout) == true ? 1 : 0;+}++ emacs_value _make_string(emacs_env *env, const char *contents, ptrdiff_t length) {
haskelisp.cabal view
@@ -1,65 +1,42 @@-name: haskelisp-version: 0.1.0.0-synopsis: Initial project template from stack-description: Please see README.md-homepage: http://github.com/githubuser/haskelisp#readme-license: GPL-3-license-file: LICENSE-author: Takenari Shinohara-maintainer: takenari.shinohara@gmail.com-copyright: 2016 Takenari Shinohara-category: Editor-build-type: Simple--- extra-source-files:-cabal-version: >=1.10--library- hs-source-dirs: src- exposed-modules: Emacs- , Emacs.Type- , Emacs.Internal- , Emacs.Core- , Emacs.Variable- , Emacs.Function- , Emacs.Command- build-depends: base >= 4.7 && < 5- , protolude- , turtle- , containers- , mtl- , text- , logging-effect- , clock- , formatting- default-language: Haskell2010- include-dirs: cbits- c-sources: cbits/stab.c+name: haskelisp+version: 0.1.0.1+cabal-version: >=1.10+build-type: Simple+license: GPL-3+license-file: LICENSE+copyright: 2016 Takenari Shinohara+maintainer: takenari.shinohara@gmail.com+homepage: http://github.com/githubuser/haskelisp#readme+synopsis: Write Emacs module in Haskell, using Emacs 25's Dynamic Module feature+description:+ Please see README.md+category: Editor, Emacs+author: Takenari Shinohara --- executable edm.so--- hs-source-dirs: app--- main-is: Main.hs--- -- ghc-options: -threaded -rtsopts -with-rtsopts=-N--- -- extra-libraries: HSrts-ghc7.10.3--- cc-options: -fPIC--- ghc-options: -shared -dynamic -fPIC -lHSrts-ghc7.10.3--- build-depends: base--- , haskelisp--- , text--- , protolude--- , turtle--- , system-filepath--- , foldl--- default-language: Haskell2010+source-repository head+ type: git+ location: https://github.com/githubuser/haskelisp --- test-suite haskelisp-test--- type: exitcode-stdio-1.0--- hs-source-dirs: test--- main-is: Spec.hs--- build-depends: base--- , haskelisp--- ghc-options: -threaded -rtsopts -with-rtsopts=-N--- default-language: Haskell2010+library+ exposed-modules:+ Emacs+ Emacs.Type+ Emacs.Internal+ Emacs.Symbol+ Emacs.Core+ Emacs.Variable+ Emacs.Function+ Emacs.Command+ build-depends:+ base >=4.7 && <5,+ protolude <0.2,+ containers <0.6,+ mtl <2.3,+ text <1.3,+ logging-effect <1.1+ c-sources:+ cbits/stab.c+ default-language: Haskell2010+ include-dirs: cbits+ hs-source-dirs: src -source-repository head- type: git- location: https://github.com/githubuser/haskelisp
src/Emacs.hs view
@@ -1,6 +1,13 @@-module Emacs (module Emacs.Core, module Emacs.Variable, module Emacs.Function, module Emacs.Command) where+module Emacs+ ( module Emacs.Core+ , module Emacs.Symbol+ , module Emacs.Variable+ , module Emacs.Function+ , module Emacs.Command+ ) where import Emacs.Core+import Emacs.Symbol import Emacs.Variable import Emacs.Function import Emacs.Command
src/Emacs/Command.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Emacs.Command- ( setCommand'- , defcommand+ ( setCommand+ , defcommand' ) where import Emacs.Core@@ -13,20 +13,20 @@ -- これは直接は使って欲くないため、' postfix を付けている。 -- EmacsValue を引数として取っているので function 以外のものを渡せてしまう-setCommand' :: Text -> InteractiveForm -> EmacsValue -> EmacsM ()-setCommand' fname form f = do- fnameQ <- mkSymbol fname- interactiveFormQ <- mkSymbol "interactive-form"+setCommand :: Text -> InteractiveForm -> EmacsValue -> EmacsM ()+setCommand fname form f = do+ fnameQ <- intern fname+ interactiveFormQ <- intern "interactive-form" void $ funcall2 "fset" fnameQ f void $ funcall3 "put" fnameQ interactiveFormQ =<< evalString "'(interactive nil)" -- TODO: interacitve-form の携帯によってarity は決まる？かな-defcommand+defcommand' :: Text -> Doc -> InteractiveForm -> Arity -> ([EmacsValue] -> EmacsM EmacsValue) -> EmacsM ()-defcommand fname (Doc doc) form (Arity arity) f =- setCommand' fname form =<< mkFunction f arity arity doc+defcommand' fname (Doc doc) form (Arity arity) f =+ setCommand fname form =<< mkFunction f arity arity doc
src/Emacs/Core.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE ForeignFunctionInterface,OverloadedStrings,DataKinds,TypeFamilies,KindSignatures,FlexibleInstances,UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -11,6 +14,8 @@ -- funcall ToEmacsValue(..), funcall1, funcall2, funcall3,+ mkFunctionFromCallable,+ Callable, -- car, cdr,@@ -40,23 +45,30 @@ -- 利便性だけのためかな？ class ToEmacsValue h where toEv :: h -> EmacsM EmacsValue+ instance ToEmacsValue Int where toEv = mkInteger+ instance ToEmacsValue Text where toEv = mkString+ instance ToEmacsValue Symbol where- toEv (Symbol name) = mkSymbol name+ toEv (Symbol name) = intern name++instance ToEmacsValue Bool where+ toEv True = mkT+ toEv False = mkNil+ instance ToEmacsValue () where toEv _ = mkNil+ instance ToEmacsValue EmacsValue where toEv = pure--- TODO: 以下のはやりすぎか？--- join を含むのはやりすぎだ...--- instance ToEmacsValue h => ToEmacsValue (EmacsM h) where--- toEv = join . fmap toEv+ instance ToEmacsValue h => ToEmacsValue [h] where toEv xs = join $ mkList <$> mapM toEv xs+ instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsValue (a,b) where toEv (a,b) = do av <- toEv a@@ -91,56 +103,83 @@ funcall1 :: (ToEmacsValue a) => Text -> a -> EmacsM EmacsValue funcall1 fname ev0 =- join $ funcall <$> mkSymbol fname+ join $ funcall <$> intern fname <*> sequence [toEv ev0] funcall2 :: (ToEmacsValue a, ToEmacsValue b) => Text -> a -> b -> EmacsM EmacsValue funcall2 fname ev0 ev1 =- join $ funcall <$> mkSymbol fname+ join $ funcall <$> intern fname <*> sequence [toEv ev0, toEv ev1] funcall3 :: (ToEmacsValue a, ToEmacsValue b, ToEmacsValue c) => Text -> a -> b -> c -> EmacsM EmacsValue funcall3 fname ev0 ev1 ev2 =- join $ funcall <$> mkSymbol fname+ join $ funcall <$> intern fname <*> sequence [toEv ev0, toEv ev1, toEv ev2] --- haskell-emacs の haskell 内 lisp の記述言語をパクる。------ Lisp 型を利用して EmacsValue を生成する場合は自明だが、逆に--- EmacsValue より Lisp を得るのはそうではない。------ うーん、微妙。やはりモジュールにまとめるべきかな？------ data Lisp = Symbol Text--- | String Text--- | Integer Int--- | List [Lisp]--- | Ev EmacsValue--- | EvM (EmacsM EmacsValue)--- | Function EFunction--- | FunctionM (EmacsM EFunction) --- lispToEmacsValue :: Lisp -> EmacsM EmacsValue--- lispToEmacsValue (Symbol t) = untag <$> mkESymbol t--- lispToEmacsValue (String t) = untag <$> mkEString t--- lispToEmacsValue (Integer i) = untag <$> mkEInteger i--- lispToEmacsValue (List xs') = do--- xs <- (sequence (map lispToEmacsValue xs'))--- mkEList xs--- lispToEmacsValue (Ev ev) = pure ev--- lispToEmacsValue (Function f) = pure (untag f)--- lispToEmacsValue (EvM evm) = evm--- lispToEmacsValue (FunctionM f) = untag <$> f+-- | Haskell <- EmacsValue+-- これは mkEFunction のために？+class FromEmacsValue h where+ fromEv :: EmacsValue -> EmacsM (Maybe h) --- funcall :: Lisp -> [Lisp] -> EmacsM EmacsValue--- funcall f args =--- join $ funcall' <$> (lispToEmacsValue f) <*> (sequence $ map lispToEmacsValue args)+-- 何故か Num b => .. だと Overlapping で怒られる。分からん。。+instance FromEmacsValue Int where+ fromEv = extractIntegerMaybe --- funcall_ :: Lisp -> [Lisp] -> EmacsM ()--- funcall_ f args =--- void $ funcall f args+instance FromEmacsValue EmacsValue where+ fromEv = pure . Just++-- hack+-- 多相的な関数は駄目らしい(具体的な関数ならokらしい)+class Callable a where+ call :: a -> [EmacsValue] -> EmacsM (Either Text EmacsValue)+ arity :: a -> Int++instance {-# OVERLAPPING #-} ToEmacsValue a => Callable a where+ call a [] = Right <$> toEv a+ call _ _ = pure $ Left "Too many arguments"+ arity _ = 0++instance {-# OVERLAPPING #-} ToEmacsValue a => Callable (IO a) where+ call a [] = do+ v <- liftIO a+ Right <$> toEv v+ call _ _ = pure $ Left "Too many arguments"+ arity _ = 0++instance {-# OVERLAPPING #-} ToEmacsValue a => Callable (EmacsM a) where+ call am [] = do+ a <- am+ Right <$> toEv a+ call _ _ = pure $ Left "Too many arguments"+ arity _ = 0++instance {-# OVERLAPPING #-} (FromEmacsValue a, Callable b) => Callable (a -> b) where++ call f (e:es) = do+ av' <- fromEv e+ case av' of+ Just av -> call (f av) es+ Nothing -> pure $ Left ""+ call _ [] = pure $ Left "Too less arguments"+ arity f = arity (f undefined) + 1++-- |+-- 多層的な関数は怒られるはず。+--+mkFunctionFromCallable :: Callable f => f -> EmacsM EmacsValue+mkFunctionFromCallable f = do+ let a = arity f+ mkFunction func a a ""+ where+ func :: [EmacsValue] -> EmacsM EmacsValue+ func es = do+ res <- call f es+ case res of+ Right ev -> return ev+ Left _ -> undefined evalString :: Text -> EmacsM EmacsValue evalString t =
src/Emacs/Function.hs view
@@ -16,68 +16,10 @@ void $ funcall2 "fset" (Symbol name) f -- | より elisp に近い形で記述したいのであればこちら-defun :: Text -> Doc -> Arity -> ([EmacsValue] -> EmacsM EmacsValue) -> EmacsM ()-defun name (Doc doc) (Arity arity) f =+defun' :: Text -> Doc -> Arity -> ([EmacsValue] -> EmacsM EmacsValue) -> EmacsM ()+defun' name (Doc doc) (Arity arity) f = setFunction name =<< mkFunction f arity arity doc -defun' :: Callable f => Text -> f -> EmacsM ()-defun' name f =+defun :: Callable f => Text -> f -> EmacsM ()+defun name f = setFunction name =<< mkFunctionFromCallable f---- | Haskell <- EmacsValue--- これは mkEFunction のために？-class FromEmacsValue h where- fromEv :: EmacsValue -> EmacsM (Maybe h)--instance Num b => FromEmacsValue b where- fromEv = extractIntegerMaybe---- hack--- 多相的な関数は駄目らしい(具体的な関数ならokらしい)-class Callable a where- call :: a -> [EmacsValue] -> EmacsM (Either Text EmacsValue)- arity :: a -> Int--instance {-# OVERLAPPING #-} ToEmacsValue a => Callable a where- call a [] = Right <$> toEv a- call _ _ = pure $ Left "Too many arguments"- arity _ = 0--instance {-# OVERLAPPING #-} ToEmacsValue a => Callable (IO a) where- call a [] = do- v <- liftIO a- Right <$> toEv v- call _ _ = pure $ Left "Too many arguments"- arity _ = 0--instance {-# OVERLAPPING #-} ToEmacsValue a => Callable (EmacsM a) where- call am [] = do- a <- am- Right <$> toEv a- call _ _ = pure $ Left "Too many arguments"- arity _ = 0--instance {-# OVERLAPPING #-} (FromEmacsValue a, Callable b) => Callable (a -> b) where-- call f (e:es) = do- av' <- fromEv e- case av' of- Just av -> call (f av) es- Nothing -> pure $ Left ""- call _ [] = pure $ Left "Too less arguments"- arity f = arity (f undefined) + 1---- |--- 多層的な関数は怒られるはず。----mkFunctionFromCallable :: Callable f => f -> EmacsM EmacsValue-mkFunctionFromCallable f = do- let a = arity f- mkFunction func a a ""- where- func :: [EmacsValue] -> EmacsM EmacsValue- func es = do- res <- call f es- case res of- Right ev -> return ev- Left _ -> undefined
src/Emacs/Internal.hs view
@@ -17,6 +17,7 @@ -- emacs -> haskell extractInteger, extractIntegerMaybe,+ extractString, -- eq, isNotNil,@@ -25,9 +26,10 @@ mkFunction, mkInteger, mkString,- mkSymbol,+ intern, mkList, mkNil,+ mkT, -- funcall, errorHandle@@ -52,11 +54,9 @@ import Foreign.Marshal.Array import Foreign.Marshal.Alloc import GHC.Ptr+import qualified GHC.Foreign as GHC+import GHC.IO.Encoding.UTF8 (utf8) import Control.Monad.Log-import qualified Turtle as T-import Formatting (sformat)-import Formatting.Clock (timeSpecs)-import System.Clock (getTime,Clock(..)) initState :: MonadIO m => m PState initState = do@@ -81,19 +81,12 @@ getEnv = emacsEnv <$> ask +-- Logging here is not a good idea. When passing high order function,+-- which could be invoked manytimes, its get quite slow. runEmacsM :: MonadIO m => Ctx -> EmacsM a -> m a runEmacsM ctx action = do- let logHandler t = T.append "/tmp/emacshaskell.log" (pure t)- liftIO $ do- startT <- getTime Monotonic- r <- runReaderT (runLoggingT action logHandler) ctx- endT <- getTime Monotonic- map <- readIORef . symbolMap $ pstate ctx- let time = sformat timeSpecs startT endT- cacheSize = Map.size map- log = "emacsM run time: " <> time <> ", symbol cache size: " <> (show cacheSize)- logHandler log- return r+ let logHandler t = pure ()+ liftIO $ runReaderT (runLoggingT action logHandler) ctx foreign import ccall _get_emacs_env_from_rt :: Ptr ()@@ -115,7 +108,7 @@ env <- getEnv typeP <- checkExitStatus $ _type_of env ev types <- forM emacsTypes $ \t -> do- q <- mkSymbol (emacsTypeSymbolName t)+ q <- intern (emacsTypeSymbolName t) b <- eq q typeP return (b, t) case List.find fst types of@@ -152,6 +145,40 @@ then (Just <$> extractInteger v) else return Nothing +-- 使い方が今イチ曖昧だが、コード見たら分かりやすい。+--+-- * Can throw signals(その場合 false が返る)+-- * もし Buffer が null の場合、Length に文字列のutf8で格納する際の+-- 必要な長さが設定され、1 を返す+-- * もし Buffer が non-null かつ、Length がutf8を格納するのに足りな+-- い場合、Length に必要な長さが設定され args_out_of_rangeエラーが+-- 投げられる。+-- * Bufferが non-null かつ、Length が十分な長さを持っている場合、+-- Buffer に utf8文字列(+最後はnull文字)が格納され、Length には長さ+-- (最後のnull文字を含めたもの)が設定され 1 を返す。+--+foreign import ccall _copy_string_contents+ :: EmacsEnv+ -> EmacsValue+ -> CString -- Buffer+ -> Ptr CPtrdiff -- Length+ -> IO CInt++extractString :: EmacsValue -> EmacsM Text+extractString ev = do+ env <- getEnv+ checkExitStatus $ alloca $ \length' -> do+ result <- _copy_string_contents env ev nullPtr length'+ if result == 1+ then do+ length <- fromIntegral <$> peek length'+ allocaBytes length $ \buffer -> do+ result' <- _copy_string_contents env ev buffer length'+ if result == 1+ then toS <$> GHC.peekCString utf8 buffer+ else pure ""+ else pure ""+ -- | どうなんだ？ -- eq は bool 返すのだが、haskell では CBool は用意していないので int にして返している。 -- module_eq は珍しく MODULE_FUNCTION_BEGIN を使っていない。@@ -251,8 +278,6 @@ -- といけな？ haskellExceptionHandler :: SomeException -> IO EmacsValue haskellExceptionHandler e = do- let log t = T.append "/tmp/emacshaskell.log" (pure t)- log $ "haskellExceptionHandler: " <> (show e) ctx <- initCtx env runEmacsM ctx $ do funcallExit <- nonLocalExitCheck@@ -263,14 +288,12 @@ when (funcallExit == EmacsFuncallExitReturn) $ do mes <- mkString (toS $ displayException e) arg <- mkList [mes]- sym <- mkSymbol "haskell-error"+ sym <- intern "haskell-error" nonLocalExitSignal sym arg -- これ以降 emacs関数を呼んでは駄目 return nil emacsExceptionHandler :: EmacsException -> IO EmacsValue emacsExceptionHandler e@(EmacsException funcallExit a0 a1) = do- let log t = T.append "/tmp/emacshaskell.log" (pure t)- log $ "emacsExceptionHandler: " <> (show e) let setter = case funcallExit of EmacsFuncallExitSignal -> _non_local_exit_signal EmacsFuncallExitThrow -> _non_local_exit_throw@@ -324,7 +347,7 @@ -- | Symbol -- https://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Symbols.html ----- mkSymbol という名前にしたのは不味い気がしてきた。elispには intern+-- intern という名前にしたのは不味い気がしてきた。elispには intern -- と make-symbol があり意味が違う。intern はシンボルを obarray に登録 -- する(既に登録されていればそれを返す)。make-symbol は全く新しいシン -- ボルを作成し、obarray には登録しない。@@ -337,8 +360,8 @@ -> CString -> IO EmacsValue -mkSymbol :: Text -> EmacsM EmacsValue-mkSymbol str = do+intern :: Text -> EmacsM EmacsValue+intern str = do s' <- lookupCache case s' of Just gev ->@@ -370,10 +393,16 @@ -- emacs側でGCされないように global_ref を作る必要があるのかな？ mkNil :: EmacsM EmacsValue mkNil = do- q0 <- mkSymbol "symbol-value"- q1 <- mkSymbol "nil"+ q0 <- intern "symbol-value"+ q1 <- intern "nil" funcall q0 [q1] +mkT :: EmacsM EmacsValue+mkT = do+ q0 <- intern "symbol-value"+ q1 <- intern "t"+ funcall q0 [q1]+ -- そもそも list という型は emacs側には存在しない。 -- listp という関数があるが、これは cons もしくは nil かどうかを判定している。 --@@ -386,7 +415,7 @@ mkList :: [EmacsValue] -> EmacsM EmacsValue mkList evs = do- listQ <- mkSymbol "list"+ listQ <- intern "list" funcall listQ evs foreign import ccall _make_global_ref
+ src/Emacs/Symbol.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+module Emacs.Symbol where++import Prelude()+import Protolude+import Emacs.Core+import Data.IORef++-- | All symbols+--+-- obarray に設定されている全てのシンボルを取得する。+-- Use `mapatoms` functoin.+allSymbols :: EmacsM [EmacsValue]+allSymbols = do+ ref <- liftIO $ newIORef []+ funcall1 "mapatoms" =<< mkFunctionFromCallable (accum ref)+ liftIO $ readIORef ref+ where+ accum :: IORef [EmacsValue] -> EmacsValue -> IO ()+ accum ref sym = modifyIORef ref (sym:)++-- | Symbol has four slots?++-- | Keyword Symbol++-- | シンボルは任意の属性を持つことができる。+--+-- 属性テーブルは シンボルと任意の値に間のハッシュである。+-- ただし値として nil は設定できない。未設定とnil に設定は区別されない。++symbolProperty :: Text -> Text -> EmacsM (Maybe EmacsValue)+symbolProperty name property = do+ ev <- funcall2 "get" (Symbol name) (Symbol property)+ b <- isNotNil ev+ return $ if b then Just ev else Nothing++setSymbolProperty+ :: (ToEmacsValue v)+ => Text+ -> Text+ -> v+ -> EmacsM EmacsValue+setSymbolProperty name property value =+ funcall3 "put" (Symbol name) (Symbol property) value