haskelisp-0.1.0.1: src/Emacs/Core.hs

{-# LANGUAGE ForeignFunctionInterface,OverloadedStrings,DataKinds,TypeFamilies,KindSignatures,FlexibleInstances,UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}

module Emacs.Core (
    module Emacs.Internal,
    defmodule,
    -- mk
    mkCons,
    -- funcall
    ToEmacsValue(..),
    funcall1, funcall2, funcall3,
    mkFunctionFromCallable,
    Callable,
    --
    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) = intern name

instance ToEmacsValue Bool where
  toEv True  = mkT
  toEv False = mkNil

instance ToEmacsValue () where
  toEv _ = mkNil

instance ToEmacsValue EmacsValue where
  toEv = pure

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 <$> intern fname
                   <*> sequence [toEv ev0]

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 fname ev0 ev1 ev2 =
  join $ funcall <$> intern fname
                   <*> sequence [toEv ev0, toEv ev1, toEv ev2]


-- | Haskell <- EmacsValue
-- これは mkEFunction のために？
class FromEmacsValue h where
  fromEv :: EmacsValue -> EmacsM (Maybe h)

-- 何故か Num b => .. だと Overlapping で怒られる。分からん。。
instance FromEmacsValue Int where
  fromEv = extractIntegerMaybe

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 =
  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"