Function.hs

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