module Emacs.Core (
module Emacs.Internal,
defmodule,
mkCons,
ToEmacsValue(..),
ToEmacsSymbol(..),
ToEmacsFunction(..),
funcall1, funcall2, funcall3,
mkFunctionFromCallable,
Callable(..),
car,
cdr,
evalString,
provide,
message,
print,
) where
import Prelude()
import Protolude hiding (mkInteger,print)
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 EmacsValue where
toEv = pure
instance ToEmacsValue Int where
toEv = mkInteger
instance ToEmacsValue Text where
toEv = mkString
instance ToEmacsValue EmacsSymbol where
toEv = pure . asEmacsValue
instance ToEmacsValue Symbol where
toEv = (asEmacsValue<$>) . toEmacsSymbol
instance ToEmacsValue EmacsKeyword where
toEv = pure . asEmacsValue
instance ToEmacsValue Keyword where
toEv = (asEmacsValue<$>) . toEmacsKeyword
instance ToEmacsValue Bool where
toEv True = mkT
toEv False = mkNil
instance ToEmacsValue () where
toEv _ = mkNil
instance ToEmacsValue EmacsList where
toEv = pure . asEmacsValue
instance ToEmacsValue h => ToEmacsValue [h] where
toEv = (asEmacsValue<$>) . toEmacsList
instance ToEmacsValue EmacsCons where
toEv = pure . asEmacsValue
instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsValue (a, b) where
toEv = (asEmacsValue<$>) . toEmacsCons
instance ToEmacsValue EmacsFunction where
toEv = pure . asEmacsValue
instance (FromEmacsValue a, Callable b) => ToEmacsValue (a -> b) where
toEv = (asEmacsValue<$>) . toEmacsFunction
class AsEmacsValue s where asEmacsValue :: s -> EmacsValue
instance AsEmacsValue EmacsSymbol where asEmacsValue (EmacsSymbol ev) = ev
instance AsEmacsValue EmacsKeyword where asEmacsValue (EmacsKeyword ev) = ev
instance AsEmacsValue EmacsCons where asEmacsValue (EmacsCons ev) = ev
instance AsEmacsValue EmacsList where asEmacsValue (EmacsList ev) = ev
instance AsEmacsValue EmacsFunction where asEmacsValue (EmacsFunction ev) = ev
class ToEmacsValue s => ToEmacsSymbol s where
toEmacsSymbol :: s -> EmacsM EmacsSymbol
instance ToEmacsSymbol EmacsSymbol where
toEmacsSymbol = pure
instance ToEmacsSymbol Symbol where
toEmacsSymbol (Symbol t) = EmacsSymbol <$> intern t
class ToEmacsValue s => ToEmacsKeyword s where
toEmacsKeyword :: s -> EmacsM EmacsKeyword
instance ToEmacsKeyword EmacsKeyword where
toEmacsKeyword = pure
instance ToEmacsKeyword Keyword where
toEmacsKeyword (Keyword t) = EmacsKeyword <$> intern (":" <> t)
class ToEmacsValue s => ToEmacsCons s where
toEmacsCons :: s -> EmacsM EmacsCons
instance ToEmacsCons EmacsCons where
toEmacsCons = pure
instance (ToEmacsValue a, ToEmacsValue b) => ToEmacsCons (a, b) where
toEmacsCons (a,b) = do
av <- toEv a
bv <- toEv b
mkCons av bv
class ToEmacsValue s => ToEmacsList s where
toEmacsList :: s -> EmacsM EmacsList
instance ToEmacsList EmacsList where
toEmacsList = pure
instance ToEmacsValue x => ToEmacsList [x] where
toEmacsList xs = EmacsList <$> (join $ mkList <$> mapM toEv xs)
class (Callable s,ToEmacsValue s) => ToEmacsFunction s where
toEmacsFunction :: s -> EmacsM EmacsFunction
instance ToEmacsFunction EmacsFunction where
toEmacsFunction = pure
instance (FromEmacsValue a, Callable b) => ToEmacsFunction (a -> b) where
toEmacsFunction f = EmacsFunction <$> mkFunctionFromCallable f
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 h
instance FromEmacsValue Int where
fromEv = extractInteger
instance FromEmacsValue Text where
fromEv = extractString
instance FromEmacsValue EmacsValue where
fromEv = pure
instance FromEmacsValue EmacsFunction where
fromEv = pure . EmacsFunction
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
call (f av) es
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
print :: ToEmacsValue v => v -> EmacsM ()
print ev =
void $ funcall1 "print" ev
mkCons
:: (ToEmacsValue a, ToEmacsValue b)
=> a
-> b
-> EmacsM EmacsCons
mkCons a b =
EmacsCons <$> funcall2 "cons" a b
car :: EmacsValue -> EmacsM EmacsValue
car = funcall1 "car"
cdr :: EmacsValue -> EmacsM EmacsValue
cdr = funcall1 "cdr"