module Emacs.Internal (
module Emacs.Type,
initState,
initCtx,
getEnv,
runEmacsM,
getEmacsEnvFromRT,
typeOf,
isTypeOf,
extractInteger,
extractString,
eq,
isNotNil,
isNil,
mkFunction,
mkInteger,
mkString,
intern,
mkList,
mkNil,
mkT,
funcall,
errorHandle
) where
import Prelude()
import Protolude hiding (mkInteger)
import Control.Exception (displayException)
import Data.IORef
import Emacs.Type
import qualified Data.List as List
import qualified Data.Map as Map
import Foreign.C.Types
import Foreign.C.String
import Foreign.StablePtr
import Foreign.Storable
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import GHC.Ptr
import qualified GHC.Foreign as GHC
import GHC.IO.Encoding.UTF8 (utf8)
initState :: MonadIO m => m PState
initState = do
mapRef <- liftIO $ newIORef mempty
return $ PState mapRef
initCtx :: MonadIO m => EmacsEnv -> m Ctx
initCtx env = do
pstate <- initState
pstatep <- liftIO $ newStablePtr pstate
return $ Ctx pstatep pstate env
getPStateStablePtr :: EmacsM (StablePtr PState)
getPStateStablePtr =
pstateStablePtr <$> ask
getPState :: EmacsM PState
getPState =
pstate <$> ask
getEnv :: EmacsM EmacsEnv
getEnv =
emacsEnv <$> ask
runEmacsM :: MonadIO m => Ctx -> EmacsM a -> m a
runEmacsM ctx action =
liftIO $ runReaderT action ctx
foreign import ccall _get_emacs_env_from_rt
:: Ptr ()
-> IO EmacsEnv
getEmacsEnvFromRT :: Ptr () -> IO EmacsEnv
getEmacsEnvFromRT =
_get_emacs_env_from_rt
foreign import ccall _type_of
:: EmacsEnv
-> EmacsValue
-> IO EmacsValue
typeOf :: EmacsValue -> EmacsM EmacsType
typeOf ev = do
env <- getEnv
typeP <- checkExitStatus $ _type_of env ev
types <- forM emacsTypes $ \t -> do
q <- intern (emacsTypeSymbolName t)
b <- eq q typeP
return (b, t)
case List.find fst types of
Just (_, t) -> return t
Nothing -> error "no type"
isTypeOf :: EmacsType -> EmacsValue -> EmacsM Bool
isTypeOf ty ev = do
t <- typeOf ev
return $ t == ty
foreign import ccall _extract_integer
:: EmacsEnv
-> EmacsValue
-> IO CIntMax
extractInteger :: Num b => EmacsValue -> EmacsM b
extractInteger ev = do
env <- getEnv
i <- checkExitStatus $ _extract_integer env ev
return (fromIntegral i)
foreign import ccall _copy_string_contents
:: EmacsEnv
-> EmacsValue
-> CString
-> Ptr CPtrdiff
-> IO CInt
extractString :: EmacsValue -> EmacsM Text
extractString ev = do
env <- getEnv
checkExitStatus $ alloca $ \length' -> do
result <- _copy_string_contents env ev nullPtr length'
if result == 1
then do
length <- fromIntegral <$> peek length'
allocaBytes length $ \buffer -> do
result' <- _copy_string_contents env ev buffer length'
if result == 1
then toS <$> GHC.peekCString utf8 buffer
else pure ""
else pure ""
foreign import ccall _eq
:: EmacsEnv
-> EmacsValue
-> EmacsValue
-> IO CInt
eq :: EmacsValue -> EmacsValue -> EmacsM Bool
eq ev0 ev1 = do
env <- getEnv
r <- liftIO $ _eq env ev0 ev1
return (r == 1)
foreign import ccall _is_not_nil
:: EmacsEnv
-> EmacsValue
-> IO CInt
isNotNil :: EmacsValue -> EmacsM Bool
isNotNil ev = do
env <- getEnv
r <- liftIO $ _is_not_nil env ev
return (r == 1)
isNil :: EmacsValue -> EmacsM Bool
isNil = (fmap . fmap) not isNotNil
foreign import ccall _make_function
:: EmacsEnv
-> CPtrdiff
-> CPtrdiff
-> FunPtr EFunctionStub
-> CString
-> StablePtr a
-> IO EmacsValue
foreign import ccall "wrapper" wrapEFunctionStub
:: EFunctionStub
-> IO (FunPtr EFunctionStub)
mkFunction :: ([EmacsValue] -> EmacsM EmacsValue) -> Int -> Int -> Text -> EmacsM EmacsValue
mkFunction f minArity' maxArity' doc' = do
let minArity = fromIntegral minArity' :: CPtrdiff
maxArity = fromIntegral maxArity' :: CPtrdiff
datap <- getPStateStablePtr
stubp <- liftIO (wrapEFunctionStub stub)
env <- getEnv
checkExitStatus . withCString (toS doc') $ \doc ->
_make_function env minArity maxArity stubp doc datap
where
stub :: EFunctionStub
stub env nargs args pstatep = errorHandle env $ do
pstate <- deRefStablePtr pstatep
es <- fmap EmacsValue <$> peekArray (fromIntegral nargs) args
runEmacsM (Ctx pstatep pstate env) (f es)
errorHandle :: EmacsEnv -> IO EmacsValue -> IO EmacsValue
errorHandle env action =
action `catch` emacsExceptionHandler
`catch` haskellExceptionHandler
where
haskellExceptionHandler :: SomeException -> IO EmacsValue
haskellExceptionHandler e = do
ctx <- initCtx env
runEmacsM ctx $ do
funcallExit <- nonLocalExitCheck
nil <- mkNil
when (funcallExit == EmacsFuncallExitReturn) $ do
mes <- mkString (toS $ displayException e)
arg <- mkList [mes]
sym <- intern "haskell-error"
nonLocalExitSignal sym arg
return nil
emacsExceptionHandler :: EmacsException -> IO EmacsValue
emacsExceptionHandler e@(EmacsException funcallExit a0 a1) = do
let setter = case funcallExit of
EmacsFuncallExitSignal -> _non_local_exit_signal
EmacsFuncallExitThrow -> _non_local_exit_throw
setter env a0 a1
return a0
checkExitStatus :: IO a -> EmacsM a
checkExitStatus action = do
v <- liftIO action
funcallExit <- nonLocalExitCheck
when (funcallExit /= EmacsFuncallExitReturn) $ do
(_,a0,a1) <- nonLocalExitGet
nonLocalExitClear
liftIO . throwIO $ EmacsException funcallExit a0 a1
return v
foreign import ccall _make_integer
:: EmacsEnv
-> CIntMax
-> IO EmacsValue
mkInteger :: Integral n => n -> EmacsM EmacsValue
mkInteger i' = do
let i = fromIntegral i' :: CIntMax
env <- getEnv
checkExitStatus $ _make_integer env i
foreign import ccall _make_string
:: EmacsEnv
-> CString
-> CPtrdiff
-> IO EmacsValue
mkString :: Text -> EmacsM EmacsValue
mkString str = do
env <- getEnv
checkExitStatus . withCStringLen (toS str) $ \(cstr,len) ->
_make_string env cstr (fromIntegral len)
foreign import ccall _intern
:: EmacsEnv
-> CString
-> IO EmacsValue
intern :: Text -> EmacsM EmacsValue
intern str = do
s' <- lookupCache
case s' of
Just gev ->
return (castGlobalToEmacsValue gev)
Nothing ->
storeToCache =<< create
where
lookupCache = do
mapRef <- symbolMap <$> getPState
map <- liftIO $ readIORef mapRef
return $ Map.lookup str map
storeToCache ev = do
mapRef <- symbolMap <$> getPState
gev <- mkGlobalRef ev
liftIO $ modifyIORef mapRef (Map.insert str gev)
return (castGlobalToEmacsValue gev)
create = do
env <- getEnv
checkExitStatus . withCString (toS str) $ \cstr -> _intern env cstr
mkNil :: EmacsM EmacsValue
mkNil = do
q0 <- intern "symbol-value"
q1 <- intern "nil"
funcall q0 [q1]
mkT :: EmacsM EmacsValue
mkT = do
q0 <- intern "symbol-value"
q1 <- intern "t"
funcall q0 [q1]
mkList :: [EmacsValue] -> EmacsM EmacsValue
mkList evs = do
listQ <- intern "list"
funcall listQ evs
foreign import ccall _make_global_ref
:: EmacsEnv
-> EmacsValue
-> IO GlobalEmacsValue
mkGlobalRef :: EmacsValue -> EmacsM GlobalEmacsValue
mkGlobalRef ev = do
env <- getEnv
checkExitStatus $ _make_global_ref env ev
foreign import ccall _non_local_exit_check
:: EmacsEnv
-> IO CInt
nonLocalExitCheck :: EmacsM EmacsFuncallExit
nonLocalExitCheck = do
env <- getEnv
toEnum . fromIntegral <$> liftIO (_non_local_exit_check env)
foreign import ccall _non_local_exit_signal
:: EmacsEnv
-> EmacsValue
-> EmacsValue
-> IO ()
nonLocalExitSignal :: EmacsValue -> EmacsValue -> EmacsM ()
nonLocalExitSignal sym val = do
env <- getEnv
liftIO $ _non_local_exit_signal env sym val
foreign import ccall _non_local_exit_throw
:: EmacsEnv
-> EmacsValue
-> EmacsValue
-> IO ()
nonLocalExitThrow :: EmacsValue -> EmacsValue -> EmacsM ()
nonLocalExitThrow sym val = do
env <- getEnv
liftIO $ _non_local_exit_throw env sym val
foreign import ccall _non_local_exit_clear
:: EmacsEnv
-> IO ()
nonLocalExitClear :: EmacsM ()
nonLocalExitClear = do
env <- getEnv
liftIO $ _non_local_exit_clear env
foreign import ccall _non_local_exit_get
:: EmacsEnv
-> Ptr EmacsValue
-> Ptr EmacsValue
-> IO CInt
nonLocalExitGet :: EmacsM (EmacsFuncallExit,EmacsValue,EmacsValue)
nonLocalExitGet = do
env <- getEnv
liftIO $ do
a0' <- malloc
a1' <- malloc
fe <- _non_local_exit_get env a0' a1'
a0 <- peek a0'
a1 <- peek a1'
free a0'
free a1'
return (toEnum (fromIntegral fe), a0, a1)
foreign import ccall _funcall
:: EmacsEnv
-> EmacsValue
-> CPtrdiff
-> Ptr EmacsValue
-> IO EmacsValue
funcall :: EmacsValue -> [EmacsValue] -> EmacsM EmacsValue
funcall func args = do
env <- getEnv
checkExitStatus . withArray args $ \carr ->
_funcall env func argsLen carr
where
argsLen = fromIntegral (length args) :: CPtrdiff