diff --git a/cbits/stab.c b/cbits/stab.c --- a/cbits/stab.c +++ b/cbits/stab.c @@ -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) { diff --git a/haskelisp.cabal b/haskelisp.cabal --- a/haskelisp.cabal +++ b/haskelisp.cabal @@ -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 diff --git a/src/Emacs.hs b/src/Emacs.hs --- a/src/Emacs.hs +++ b/src/Emacs.hs @@ -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 diff --git a/src/Emacs/Command.hs b/src/Emacs/Command.hs --- a/src/Emacs/Command.hs +++ b/src/Emacs/Command.hs @@ -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 diff --git a/src/Emacs/Core.hs b/src/Emacs/Core.hs --- a/src/Emacs/Core.hs +++ b/src/Emacs/Core.hs @@ -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 = diff --git a/src/Emacs/Function.hs b/src/Emacs/Function.hs --- a/src/Emacs/Function.hs +++ b/src/Emacs/Function.hs @@ -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 diff --git a/src/Emacs/Internal.hs b/src/Emacs/Internal.hs --- a/src/Emacs/Internal.hs +++ b/src/Emacs/Internal.hs @@ -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 diff --git a/src/Emacs/Symbol.hs b/src/Emacs/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Emacs/Symbol.hs @@ -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