{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Neovim.Plugin (
startPluginThreads,
StartupConfig,
wrapPlugin,
NeovimPlugin,
Plugin(..),
Synchronous(..),
CommandOption(..),
addAutocmd,
registerPlugin,
) where
import Neovim.API.String
import Neovim.Classes
import Neovim.Config
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 qualified Neovim.Plugin.Startup as Plugin
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)
import UnliftIO.STM
import Prelude
logger :: String
logger = "Neovim.Plugin"
type StartupConfig = Plugin.StartupConfig NeovimConfig
startPluginThreads :: Internal.Config StartupConfig
-> [Neovim StartupConfig NeovimPlugin]
-> IO (Either (Doc AnsiStyle) ([FunctionMapEntry],[Async ()]))
startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], [])
where
go :: ([FunctionMapEntry], [Async ()])
-> Neovim StartupConfig NeovimPlugin
-> Neovim StartupConfig ([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
Function (F functionName) s -> do
pName <- getProviderName
let (defineFunction, host) = either
(\n -> ("remote#define#FunctionOnHost", toObject n))
(\c -> ("remote#define#FunctionOnChannel", toObject c))
pName
ret <- vim_call_function defineFunction $
host +: functionName +: s +: functionName +: (Map.empty :: Dictionary) +: []
case ret of
Left e -> do
liftIO . errorM logger $
"Failed to register function: " ++ show functionName ++ show e
return False
Right _ -> do
liftIO . debugM logger $
"Registered function: " ++ show functionName
return True
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
ret <- vim_call_function defineFunction $
host +: functionName +: sync +: functionName +: copts +: []
case ret of
Left e -> do
liftIO . errorM logger $
"Failed to register command: " ++ show functionName ++ show e
return False
Right _ -> do
liftIO . debugM logger $
"Registered command: " ++ show functionName
return True
Autocmd acmdType (F functionName) opts -> do
pName <- getProviderName
let (defineFunction, host) = either
(\n -> ("remote#define#AutocmdOnHost", toObject n))
(\c -> ("remote#define#AutocmdOnChannel", toObject c))
pName
ret <- vim_call_function defineFunction $
host +: functionName +: Async +: acmdType +: opts +: []
case ret of
Left e -> do
liftIO . errorM logger $
"Failed to register autocmd: " ++ show functionName ++ show e
return False
Right _ -> do
liftIO . debugM logger $
"Registered autocmd: " ++ show functionName
return True
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
Right (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
_ ->
err "Could not determine provider name."
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 ((name . 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 FunctionName ([Object] -> Neovim env Object))
-> Neovim env (Maybe FunctionMapEntry)
registerPlugin reg d f q tm = registerWithNeovim d >>= \case
True -> do
let n = name d
e = (d, Stateful q)
liftIO . atomically . modifyTVar tm $ Map.insert n f
reg e
return (Just e)
False ->
return Nothing
addAutocmd :: ByteString
-> AutocmdOptions
-> (Neovim env ())
-> Neovim env (Maybe (Either (Neovim anyEnv ()) ReleaseKey))
addAutocmd event (opts@AutocmdOptions{..}) f = do
n <- newUniqueFunctionName
fmap snd <$> registerFunctionality (Autocmd event n 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 FunctionName ([Object] -> Neovim env Object))
-> Neovim env ()
listeningThread q route = do
msg <- liftIO . atomically $ readTQueue q
forM_ (fromMessage msg) $ \req@Request{..} -> do
route' <- liftIO $ readTVarIO route
forM_ (Map.lookup reqMethod route') $ \f -> do
respond req . either Left id =<< race
(timeoutAndLog 10 reqMethod)
(executeFunction f reqArgs)
forM_ (fromMessage msg) $ \Notification{..} -> do
route' <- liftIO $ readTVarIO route
forM_ (Map.lookup notMethod route') $ \f ->
void . async $ do
result <- either Left id <$> race
(timeoutAndLog 600 notMethod)
(executeFunction f notArgs)
case result of
Left message ->
nvim_err_writeln' message
Right _ ->
return ()
listeningThread q route