haskelisp (empty) → 0.1.0.0
raw patch · 11 files changed
+1152/−0 lines, 11 filesdep +basedep +clockdep +containerssetup-changed
Dependencies added: base, clock, containers, formatting, logging-effect, mtl, protolude, text, turtle
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/stab.c +129/−0
- haskelisp.cabal +65/−0
- src/Emacs.hs +6/−0
- src/Emacs/Command.hs +32/−0
- src/Emacs/Core.hs +164/−0
- src/Emacs/Function.hs +83/−0
- src/Emacs/Internal.hs +482/−0
- src/Emacs/Type.hs +135/−0
- src/Emacs/Variable.hs +24/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/stab.c view
@@ -0,0 +1,129 @@+#include <HsFFI.h>+#include <string.h>+#include <emacs-module.h>+/* extern void __stginit_Lib(void); */++/* Declare mandatory GPL symbol. */+/* Shoudn't declare here. Library user should declare. */+/* int plugin_is_GPL_compatible; */++void __attribute__ ((constructor)) my_load(void);+void __attribute__ ((destructor)) my_unload(void);++// https://www.vex.net/~trebla/haskell/so.xhtml 参照+void my_load(void) {+ static int argc = 1;+ static char *argv[] = { "haskelisp", 0}, **argv_ = argv;+ hs_init(&argc, &argv_);+}+void my_unload(void) {+ hs_exit();+}++/* wrappers */++emacs_env *_get_emacs_env_from_rt(struct emacs_runtime *ert) {+ return ert->get_environment(ert);+}++/* Function registration. */++emacs_value _make_function(emacs_env *env,+ ptrdiff_t min_arity,+ ptrdiff_t max_arity,+ emacs_value (*function) (emacs_env *env,+ ptrdiff_t nargs,+ emacs_value args[],+ void *),+ const char *documentation,+ void *data) {+ return env->make_function(env,+ min_arity,+ max_arity,+ function,+ documentation,+ data);+}++emacs_value _funcall(emacs_env *env,+ emacs_value function,+ ptrdiff_t nargs,+ emacs_value args[]) {+ return env->funcall(env,+ function,+ nargs,+ args);+}++emacs_value _intern(emacs_env *env, const char *symbol_name) {+ return env->intern(env, symbol_name);+}++/* Type conversion. */++emacs_value _type_of(emacs_env *env, emacs_value value) {+ return env->type_of(env,value);+}++int _is_not_nil(emacs_env *env, emacs_value value) {+ return env->is_not_nil(env,value) == true ? 1 : 0;+}++int _eq(emacs_env *env, emacs_value a, emacs_value b) {+ return env->eq(env, a, b) == true ? 1 : 0;+}++intmax_t _extract_integer(emacs_env *env, emacs_value value) {+ return env->extract_integer(env, value);+}++emacs_value _make_integer(emacs_env *env, intmax_t value) {+ return env->make_integer(env, value);+}++/* double (*extract_float) (emacs_env *env, emacs_value value); */++/* emacs_value (*make_float) (emacs_env *env, double value); */++emacs_value _make_string(emacs_env *env,+ const char *contents,+ ptrdiff_t length) {+ return env->make_string(env,contents,length);+}++/* Memory management. */++emacs_value _make_global_ref(emacs_env *env,+ emacs_value any_reference) {+ return env->make_global_ref(env, any_reference);+}++/* Non-local exit handling. */++enum emacs_funcall_exit _non_local_exit_check(emacs_env *env) {+ return env->non_local_exit_check(env);+}++void _non_local_exit_clear(emacs_env *env) {+ env->non_local_exit_clear(env);+}++enum emacs_funcall_exit _non_local_exit_get(emacs_env *env,+ emacs_value *non_local_exit_symbol_out,+ emacs_value *non_local_exit_data_out) {+ return env->non_local_exit_get(env,+ non_local_exit_symbol_out,+ non_local_exit_data_out);+}++void _non_local_exit_signal(emacs_env *env,+ emacs_value non_local_exit_symbol,+ emacs_value non_local_exit_data) {+ env->non_local_exit_signal(env, non_local_exit_symbol, non_local_exit_data);+}++void _non_local_exit_throw(emacs_env *env,+ emacs_value tag,+ emacs_value value) {+ env->non_local_exit_throw(env,tag,value);+}
+ haskelisp.cabal view
@@ -0,0 +1,65 @@+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++-- 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++-- 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++source-repository head+ type: git+ location: https://github.com/githubuser/haskelisp
+ src/Emacs.hs view
@@ -0,0 +1,6 @@+module Emacs (module Emacs.Core, module Emacs.Variable, module Emacs.Function, module Emacs.Command) where++import Emacs.Core+import Emacs.Variable+import Emacs.Function+import Emacs.Command
+ src/Emacs/Command.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Emacs.Command+ ( setCommand'+ , defcommand+ ) where++import Emacs.Core+import Data.Text+import Control.Monad (void)++-- 依存型とか駆使すれば多分 interacvie form と関数の引数の型の整合性が+-- 取れていることが多分保証できる。++-- これは直接は使って欲くないため、' postfix を付けている。+-- EmacsValue を引数として取っているので function 以外のものを渡せてしまう+setCommand' :: Text -> InteractiveForm -> EmacsValue -> EmacsM ()+setCommand' fname form f = do+ fnameQ <- mkSymbol fname+ interactiveFormQ <- mkSymbol "interactive-form"+ void $ funcall2 "fset" fnameQ f+ void $ funcall3 "put" fnameQ interactiveFormQ =<< evalString "'(interactive nil)"++-- TODO: interacitve-form の携帯によってarity は決まる？かな+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
+ src/Emacs/Core.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Emacs.Core (+ module Emacs.Internal,+ defmodule,+ -- mk+ mkCons,+ -- funcall+ ToEmacsValue(..),+ funcall1, funcall2, funcall3,+ --+ car,+ cdr,+ --+ evalString,+ provide,+ message,+ ) where++import Prelude()+import Protolude hiding (mkInteger)+import Foreign.C.Types+import Foreign.StablePtr+import Emacs.Type+import Emacs.Internal++-- emacsModuleInit に渡す関数+defmodule :: Text -> EmacsM a -> Ptr () -> IO CInt+defmodule name mod ert = do+ env <- getEmacsEnvFromRT ert+ errorHandle env $ do+ ctx <- initCtx env+ runEmacsM ctx $ mod >> funcall1 "provide" (Symbol name)+ return 0++-- | Haskell -> EmacsValue への変換+-- 利便性だけのためかな？+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+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+ bv <- toEv b+ mkCons av bv++-- シンボルを渡す場所は多いので。ただ ToEmacsValue と関係持たせていは+-- いけない。+--+-- 通常は Text の引数でいいと思うんだけ(いちいち)文字列ではなく、シン+-- ボルにするよと明示したいところでは利用するのがいいかな？後は関数か+-- らのシンボルの返値を利用する場合とかかな(Text だと、一旦+-- symbol-name で文字列表現を取り出す必要が出てくる)。+--+-- ああ、やはりどうだろう。そもそもシンボルという概念がhaskellには必要+-- ないか？objectではなく、eq で等価性が判定されるので文字列と同義にな+-- るのかな？(ただ空文字列は駄目かな)。+-- ESymbol でも動作させたい関数は ' バージョンを作るのがいいかな。+-- class ToESymbol h where+-- toESymbol :: h -> EmacsM ESymbol+-- toESymbol' :: h -> EmacsM EmacsValue+-- toESymbol' = fmap (untag) . toESymbol+-- instance ToESymbol Symbol where+-- toESymbol (Symbol name) = mkESymbol name+-- instance ToESymbol ESymbol where+-- toESymbol = pure+-- instance ToESymbol (EmacsM ESymbol) where+-- toESymbol = id++-- for internal usage.+-- 関数名は ToESymbol ではなく、Text で受け取っているのは利便性のため。+funcall1 :: (ToEmacsValue a)+ => Text -> a -> EmacsM EmacsValue+funcall1 fname ev0 =+ join $ funcall <$> mkSymbol fname+ <*> sequence [toEv ev0]++funcall2 :: (ToEmacsValue a, ToEmacsValue b)+ => Text -> a -> b -> EmacsM EmacsValue+funcall2 fname ev0 ev1 =+ join $ funcall <$> mkSymbol 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+ <*> 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++-- funcall :: Lisp -> [Lisp] -> EmacsM EmacsValue+-- funcall f args =+-- join $ funcall' <$> (lispToEmacsValue f) <*> (sequence $ map lispToEmacsValue args)++-- funcall_ :: Lisp -> [Lisp] -> EmacsM ()+-- funcall_ f args =+-- void $ funcall f args++evalString :: Text -> EmacsM EmacsValue+evalString t =+ funcall1 "eval" =<< (car =<< funcall1 "read-from-string" t)++provide :: Text -> EmacsM ()+provide feature =+ void $ funcall1 "provide" (Symbol feature)++message :: Text -> EmacsM ()+message t =+ void $ funcall1 "message" t++mkCons :: EmacsValue -> EmacsValue -> EmacsM EmacsValue+mkCons = funcall2 "cons"++car :: EmacsValue -> EmacsM EmacsValue+car = funcall1 "car"++cdr :: EmacsValue -> EmacsM EmacsValue+cdr = funcall1 "cdr"
+ src/Emacs/Function.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ForeignFunctionInterface,OverloadedStrings,DataKinds,TypeFamilies,KindSignatures,FlexibleInstances,UndecidableInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+module Emacs.Function where++import Prelude()+import Protolude+import Emacs.Core++-- | 関数の設定+-- 一番 low level なのが setFunction+setFunction :: Text -> EmacsValue -> EmacsM ()+setFunction name f = do+ void $ funcall2 "fset" (Symbol name) f++-- | より elisp に近い形で記述したいのであればこちら+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 =+ 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
@@ -0,0 +1,482 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Emacs.Internal (+ module Emacs.Type,+ initState,+ initCtx,+ getEnv,+ runEmacsM,+ getEmacsEnvFromRT,+ -- Type relaties one..+ typeOf,+ isTypeOf,+ -- emacs -> haskell+ extractInteger,+ extractIntegerMaybe,+ --+ eq,+ isNotNil,+ isNil,+ -- mk+ mkFunction,+ mkInteger,+ mkString,+ mkSymbol,+ mkList,+ mkNil,+ --+ funcall,+ errorHandle+ ) where++{-+emacs-modue.h の関数。+型は EmacsValue しか扱わない。基本、このレベルの関数は使うべきではない。+-}++import Prelude()+import Protolude hiding (mkInteger)+import Control.Exception (displayException)+import Data.IORef+import Emacs.Type+import qualified Data.List as List+import qualified Data.Map as Map+import Foreign.C.Types+import Foreign.C.String+import Foreign.StablePtr+import Foreign.Storable+import Foreign.Marshal.Array+import Foreign.Marshal.Alloc+import GHC.Ptr+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+ mapRef <- liftIO $ newIORef mempty+ return $ PState mapRef++initCtx :: MonadIO m => EmacsEnv -> m Ctx+initCtx env = do+ pstate <- initState+ pstatep <- liftIO $ newStablePtr pstate+ return $ Ctx pstatep pstate env++getPStateStablePtr :: EmacsM (StablePtr PState)+getPStateStablePtr =+ pstateStablePtr <$> ask++getPState :: EmacsM PState+getPState =+ pstate <$> ask++getEnv :: EmacsM EmacsEnv+getEnv =+ emacsEnv <$> ask++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++foreign import ccall _get_emacs_env_from_rt+ :: Ptr ()+ -> IO EmacsEnv++getEmacsEnvFromRT :: Ptr () -> IO EmacsEnv+getEmacsEnvFromRT =+ _get_emacs_env_from_rt++-- TODO: シンボル のキャッシュしないと毎回シンボルを取得するのは遅い気+-- がする。+foreign import ccall _type_of+ :: EmacsEnv+ -> EmacsValue+ -> IO EmacsValue++typeOf :: EmacsValue -> EmacsM EmacsType+typeOf ev = do+ env <- getEnv+ typeP <- checkExitStatus $ _type_of env ev+ types <- forM emacsTypes $ \t -> do+ q <- mkSymbol (emacsTypeSymbolName t)+ b <- eq q typeP+ return (b, t)+ case List.find fst types of+ Just (_, t) -> return t+ Nothing -> error "no type"++isTypeOf :: EmacsType -> EmacsValue -> EmacsM Bool+isTypeOf ty ev = do+ t <- typeOf ev+ return $ t == ty++-- | EmacsVAlue -> Haskell の変換+--+-- ただし可能なのは限られている。例えば バッファとかは Haskell 側で対+-- 応する型を持たないので EBuffer(もしくは EmacsValue)のままで扱う必要+-- がある。++-- 引数が integer じゃない場合多分 signal が投げられる+foreign import ccall _extract_integer+ :: EmacsEnv+ -> EmacsValue+ -> IO CIntMax++extractInteger :: Num b => EmacsValue -> EmacsM b+extractInteger ev = do+ env <- getEnv+ i <- checkExitStatus $ _extract_integer env ev+ return (fromIntegral i)++extractIntegerMaybe :: Num b => EmacsValue -> EmacsM (Maybe b)+extractIntegerMaybe v = do+ b <- isTypeOf EInteger v+ if b+ then (Just <$> extractInteger v)+ else return Nothing++-- | どうなんだ？+-- eq は bool 返すのだが、haskell では CBool は用意していないので int にして返している。+-- module_eq は珍しく MODULE_FUNCTION_BEGIN を使っていない。+foreign import ccall _eq+ :: EmacsEnv+ -> EmacsValue+ -> EmacsValue+ -> IO CInt++eq :: EmacsValue -> EmacsValue -> EmacsM Bool+eq ev0 ev1 = do+ env <- getEnv+ r <- liftIO $ _eq env ev0 ev1+ return (r == 1)++foreign import ccall _is_not_nil+ :: EmacsEnv+ -> EmacsValue+ -> IO CInt++isNotNil :: EmacsValue -> EmacsM Bool+isNotNil ev = do+ env <- getEnv+ r <- liftIO $ _is_not_nil env ev+ return (r == 1)++isNil :: EmacsValue -> EmacsM Bool+isNil = (fmap . fmap) not isNotNil++-- TODO: castFunPtrToPtr はまずいかな？inline-c 自体にFunPtrを作る機能+-- が備わっている？$fun:(...) 何故か使えない。。+-- TODO: arity と doc は Arity と Doc 型にするべきかな。++foreign import ccall _make_function+ :: EmacsEnv+ -> CPtrdiff+ -> CPtrdiff+ -> FunPtr EFunctionStub+ -> CString+ -> StablePtr a+ -> IO EmacsValue++-- TODO: ??? これ StablePtr の効果も兼ねている？+foreign import ccall "wrapper" wrapEFunctionStub+ :: EFunctionStub+ -> IO (FunPtr EFunctionStub)++mkFunction :: ([EmacsValue] -> EmacsM EmacsValue) -> Int -> Int -> Text -> EmacsM EmacsValue+mkFunction f minArity' maxArity' doc' = do+ let minArity = fromIntegral minArity' :: CPtrdiff+ maxArity = fromIntegral maxArity' :: CPtrdiff+ datap <- getPStateStablePtr+ stubp <- liftIO (wrapEFunctionStub stub)+ env <- getEnv+ checkExitStatus . withCString (toS doc') $ \doc ->+ _make_function env minArity maxArity stubp doc datap+ where+ stub :: EFunctionStub+ stub env nargs args pstatep = errorHandle env $ do+ pstate <- deRefStablePtr pstatep+ es <- fmap EmacsValue <$> peekArray (fromIntegral nargs) args+ runEmacsM (Ctx pstatep pstate env) (f es)++-- | Haskell で投げられた例外の対応+--+-- Emacs -> Haskell から呼ばれるところに設置する必要がある。例外が補足+-- できないと恐らく emacs がクラッシュする。非同期例外については考える+-- 必要はない。+--+-- 二つの場合を対処する必要がある(多段)+--+-- 1. Haskell 側で例外が発生した+-- 2. Haskell から呼び出した emacs 関数の中で signal(or throw)された+--+-- 2. の場合、emacsから返ってきた時に non local exit かどうか確認し、+-- もしそうであれば haskellの例外を投げる。そして haskell -> emacsに戻+-- る場所で haskellの例外は補足する。その場合、non-local-exit は既に設+-- 定されているので、+--+-- _non_local_exit_signal で haskellエラーであることを設定する。ただし+-- これが簡単にはいかず、+--+-- * IO モナドの中で実現する必要がある+-- * emacs関数を呼び出す際に例外が発生しうるものを呼び出せない+--+-- catch する順番重要+errorHandle :: EmacsEnv -> IO EmacsValue -> IO EmacsValue+errorHandle env action =+ action `catch` emacsExceptionHandler+ `catch` haskellExceptionHandler+ where+ -- handler の中で例外が発生した場合は諦め？+ -- ほんとは ctx はいらなくて、env だけで 対応したいところ+ -- とりあえずの対応+ --+ -- TODO: ハンドラ中に EmacsException が投げられたときは無視しない+ -- といけな？+ 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+ -- TODO: これが不味い。既に funcall-exit が signal/throw に設+ -- 定されている可能性があるため、mkNil で更に EmacsException+ -- 例外が飛んでしまう。+ nil <- mkNil+ when (funcallExit == EmacsFuncallExitReturn) $ do+ mes <- mkString (toS $ displayException e)+ arg <- mkList [mes]+ sym <- mkSymbol "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+ setter env a0 a1+ return a0++-- emacsモジュール関数の呼び出し後に signal/throwされていないかチェッ+-- クする。されている場合は EmacsException を投げる。+--+-- emacs-module.c の module_* 関数で 先頭にMODULE_FUNCTION_BEGIN が書+-- かれているものが実行の後にチェックが必要。+--+-- TODO: 理想的には チェック必要な import ccal は IONeedCheck a みたい+-- な型を返すようにして、checkExitStatus しないと IO(や EmacsM)に直せ+-- ないようにするのがいいのかな？ただちょっと面倒。+checkExitStatus :: IO a -> EmacsM a+checkExitStatus action = do+ v <- liftIO action+ funcallExit <- nonLocalExitCheck+ when (funcallExit /= EmacsFuncallExitReturn) $ do+ (_,a0,a1) <- nonLocalExitGet+ nonLocalExitClear+ liftIO . throwIO $ EmacsException funcallExit a0 a1+ return v++-- emacs_value (*make_integer) (emacs_env *env, intmax_t value);+foreign import ccall _make_integer+ :: EmacsEnv+ -> CIntMax+ -> IO EmacsValue++mkInteger :: Integral n => n -> EmacsM EmacsValue+mkInteger i' = do+ let i = fromIntegral i' :: CIntMax+ env <- getEnv+ checkExitStatus $ _make_integer env i++-- Create emacs symbol+foreign import ccall _make_string+ :: EmacsEnv+ -> CString+ -> CPtrdiff+ -> IO EmacsValue++mkString :: Text -> EmacsM EmacsValue+mkString str = do+ env <- getEnv+ checkExitStatus . withCStringLen (toS str) $ \(cstr,len) ->+ _make_string env cstr (fromIntegral len)++-- | Symbol+-- https://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Symbols.html+--+-- mkSymbol という名前にしたのは不味い気がしてきた。elispには intern+-- と make-symbol があり意味が違う。intern はシンボルを obarray に登録+-- する(既に登録されていればそれを返す)。make-symbol は全く新しいシン+-- ボルを作成し、obarray には登録しない。+--+-- :foo のようなのは keyword symbol と呼ばれており、自分自身に評価され+-- る。実態としてはただ単に : で前置されたシンボルである。++foreign import ccall _intern+ :: EmacsEnv+ -> CString+ -> IO EmacsValue++mkSymbol :: Text -> EmacsM EmacsValue+mkSymbol str = do+ s' <- lookupCache+ case s' of+ Just gev ->+ return (castGlobalToEmacsValue gev)+ Nothing ->+ storeToCache =<< create+ where+ lookupCache = do+ mapRef <- symbolMap <$> getPState+ map <- liftIO $ readIORef mapRef+ return $ Map.lookup str map++ -- TODO: 現在は全部入れているけど、これはまずい+ storeToCache ev = do+ mapRef <- symbolMap <$> getPState+ gev <- mkGlobalRef ev+ liftIO $ modifyIORef mapRef (Map.insert str gev)+ return (castGlobalToEmacsValue gev)++ create = do+ env <- getEnv+ checkExitStatus . withCString (toS str) $ \cstr -> _intern env cstr++-- 単一の値しかないので引数は不要。どうやって取得するだろ？+-- nil という定数が nil を持っている。+-- (symbol-value 'nil) でいけるかな。(eval 'nil) でもいいかも+--+-- TODO: キャッシュするべきだよね(キャッシュする場合は emacs_value を+-- emacs側でGCされないように global_ref を作る必要があるのかな？+mkNil :: EmacsM EmacsValue+mkNil = do+ q0 <- mkSymbol "symbol-value"+ q1 <- mkSymbol "nil"+ funcall q0 [q1]++-- そもそも list という型は emacs側には存在しない。+-- listp という関数があるが、これは cons もしくは nil かどうかを判定している。+--+-- 以下のナイーブな実装だと大量に emacs 側の関数呼び出しが必要になり、遅い。+--+-- mkList :: [EmacsValue] -> EmacsM EmacsValue+-- mkList evs = do+-- nil <- mkNil+-- foldrM mkCons nil evs++mkList :: [EmacsValue] -> EmacsM EmacsValue+mkList evs = do+ listQ <- mkSymbol "list"+ funcall listQ evs++foreign import ccall _make_global_ref+ :: EmacsEnv+ -> EmacsValue+ -> IO GlobalEmacsValue++mkGlobalRef :: EmacsValue -> EmacsM GlobalEmacsValue+mkGlobalRef ev = do+ env <- getEnv+ checkExitStatus $ _make_global_ref env ev++-- | 例外ハンドリング++foreign import ccall _non_local_exit_check+ :: EmacsEnv+ -> IO CInt++nonLocalExitCheck :: EmacsM EmacsFuncallExit+nonLocalExitCheck = do+ env <- getEnv+ toEnum . fromIntegral <$> liftIO (_non_local_exit_check env)++--+-- Emacs に戻ったときに signal を投げる。+foreign import ccall _non_local_exit_signal+ :: EmacsEnv+ -> EmacsValue+ -> EmacsValue+ -> IO ()++nonLocalExitSignal :: EmacsValue -> EmacsValue -> EmacsM ()+nonLocalExitSignal sym val = do+ env <- getEnv+ liftIO $ _non_local_exit_signal env sym val++foreign import ccall _non_local_exit_throw+ :: EmacsEnv+ -> EmacsValue+ -> EmacsValue+ -> IO ()++nonLocalExitThrow :: EmacsValue -> EmacsValue -> EmacsM ()+nonLocalExitThrow sym val = do+ env <- getEnv+ liftIO $ _non_local_exit_throw env sym val++foreign import ccall _non_local_exit_clear+ :: EmacsEnv+ -> IO ()++nonLocalExitClear :: EmacsM ()+nonLocalExitClear = do+ env <- getEnv+ liftIO $ _non_local_exit_clear env++-- 第二引数、第三引数に書き込まれることに注意。+foreign import ccall _non_local_exit_get+ :: EmacsEnv+ -> Ptr EmacsValue+ -> Ptr EmacsValue+ -> IO CInt++nonLocalExitGet :: EmacsM (EmacsFuncallExit,EmacsValue,EmacsValue)+nonLocalExitGet = do+ env <- getEnv+ liftIO $ do+ a0' <- malloc+ a1' <- malloc+ fe <- _non_local_exit_get env a0' a1'+ a0 <- peek a0'+ a1 <- peek a1'+ free a0'+ free a1'+ return (toEnum (fromIntegral fe), a0, a1)++-- | Emacs の+-- 呼び出しは symbol に限らないのか。関数の直接起動とか。++foreign import ccall _funcall+ :: EmacsEnv+ -> EmacsValue+ -> CPtrdiff+ -> Ptr EmacsValue+ -> IO EmacsValue++funcall :: EmacsValue -> [EmacsValue] -> EmacsM EmacsValue+funcall func args = do+ env <- getEnv+ checkExitStatus . withArray args $ \carr ->+ _funcall env func argsLen carr+ where+ argsLen = fromIntegral (length args) :: CPtrdiff
+ src/Emacs/Type.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+module Emacs.Type where++import Prelude(Show(..))+import Protolude hiding (show)+import Data.IORef+import GHC.Ptr+import Foreign.C.Types+import Foreign.StablePtr+import Control.Monad.Log+import Control.Monad.Reader+import Data.Data hiding(typeOf)++data PState = PState+ { symbolMap :: IORef (Map Text GlobalEmacsValue)+ }++data Ctx = Ctx+ { pstateStablePtr :: StablePtr PState+ , pstate :: PState+ , emacsEnv :: EmacsEnv+ }++type EmacsM =+ LoggingT Text (ReaderT Ctx IO)+++-- | nil について+--+-- emacs 内部では nil は文字列で表現できないシンボルとして定義されている。+-- globals.h+--+-- #define Qnil builtin_lisp_symbol (0)+--+-- type-of では取得できない。nil は型ではない？かな。多分 type_of に渡+-- すとエラーになる。+--+-- haskell では不便なので ENil という型を導入する。+data EmacsType = ESymbol+ | EInteger+ | EFunction+ | EString+ | ECons+ | ENil+ deriving (Show, Eq, Data)++-- これは emacs 側での正式な名前である必要がある。typeOf が依存してい+-- る。nil は若干嘘が入っている。nil という型は存在しない。+emacsTypeSymbolName :: EmacsType -> Text+emacsTypeSymbolName ESymbol = "symbol"+emacsTypeSymbolName EInteger = "integer"+emacsTypeSymbolName EFunction = "function"+emacsTypeSymbolName EString = "string"+emacsTypeSymbolName ECons = "cons"+emacsTypeSymbolName ENil = "nil" -- lie++emacsTypes :: [EmacsType]+emacsTypes = fromConstr <$> dataTypeConstrs (dataTypeOf ESymbol)++-- Singlton Types テクニック+-- 値と型を結び付けている+-- 現在は tagAs のところでしか使っていないのでオーバーキルかな。。+-- export しないほうがいいかも。internal だけに留めるかな？+-- data SEmacsType (et :: EmacsType) where+-- SESymbol :: SEmacsType 'ESymbol+-- SEInteger :: SEmacsType 'EInteger+-- SECons :: SEmacsType 'ECons+-- SENil :: SEmacsType 'ENil++-- emacsTypeValue :: SEmacsType b -> EmacsType+-- emacsTypeValue SESymbol = ESymbol+-- emacsTypeValue SEInteger = EInteger+++newtype EmacsEnv = EmacsEnv (Ptr ())+ deriving (Storable)+newtype EmacsValue = EmacsValue (Ptr ())+ deriving (Storable)+newtype GlobalEmacsValue = GlobalEmacsValue (Ptr ())+ deriving (Storable)++castGlobalToEmacsValue :: GlobalEmacsValue -> EmacsValue+castGlobalToEmacsValue (GlobalEmacsValue p) =+ EmacsValue p++-- type ESymbol = Tagged 'ESymbol EmacsValue+-- type EInteger = Tagged 'EInteger EmacsValue+-- type EFunction = Tagged 'EFunction EmacsValue+-- type EString = Tagged 'EString EmacsValue+-- type ECons = Tagged 'ECons EmacsValue+-- type ENil = Tagged 'ENil EmacsValue++-- | Emacs の値に対する Haskell の型+-- 数値や文字列は素直なんだけど、他+-- Nil は空 [] でいいのかな？+newtype Symbol = Symbol Text+data Nil = Nil+data Cons = Cons EmacsValue EmacsValue+newtype List = List [EmacsValue]++-- | 例外機構++data EmacsFuncallExit+ = EmacsFuncallExitReturn+ | EmacsFuncallExitSignal+ | EmacsFuncallExitThrow+ deriving (Show,Eq,Enum)++data EmacsException+ = EmacsException EmacsFuncallExit EmacsValue EmacsValue++instance Show EmacsException where+ show (EmacsException funcallExit _ _) =+ "EmacsException(" <> show funcallExit <> ")"++instance Exception EmacsException++-- | 関数定義のため必要な型++type EFunctionStub+ = EmacsEnv+ -> CPtrdiff+ -> Ptr (Ptr ())+ -> StablePtr PState+ -> IO EmacsValue++data InteractiveForm = InteractiveNoArgs++newtype Doc = Doc Text -- ドキュメント(関数など)+newtype Arity = Arity Int -- 関数アリティ
+ src/Emacs/Variable.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Emacs.Variable+ ( setVariable+ , variableValue+ , isVariableBounded+ ) where++import Emacs.Core+import Data.Text++setVariable :: ToEmacsValue a => Text -> a -> EmacsM EmacsValue+setVariable name val =+ funcall2 "set" (Symbol name) val++isVariableBounded :: Text -> EmacsM Bool+isVariableBounded name =+ isNotNil =<< funcall1 "boundp" (Symbol name)++variableValue :: Text -> EmacsM (Maybe EmacsValue)+variableValue name = do+ bounded <- isNotNil =<< funcall1 "boundp" (Symbol name)+ if bounded+ then Just <$> funcall1 "symbol-value" (Symbol name)+ else pure Nothing