haskelisp 0.1.0.5 → 0.1.1.0

raw patch · 8 files changed

+387/−69 lines, 8 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +89/−0
• haskelisp.cabal +2/−1
• src/Emacs/Core.hs +157/−29
• src/Emacs/Function.hs +4/−7
• src/Emacs/Internal.hs +5/−11
• src/Emacs/NAdvice.hs +80/−0
• src/Emacs/Symbol.hs +34/−14
• src/Emacs/Type.hs +16/−7

@@ -3,6 +3,7 @@ Write Emacs module in Haskell, using Emacs 25's Dynamic Module feature.  * Only tested with linux.+* Only tested with Stack (LTS 6.26) * You need to build emacs with --with-modules configuration options * You need to specify some ghc-options to make it work @@ -12,6 +13,7 @@     module Main where      import Emacs+    import Foreign.C.Types      foreign export ccall "emacs_module_init" emacsModuleInit :: EmacsModule @@ -23,3 +25,90 @@       defun "square" $ \i -> do         message "haskell squre function called"         return $ (i*i :: Int)++    main :: IO ()+    main = undefined++# How to use++Explain using Stack and LTS 6.26 as premise.++## 1. Create a new project with Stack++    $ stack --resolver=lts-6.26 new mymodule++## 2. Change executable name to *.so and add haskelisp to the dependency++mymodule.cabal:++    executable mymodule.so+      hs-source-dirs:      app+      main-is:             Main.hs+      ghc-options:         -threaded -rtsopts -with-rtsopts=-N+      build-depends:       base+                         , mymodule+                         , haskelisp+      default-language:    Haskell2010++## 3. Change `ghc-options` and add `cc-options` to make shared library++mymodule.cabal:++    executable mymodule.so+      ...+      cc-options:          -fPIC+      ghc-options:         -shared -dynamic -fPIC -lHSrts-ghc7.10.3+      ...++## 4. Modules must be GPL compatible++The shared library must include `plugin_is_GPL_compatible` symbol to be loaded by Emacs.+Prepare a C source file and specify it with `c-sources` option.++    $ echo 'int plugin_is_GPL_compatible;' > plugin_is_GPL_compatible.c++mymodule.cabal:++    executable mymodule.so+      ...+      c-sources:           plugin_is_GPL_compatible.c+      ...++## 5. Write some code++Main.hs:++    {-# LANGUAGE ForeignFunctionInterface,OverloadedStrings #-}+    module Main where++    import Emacs+    import Foreign.C.Types++    foreign export ccall "emacs_module_init" emacsModuleInit :: EmacsModule++    emacsModuleInit :: EmacsModule+    emacsModuleInit = defmodule "mymodule" $ do++      defun "mysquare" $ \i -> do+        message "haskell squre function called"+        return $ (i*i :: Int)++    main :: IO ()+    main = undefined++We don't need `main` function, but without it cause a compile error,+so include a dummy one. It won't be called.++## 6. Build++    $ stack build++## 7. Copy the genereated shared library under `load-path`++For example, if `~/.emacs.d/lisp` is included in `load-path`:++    $ cp .stack-work/install/x86_64-linux/lts-6.26/7.10.3/bin/mymodule.so ~/.emacs.d/lisp/++## 8. Load your shared library++    (require 'mymodule)

