haskelisp-0.1.0.0: src/Emacs/Core.hs

{-# 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"