module Neovim.Plugin (
startPluginThreads,
StartupConfig,
wrapPlugin,
NeovimPlugin,
Plugin(..),
Synchronous(..),
CommandOption(..),
addAutocmd,
addAutocmd',
registerInStatelessContext,
registerInStatefulContext,
) 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.Concurrent (ThreadId, forkIO)
import Control.Concurrent.STM
import Control.Monad (foldM, void)
import Control.Monad.Catch (SomeException, try)
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 Text.PrettyPrint.ANSI.Leijen (Doc)
import Prelude
logger :: String
logger = "Neovim.Plugin"
type StartupConfig = Plugin.StartupConfig NeovimConfig
startPluginThreads :: Internal.Config StartupConfig ()
-> [Neovim StartupConfig () NeovimPlugin]
-> IO (Either Doc ([FunctionMapEntry],[ThreadId]))
startPluginThreads cfg = fmap (fmap fst)
. runNeovimInternal return cfg ()
. foldM go ([], [])
where
go :: ([FunctionMapEntry], [ThreadId])
-> Neovim StartupConfig () NeovimPlugin
-> Neovim StartupConfig () ([FunctionMapEntry], [ThreadId])
go acc iop = do
NeovimPlugin p <- iop
(es, tids) <- foldl (\(es, tids) (es', tid) -> (es'++es, tid:tids)) acc
<$> mapM registerStatefulFunctionality (statefulExports p)
es' <- forM (exports p) $ \e -> do
registerInStatelessContext
(\_ -> return ())
(getDescription e)
(getFunction e)
return $ (catMaybes es' ++ es, tids)
registerWithNeovim :: FunctionalityDescription -> Neovim anyConfig anyState 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 r st (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 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 r st Object)
-> Neovim r st (Maybe (FunctionMapEntry, Either (Neovim anyR anySt ()) ReleaseKey))
registerFunctionality d f = Internal.asks' Internal.pluginSettings >>= \case
Nothing -> do
liftIO $ errorM logger "Cannot register functionality in this context."
return Nothing
Just (Internal.StatelessSettings reg) ->
reg d f >>= \case
Just e -> do
return $ Just (e, Left (freeFun (fst e)))
_ ->
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
registerInStatelessContext
:: (FunctionMapEntry -> Neovim r st ())
-> FunctionalityDescription
-> ([Object] -> Neovim' Object)
-> Neovim r st (Maybe FunctionMapEntry)
registerInStatelessContext reg d f = registerWithNeovim d >>= \case
False ->
return Nothing
True -> do
let e = (d, Stateless f)
reg e
return $ Just e
registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim r st ()
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)
registerInStatefulContext
:: (FunctionMapEntry -> Neovim r st ())
-> FunctionalityDescription
-> ([Object] -> Neovim r st Object)
-> TQueue SomeMessage
-> TVar (Map FunctionName ([Object] -> Neovim r st Object))
-> Neovim r st (Maybe FunctionMapEntry)
registerInStatefulContext 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 r st ())
-> Neovim r st (Maybe (Either (Neovim anyR anySt ()) ReleaseKey))
addAutocmd event (opts@AutocmdOptions{..}) f = do
n <- newUniqueFunctionName
fmap snd <$> registerFunctionality (Autocmd event n opts) (\_ -> toObject <$> f)
addAutocmd' :: ByteString
-> AutocmdOptions
-> Neovim' ()
-> Neovim r st (Maybe ReleaseKey)
addAutocmd' event opts f = do
n <- newUniqueFunctionName
void $ registerInStatelessContext
registerInGlobalFunctionMap
(Autocmd event n opts)
(\_ -> toObject <$> f)
return Nothing
registerStatefulFunctionality
:: StatefulFunctionality r st
-> Neovim anyconfig anyState ([FunctionMapEntry], ThreadId)
registerStatefulFunctionality (StatefulFunctionality r st fs) = do
q <- liftIO newTQueueIO
route <- liftIO $ newTVarIO Map.empty
cfg <- Internal.ask'
let startupConfig = cfg
{ Internal.customConfig = r
, Internal.pluginSettings = Just $ Internal.StatefulSettings
(registerInStatefulContext (\_ -> return ())) q route
}
res <- liftIO . runNeovimInternal return startupConfig st . 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 = r
, Internal.pluginSettings = Just $ Internal.StatefulSettings
(registerInStatefulContext registerInGlobalFunctionMap) q route
}
tid <- liftIO . forkIO . void . runNeovimInternal return pluginThreadConfig st $ do
listeningThread q route
return (map fst es, tid)
where
executeFunction
:: ([Object] -> Neovim r st Object)
-> [Object]
-> Neovim r st (Either String Object)
executeFunction f args = try (f args) >>= \case
Left e -> return . Left $ show (e :: SomeException)
Right res -> return $ Right res
listeningThread :: TQueue SomeMessage
-> TVar (Map FunctionName ([Object] -> Neovim r st Object))
-> Neovim r st ()
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 ->
respond req =<< executeFunction f reqArgs
forM_ (fromMessage msg) $ \Notification{..} -> do
route' <- liftIO $ readTVarIO route
forM_ (Map.lookup notMethod route') $ \f ->
void $ executeFunction f notArgs
listeningThread q route