@@ -1,5 +1,5 @@ name: haskelisp-version: 0.1.0.5+version: 0.1.1.0 cabal-version: >=1.10 build-type: Simple license: GPL-3@@ -30,6 +30,7 @@         Emacs.Core         Emacs.Function         Emacs.Command+        Emacs.NAdvice     build-depends:         base >=4.7 && <5,         protolude <0.2,

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface,OverloadedStrings,DataKinds,TypeFamilies,KindSignatures,FlexibleInstances,UndecidableInstances #-}+{-# LANGUAGE ForeignFunctionInterface,UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -10,9 +10,11 @@     mkCons,     -- funcall     ToEmacsValue(..),+    ToEmacsSymbol(..),+    ToEmacsFunction(..),     funcall1, funcall2, funcall3,     mkFunctionFromCallable,-    Callable,+    Callable(..),     --     car,     cdr,@@ -20,10 +22,11 @@     evalString,     provide,     message,+    print,     ) where  import Prelude()-import Protolude hiding (mkInteger)+import Protolude hiding (mkInteger,print) import Foreign.C.Types import Foreign.StablePtr import Emacs.Type@@ -38,68 +41,187 @@     runEmacsM ctx $ mod >> funcall1 "provide" (Symbol name)   return 0 +-- 関数の引数に ToEmacsValue を受け取るようにすると便利なんだけど、問+-- 題はその引数の実際の値を取得するめに EmacsM の中で実行する必要があ+-- り、引数の実行で例外が発生するかもしれない、ということ。+--+-- ある関数の中でEmacsException例外が発生したときにどのタイミングでど+-- こまで進んだかの保証が得られない。+-- ああ、けど IO での例外でも同じことが言えるのか... class ToEmacsValue h where   toEv :: h -> EmacsM EmacsValue +-- misc+-- EmacsM EmacsValue はどうなんだ... いいのかな？いいのであれば、+-- EmacsM EmacsSymbol とかも許容するべきかな。+-- いや、やはりないほうがいいかな。+instance ToEmacsValue EmacsValue where+  toEv = pure+-- instance ToEmacsValue (EmacsM EmacsValue) where+--   toEv = identity++-- Integer instance ToEmacsValue Int where   toEv = mkInteger +-- String instance ToEmacsValue Text where   toEv = mkString +-- Symbol+instance ToEmacsValue EmacsSymbol where+  toEv = pure . asEmacsValue instance ToEmacsValue Symbol where-  toEv (Symbol name) = intern name+  toEv = (asEmacsValue<$>) . toEmacsSymbol +-- Kwyword+instance ToEmacsValue EmacsKeyword where+  toEv = pure . asEmacsValue+instance ToEmacsValue Keyword where+  toEv = (asEmacsValue<$>) . toEmacsKeyword++-- Bool instance ToEmacsValue Bool where   toEv True  = mkT   toEv False = mkNil +-- Nil instance ToEmacsValue () where   toEv _ = mkNil -instance ToEmacsValue EmacsValue where-  toEv = pure-+-- List+instance ToEmacsValue EmacsList where+  toEv = pure . asEmacsValue instance ToEmacsValue h => ToEmacsValue [h] where-  toEv xs =-    join $ mkList <$> mapM toEv xs+  toEv = (asEmacsValue<$>) . toEmacsList -instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsValue (a,b) where-  toEv (a,b) = do+-- Cons+instance ToEmacsValue EmacsCons where+  toEv = pure . asEmacsValue+instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsValue (a, b) where+  toEv = (asEmacsValue<$>) . toEmacsCons++-- Function+-- Can only handle function with no arguments.+-- Use mkFunctionFromCallable for no args.+instance ToEmacsValue EmacsFunction where+  toEv = pure . asEmacsValue+instance (FromEmacsValue a, Callable b) => ToEmacsValue (a -> b) where+  toEv = (asEmacsValue<$>) . toEmacsFunction++-- AsEmacsValue+-- これはderiveしたいところ...+class    AsEmacsValue s             where asEmacsValue :: s -> EmacsValue+instance AsEmacsValue EmacsSymbol   where asEmacsValue (EmacsSymbol ev) = ev+instance AsEmacsValue EmacsKeyword  where asEmacsValue (EmacsKeyword ev) = ev+instance AsEmacsValue EmacsCons     where asEmacsValue (EmacsCons ev) = ev+instance AsEmacsValue EmacsList     where asEmacsValue (EmacsList ev) = ev+instance AsEmacsValue EmacsFunction where asEmacsValue (EmacsFunction ev) = ev++-- それぞれの OpaqueType への変換++-- Symbol+class ToEmacsValue s => ToEmacsSymbol s where+  toEmacsSymbol :: s -> EmacsM EmacsSymbol+instance ToEmacsSymbol EmacsSymbol where+  toEmacsSymbol = pure+instance ToEmacsSymbol Symbol      where+  toEmacsSymbol (Symbol t) = EmacsSymbol <$> intern t++-- Keyword+class ToEmacsValue s => ToEmacsKeyword s where+  toEmacsKeyword :: s -> EmacsM EmacsKeyword+instance ToEmacsKeyword EmacsKeyword where+  toEmacsKeyword = pure+instance ToEmacsKeyword Keyword where+  toEmacsKeyword (Keyword t) = EmacsKeyword <$> intern (":" <> t)++-- Cons+class ToEmacsValue s => ToEmacsCons s where+  toEmacsCons :: s -> EmacsM EmacsCons+instance ToEmacsCons EmacsCons where+  toEmacsCons = pure+instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsCons (a, b) where+  toEmacsCons (a,b) = do     av <- toEv a     bv <- toEv b     mkCons av bv -funcall1 :: (ToEmacsValue a)-         => Text -> a -> EmacsM EmacsValue+-- List+class ToEmacsValue s => ToEmacsList s where+  toEmacsList :: s -> EmacsM EmacsList+instance ToEmacsList EmacsList where+  toEmacsList = pure+instance ToEmacsValue x => ToEmacsList [x] where+  toEmacsList xs = EmacsList <$> (join $ mkList <$> mapM toEv xs)++-- Function+-- tricky+-- 無引数関数は明示的にやる必要ある。+class (Callable s,ToEmacsValue s) => ToEmacsFunction s where+  toEmacsFunction :: s -> EmacsM EmacsFunction++instance ToEmacsFunction EmacsFunction where+  toEmacsFunction = pure++instance (FromEmacsValue a, Callable b) => ToEmacsFunction (a -> b) where+  toEmacsFunction f = EmacsFunction <$> mkFunctionFromCallable f++-- Function call Utilities+funcall1+  :: ToEmacsValue a+  => Text+  -> a+  -> EmacsM EmacsValue funcall1 fname ev0 =   join $ funcall <$> intern fname                  <*> sequence [toEv ev0] -funcall2 :: (ToEmacsValue a, ToEmacsValue b)-         => Text -> a -> b -> EmacsM EmacsValue+funcall2+  :: (ToEmacsValue a, ToEmacsValue b)+  => Text+  -> a+  -> b+  -> EmacsM EmacsValue funcall2 fname ev0 ev1 =   join $ funcall <$> intern fname                  <*> sequence [toEv ev0, toEv ev1] -funcall3 :: (ToEmacsValue a, ToEmacsValue b, ToEmacsValue c)-         => Text -> a -> b -> c -> EmacsM EmacsValue+funcall3+  :: (ToEmacsValue a, ToEmacsValue b, ToEmacsValue c)+  => Text+  -> a+  -> b+  -> c+  -> EmacsM EmacsValue funcall3 fname ev0 ev1 ev2 =   join $ funcall <$> intern fname                  <*> sequence [toEv ev0, toEv ev1, toEv ev2] -+-- Emacs -> Haskell+-- 変換に失敗する場合は例外を飛ばすように+--+-- 現状 EmacsValue を返している関数を、 h を返すようにするのも便利かも+-- しれないが、明示的な型指定する必要が増えるかも。。。 class FromEmacsValue h where-  fromEv :: EmacsValue -> EmacsM (Maybe h)+  fromEv :: EmacsValue -> EmacsM h --- 何故か Num b => .. だと Overlapping で怒られる。分からん。。 instance FromEmacsValue Int where-  fromEv = extractIntegerMaybe+  fromEv = extractInteger +instance FromEmacsValue Text where+  fromEv = extractString+ instance FromEmacsValue EmacsValue where-  fromEv = pure . Just+  fromEv = pure +-- TODO: これいいのか？チェック必要ないか？+instance FromEmacsValue EmacsFunction where+  fromEv = pure . EmacsFunction++ -- 多相的な関数は駄目らしい(具体的な関数ならokらしい)+-- TODO: optional, rest 引数に対応する。 class Callable a where     call :: a -> [EmacsValue] -> EmacsM (Either Text EmacsValue)     arity :: a -> Int@@ -124,12 +246,9 @@     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 ""+    av <- fromEv e+    call (f av) es   call _ [] = pure $ Left "Too less arguments"   arity f = arity (f undefined) + 1 @@ -158,8 +277,17 @@ message t =   void $ funcall1 "message" t -mkCons :: EmacsValue -> EmacsValue -> EmacsM EmacsValue-mkCons = funcall2 "cons"+print :: ToEmacsValue v => v -> EmacsM ()+print ev =+  void $ funcall1 "print" ev++mkCons+  :: (ToEmacsValue a, ToEmacsValue b)+  => a+  -> b+  -> EmacsM EmacsCons+mkCons a b =+  EmacsCons <$> funcall2 "cons" a b  car :: EmacsValue -> EmacsM EmacsValue car = funcall1 "car"

