module Emacs.Core (
module Emacs.Internal,
defmodule,
mkCons,
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
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)
instance FromEmacsValue Int where
fromEv = extractIntegerMaybe
instance FromEmacsValue EmacsValue where
fromEv = pure . Just
class Callable a where
call :: a -> [EmacsValue] -> EmacsM (Either Text EmacsValue)
arity :: a -> Int
instance ToEmacsValue a => Callable a where
call a [] = Right <$> toEv a
call _ _ = pure $ Left "Too many arguments"
arity _ = 0
instance ToEmacsValue a => Callable (IO a) where
call a [] = do
v <- liftIO a
Right <$> toEv v
call _ _ = pure $ Left "Too many arguments"
arity _ = 0
instance ToEmacsValue a => Callable (EmacsM a) where
call am [] = do
a <- am
Right <$> toEv a
call _ _ = pure $ Left "Too many arguments"
arity _ = 0
instance (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"