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

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 -> EmacsModule
defmodule name mod ert = do
  env <- getEmacsEnvFromRT ert
  errorHandle env $ do
    ctx <- initCtx env
    runEmacsM ctx $ mod >> funcall1 "provide" (Symbol name)
  return 0

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

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]


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

-- 多相的な関数は駄目らしい(具体的な関数なら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"