@@ -1,21 +1,18 @@-{-# LANGUAGE ForeignFunctionInterface,OverloadedStrings,DataKinds,TypeFamilies,KindSignatures,FlexibleInstances,UndecidableInstances #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+ 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 に近い形で記述したいのであればこちら+--  より elisp に近い形で記述したいのであればこちら defun' :: Text -> Doc -> Arity -> ([EmacsValue] -> EmacsM EmacsValue) -> EmacsM () defun' name (Doc doc) (Arity arity) f =   setFunction name =<< mkFunction f arity arity doc

@@ -11,7 +11,6 @@     isTypeOf,     -- emacs -> haskell     extractInteger,-    extractIntegerMaybe,     extractString,     --     eq,@@ -118,13 +117,6 @@   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- -- emacs-module.c 参照 -- --  * Can throw signals(その場合 false が返る)@@ -219,7 +211,7 @@       es <- fmap EmacsValue <$> peekArray (fromIntegral nargs) args       runEmacsM (Ctx pstatep pstate env) (f es) --- | Haskell で投げられた例外の対応+-- Haskell で投げられた例外の対応 -- -- Emacs -> Haskell から呼ばれるところに設置する必要がある。例外が補足 -- できないと恐らく emacs がクラッシュする。非同期例外については考える@@ -321,7 +313,7 @@   checkExitStatus . withCStringLen (toS str) $ \(cstr,len) ->     _make_string env cstr (fromIntegral len) --- | Symbol+-- Symbol -- https://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Symbols.html -- -- intern という名前にしたのは不味い気がしてきた。elispには intern@@ -337,6 +329,8 @@   -> CString   -> IO EmacsValue +-- TODO: キャッシュするのは不味い気がしてきた。滅多にないとは思うけど、+-- unintern された場合にの動きが問題となる。 intern :: Text -> EmacsM EmacsValue intern str = do   s' <- lookupCache@@ -397,7 +391,7 @@   env <- getEnv   checkExitStatus $ _make_global_ref env ev --- | 例外ハンドリング+-- 例外ハンドリング  foreign import ccall _non_local_exit_check  :: EmacsEnv

@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+module Emacs.NAdvice where++import Prelude()+import Protolude+import Emacs.Core++-- Emacs 24 からアドバイスの機構が一新された(nadvice.el)。以前より大幅+-- にシンプルになっている。必要な関数は `advice-add` と+-- `advice-remove` の二つ。++-- (advice-add SYMBOL WHERE FUNCTION &optional PROPS)+--+-- Like ‘add-function’ but for the function named SYMBOL.+-- Contrary to ‘add-function’, this will properly handle the cases where SYMBOL+-- is defined as a macro, alias, command, ...+--+-- TODO: PROPSについては `add-function` のヘルプを参照++-- 基本的に Arround 一つで全て実装できる。+--+--  `:before'       (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r))+--  `:after'        (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r)))+--  `:around'       (lambda (&rest r) (apply FUNCTION OLDFUN r))+--  `:override'     (lambda (&rest r) (apply FUNCTION r))+--  `:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r)))+--  `:before-until' (lambda (&rest r) (or  (apply FUNCTION r) (apply OLDFUN r)))+--  `:after-while'  (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r)))+--  `:after-until'  (lambda (&rest r) (or  (apply OLDFUN r) (apply FUNCTION r)))+--  `:filter-args'  (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r)))+--  `:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r)))+--+data Where+  = Around+  | Before+  | After+  | Override+  | BeforeWhile+  | BeforeUntil+  | AfterWhile+  | AfterUntil+  | FilterArgs+  | FIlterReturn++whereToKeyword :: Where -> Keyword+whereToKeyword Around = Keyword "around"+whereToKeyword Before = Keyword "before"++-- TODO: FUNCTION は シンボルでないと駄目？ -> いや、関数でもOK+-- 存在しないシンボルに対しても設定できる。+adviceAdd'+  :: (ToEmacsSymbol s, ToEmacsFunction f)+  => s+  -> Where+  -> f+  -> EmacsM ()+adviceAdd' target where' func =+  void $ funcall3 "advice-add" target (whereToKeyword where') func++-- 基本的にこの関数さえあれば何でもできる。+-- TODO: アドバイス外せるように+around' :: Callable f => Text -> (EmacsFunction -> f) -> EmacsM ()+around' name ff = do+  adviceAdd' (Symbol name) Around ff++-- aroundアドバイスの場合、大抵は引数は弄らない。ショートカット的。+-- TODO:+around :: Callable f => Text -> (EmacsM EmacsValue -> f) -> EmacsM ()+around name ff = do+  adviceAdd' (Symbol name) Around =<< wrap ff+  where+    wrap :: Callable f => (EmacsM EmacsValue -> f) -> EmacsM EmacsFunction+    wrap newf =+      let wf :: [EmacsValue] -> EmacsM EmacsValue+          wf (func:args) = do+            res <- call (newf (funcall func args)) args+            case res of+              Right ev -> return ev+              Left   _ -> undefined+      in EmacsFunction <$> mkFunction wf 0 1000 "around advice"

