{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
module Neovim.Plugin (
startPluginThreads,
wrapPlugin,
NeovimPlugin,
Plugin(..),
Synchronous(..),
CommandOption(..),
addAutocmd,
registerPlugin,
) where
import Neovim.API.String
import Neovim.Classes
import Neovim.Context
import Neovim.Context.Internal (FunctionType (..),
runNeovimInternal)
import qualified Neovim.Context.Internal as Internal
import Neovim.Plugin.Classes hiding (register)
import Neovim.Plugin.Internal
import Neovim.Plugin.IPC.Classes
import Neovim.RPC.FunctionCall
import Control.Applicative
import Control.Monad (foldM, void)
import Control.Monad.Trans.Resource hiding (register)
import Data.ByteString (ByteString)
import Data.ByteString.UTF8 (toString)
import Data.Foldable (forM_)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.MessagePack
import Data.Traversable (forM)
import System.Log.Logger
import UnliftIO.Async (Async, async, race)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (SomeException, try, catch)
import UnliftIO.STM
import Prelude
logger :: String
logger = "Neovim.Plugin"
startPluginThreads :: Internal.Config ()
-> [Neovim () NeovimPlugin]
-> IO (Either (Doc AnsiStyle) ([FunctionMapEntry],[Async ()]))
startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], [])
where
go :: ([FunctionMapEntry], [Async ()])
-> Neovim () NeovimPlugin
-> Neovim () ([FunctionMapEntry], [Async ()])
go (es, tids) iop = do
NeovimPlugin p <- iop
(es', tid) <- registerStatefulFunctionality p
return $ (es ++ es', tid:tids)
registerWithNeovim :: FunctionalityDescription -> Neovim anyEnv Bool
registerWithNeovim = \case
func@(Function (F functionName) s) -> do
pName <- getProviderName
let (defineFunction, host) = either
(\n -> ("remote#define#FunctionOnHost", toObject n))
(\c -> ("remote#define#FunctionOnChannel", toObject c))
pName
reportError (e :: NeovimException) = do
liftIO . errorM logger $
"Failed to register function: " ++ show functionName ++ show e
return False
logSuccess = do
liftIO . debugM logger $
"Registered function: " ++ show functionName
return True
flip catch reportError $ do
void $ vim_call_function defineFunction $
host +: nvimMethodName (nvimMethod func) +: s +: functionName +: (Map.empty :: Dictionary) +: []
logSuccess
cmd@(Command (F functionName) copts) -> do
let sync = case getCommandOptions copts of
(CmdSync s:_) -> s
_ -> Sync
pName <- getProviderName
let (defineFunction, host) = either
(\n -> ("remote#define#CommandOnHost", toObject n))
(\c -> ("remote#define#CommandOnChannel", toObject c))
pName
reportError (e :: NeovimException) = do
liftIO . errorM logger $
"Failed to register command: " ++ show functionName ++ show e
return False
logSuccess = do
liftIO . debugM logger $
"Registered command: " ++ show functionName
return True
flip catch reportError $ do
void $ vim_call_function defineFunction $
host +: nvimMethodName (nvimMethod cmd) +: sync +: functionName +: copts +: []
logSuccess
Autocmd acmdType (F functionName) sync opts -> do
pName <- getProviderName
let (defineFunction, host) = either
(\n -> ("remote#define#AutocmdOnHost", toObject n))
(\c -> ("remote#define#AutocmdOnChannel", toObject c))
pName
reportError (e :: NeovimException) = do
liftIO . errorM logger $
"Failed to register autocmd: " ++ show functionName ++ show e
return False
logSuccess = do
liftIO . debugM logger $
"Registered autocmd: " ++ show functionName
return True
flip catch reportError $ do
void $ vim_call_function defineFunction $
host +: functionName +: sync +: acmdType +: opts +: []
logSuccess
getProviderName :: Neovim env (Either String Int)
getProviderName = do
mp <- Internal.asks' Internal.providerName
(liftIO . atomically . tryReadTMVar) mp >>= \case
Just p ->
return p
Nothing -> do
api <- nvim_get_api_info
case api of
[] -> err "empty nvim_get_api_info"
(i:_) -> do
case fromObject i :: Either (Doc AnsiStyle) Int of
Left _ ->
err $ "Expected an integral value as the first"
<+> "argument of nvim_get_api_info"
Right channelId -> do
liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId
return . Right $ fromIntegral channelId
registerFunctionality :: FunctionalityDescription
-> ([Object] -> Neovim env Object)
-> Neovim env (Maybe (FunctionMapEntry, Either (Neovim anyEnv ()) ReleaseKey))
registerFunctionality d f = Internal.asks' Internal.pluginSettings >>= \case
Nothing -> do
liftIO $ errorM logger "Cannot register functionality in this context."
return Nothing
Just (Internal.StatefulSettings reg q m) ->
reg d f q m >>= \case
Just e -> do
cfg <- Internal.retypeConfig () <$> Internal.ask'
rk <- fst <$> allocate (return ()) (free cfg (fst e))
return $ Just (e, Right rk)
Nothing ->
return Nothing
where
freeFun = \case
Autocmd event _ _ AutocmdOptions{..} -> do
void . vim_command . unwords $ catMaybes
[ Just "autocmd!", acmdGroup
, Just (toString event) , Just acmdPattern
]
Command{} ->
liftIO $ warningM logger "Free not implemented for commands."
Function{} ->
liftIO $ warningM logger "Free not implemented for functions."
free cfg = const . void . liftIO . runNeovimInternal return cfg . freeFun
registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim env ()
registerInGlobalFunctionMap e = do
liftIO . debugM logger $ "Adding function to global function map." ++ show (fst e)
funMap <- Internal.asks' Internal.globalFunctionMap
liftIO . atomically $ do
m <- takeTMVar funMap
putTMVar funMap $ Map.insert ((nvimMethod . fst) e) e m
liftIO . debugM logger $ "Added function to global function map." ++ show (fst e)
registerPlugin
:: (FunctionMapEntry -> Neovim env ())
-> FunctionalityDescription
-> ([Object] -> Neovim env Object)
-> TQueue SomeMessage
-> TVar (Map NvimMethod ([Object] -> Neovim env Object))
-> Neovim env (Maybe FunctionMapEntry)
registerPlugin reg d f q tm = registerWithNeovim d >>= \case
True -> do
let n = nvimMethod d
e = (d, Stateful q)
liftIO . atomically . modifyTVar tm $ Map.insert n f
reg e
return (Just e)
False ->
return Nothing
addAutocmd :: ByteString
-> Synchronous
-> AutocmdOptions
-> (Neovim env ())
-> Neovim env (Maybe (Either (Neovim anyEnv ()) ReleaseKey))
addAutocmd event s (opts@AutocmdOptions{..}) f = do
n <- newUniqueFunctionName
fmap snd <$> registerFunctionality (Autocmd event n s opts) (\_ -> toObject <$> f)
registerStatefulFunctionality
:: Plugin env
-> Neovim anyEnv ([FunctionMapEntry], Async ())
registerStatefulFunctionality (Plugin { environment = env, exports = fs }) = do
messageQueue <- liftIO newTQueueIO
route <- liftIO $ newTVarIO Map.empty
cfg <- Internal.ask'
let startupConfig = cfg
{ Internal.customConfig = env
, Internal.pluginSettings = Just $ Internal.StatefulSettings
(registerPlugin (\_ -> return ())) messageQueue route
}
res <- liftIO . runNeovimInternal return startupConfig . forM fs $ \f ->
registerFunctionality (getDescription f) (getFunction f)
es <- case res of
Left e -> err e
Right a -> return $ catMaybes a
let pluginThreadConfig = cfg
{ Internal.customConfig = env
, Internal.pluginSettings = Just $ Internal.StatefulSettings
(registerPlugin registerInGlobalFunctionMap) messageQueue route
}
tid <- liftIO . async . void . runNeovim pluginThreadConfig $ do
listeningThread messageQueue route
return (map fst es, tid)
where
executeFunction
:: ([Object] -> Neovim env Object)
-> [Object]
-> Neovim env (Either String Object)
executeFunction f args = try (f args) >>= \case
Left e -> return . Left $ show (e :: SomeException)
Right res -> return $ Right res
timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String
timeoutAndLog seconds functionName = do
threadDelay (fromIntegral seconds * 1000 * 1000)
return . show $
pretty functionName <+> "has been aborted after"
<+> pretty seconds <+> "seconds"
listeningThread :: TQueue SomeMessage
-> TVar (Map NvimMethod ([Object] -> Neovim env Object))
-> Neovim env ()
listeningThread q route = do
msg <- readSomeMessage q
forM_ (fromMessage msg) $ \req@(Request fun@(F methodName) _ args) -> do
let method = NvimMethod methodName
route' <- liftIO $ readTVarIO route
forM_ (Map.lookup method route') $ \f -> do
respond req . either Left id =<< race
(timeoutAndLog 10 fun)
(executeFunction f args)
forM_ (fromMessage msg) $ \(Notification fun@(F methodName) args) -> do
let method = NvimMethod methodName
route' <- liftIO $ readTVarIO route
forM_ (Map.lookup method route') $ \f ->
void . async $ do
result <- either Left id <$> race
(timeoutAndLog 600 fun)
(executeFunction f args)
case result of
Left message ->
nvim_err_writeln message
Right _ ->
return ()
listeningThread q route