@@ -6,43 +6,63 @@ import Emacs.Core import Data.IORef --- | All symbols+-- All symbols -- -- obarray に設定されている全てのシンボルを取得する。 -- Use `mapatoms` functoin. allSymbols :: EmacsM [EmacsValue] allSymbols = do   ref <- liftIO $ newIORef []-  funcall1 "mapatoms" =<< mkFunctionFromCallable (accum ref)+  -- funcall1 "mapatoms" =<< mkFunctionFromCallable (accum ref)+  funcall1 "mapatoms" (accum ref)   liftIO $ readIORef ref   where     accum :: IORef [EmacsValue] -> EmacsValue -> IO ()     accum ref sym = modifyIORef ref (sym:) --- | Symbol has four slots?+-- Symbol has four slots.+--+--  1. name+--  2. value (* can have buffer local value)+--  3. function+--  4. property list (* can have buffer local list) -setVal :: ToEmacsValue a => Text -> a -> EmacsM EmacsValue-setVal name val =+getSymbolName :: Text -> EmacsM Text+getSymbolName name =+  extractString =<< funcall1 "symbol-name" (Symbol name)++setValue :: ToEmacsValue a => Text -> a -> EmacsM EmacsValue+setValue name val =   funcall2 "set" (Symbol name) val +-- Could throw exception if the symbol is not setted.+getValue :: Text -> EmacsM EmacsValue+getValue name =+  funcall1 "symbol-value" (Symbol name)++-- if Symbol exists (included in obarray) and a value is bounded. isBounded :: Text -> EmacsM Bool isBounded name =   isNotNil =<< funcall1 "boundp" (Symbol name) -getVal :: Text -> EmacsM (Maybe EmacsValue)-getVal name = do-  bounded <- isNotNil =<< funcall1 "boundp" (Symbol name)-  if bounded-    then Just <$> funcall1 "symbol-value" (Symbol name)-    else pure Nothing+-- Buffer local+--+-- If the variable is buffer local, you need to use+-- getDefaultValue/setDefaultValue to set/get the global variable.+getDefaultValue :: Text -> EmacsM EmacsValue+getDefaultValue name =+  funcall1 "default-value" (Symbol name) --- | Keyword Symbol+setDefaultValue :: ToEmacsValue a => Text -> a -> EmacsM EmacsValue+setDefaultValue name val =+  funcall2 "set-default" (Symbol name) val --- | シンボルは任意の属性を持つことができる。+--  Keyword Symbol++--  シンボルは任意の属性を持つことができる。 -- -- 属性テーブルは シンボルと任意の値に間のハッシュである。 -- ただし値として nil は設定できない。未設定とnil に設定は区別されない。- symbolProperty :: Text -> Text -> EmacsM (Maybe EmacsValue) symbolProperty name property = do   ev <- funcall2 "get" (Symbol name) (Symbol property)

@@ -25,7 +25,7 @@ type EmacsM =   ReaderT Ctx IO --- | nil について+-- nil について -- -- emacs 内部では nil は文字列で表現できないシンボルとして定義されている。 -- globals.h@@ -73,15 +73,24 @@ castGlobalToEmacsValue (GlobalEmacsValue p) =   EmacsValue p --- | Emacs の値に対する Haskell の型+-- EmacsValue Opaque Type :w+--+-- これは導入するべきなのか？+-- 少なくともこれにラップする際は確実に保証できるときのみに+newtype EmacsSymbol   = EmacsSymbol   EmacsValue+newtype EmacsKeyword  = EmacsKeyword  EmacsValue+newtype EmacsCons     = EmacsCons     EmacsValue+newtype EmacsFunction = EmacsFunction EmacsValue+newtype EmacsList     = EmacsList     EmacsValue++-- Emacs の値に対する Haskell の型 -- 数値や文字列は素直なんだけど、他 -- Nil は空 [] でいいのかな？ newtype Symbol = Symbol Text-data Nil       = Nil-data Cons      = Cons EmacsValue EmacsValue-newtype List   = List [EmacsValue]+newtype Keyword = Keyword Text+data Cons = Cons EmacsValue EmacsValue --- | 例外機構+-- 例外機構  data EmacsFuncallExit   = EmacsFuncallExitReturn@@ -98,7 +107,7 @@  instance Exception EmacsException --- | 関数定義のため必要な型+-- 関数定義のため必要な型  type EFunctionStub   = EmacsEnv