{-# LANGUAGE LambdaCase #-}
{- |
Module      :  Neovim.RPC.SocketReader
Description :  The component which reads RPC messages from the neovim instance
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
-}
module Neovim.RPC.SocketReader (
    runSocketReader,
    parseParams,
) where

import Neovim.Classes ( Int64, NvimObject(toObject, fromObject) )
import Neovim.Context ( MonadIO(liftIO), asks, Neovim, runNeovim )
import qualified Neovim.Context.Internal as Internal
import Neovim.Plugin.Classes (
    CommandArguments (..),
    CommandOption (..),
    FunctionName (..),
    FunctionalityDescription (..),
    NeovimEventId (..),
    NvimMethod (..),
    Subscription (..),
    getCommandOptions,
 )
import Neovim.Plugin.IPC.Classes
    ( getCurrentTime,
      Notification(Notification),
      Request(Request),
      writeMessage )
import qualified Neovim.RPC.Classes as MsgpackRPC
import Neovim.RPC.Common ( RPCConfig(recipients) )
import Neovim.RPC.FunctionCall ( atomically' )

import Conduit as C
    ( Void,
      MonadTrans(lift),
      sourceHandle,
      (.|),
      awaitForever,
      runConduit,
      ConduitT )
import Control.Monad (void)
import Data.Conduit.Cereal (conduitGet2)
import Data.Default (def)
import Data.Foldable (foldl', forM_)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.MessagePack ( Object(ObjectArray) )
import qualified Data.Serialize (get)
import System.IO (Handle)
import System.Log.Logger ( debugM, errorM, warningM )
import UnliftIO (atomically, timeout, readTVarIO, modifyTVar', putTMVar, readTMVar, async, newEmptyTMVarIO, modifyTVar)

import Prelude

logger :: String
logger :: String
logger = String
"Socket Reader"

type SocketHandler = Neovim RPCConfig

{- | This function will establish a connection to the given socket and read
 msgpack-rpc events from it.
-}
runSocketReader ::
    Handle ->
    Internal.Config RPCConfig ->
    IO ()
runSocketReader :: Handle -> Config RPCConfig -> IO ()
runSocketReader Handle
readableHandle Config RPCConfig
cfg =
    IO (Either (Doc AnsiStyle) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Doc AnsiStyle) ()) -> IO ())
-> (ConduitT () Void SocketHandler ()
    -> IO (Either (Doc AnsiStyle) ()))
-> ConduitT () Void SocketHandler ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config RPCConfig
-> Neovim RPCConfig () -> IO (Either (Doc AnsiStyle) ())
forall a env.
NFData a =>
Config env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
runNeovim (RPCConfig -> Config RPCConfig -> Config RPCConfig
forall env anotherEnv. env -> Config anotherEnv -> Config env
Internal.retypeConfig (Config RPCConfig -> RPCConfig
forall env. Config env -> env
Internal.customConfig Config RPCConfig
cfg) Config RPCConfig
cfg) (Neovim RPCConfig () -> IO (Either (Doc AnsiStyle) ()))
-> (ConduitT () Void SocketHandler () -> Neovim RPCConfig ())
-> ConduitT () Void SocketHandler ()
-> IO (Either (Doc AnsiStyle) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void SocketHandler () -> Neovim RPCConfig ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void SocketHandler () -> IO ())
-> ConduitT () Void SocketHandler () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> ConduitT () ByteString SocketHandler ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
readableHandle
            ConduitT () ByteString SocketHandler ()
-> ConduitT ByteString Void SocketHandler ()
-> ConduitT () Void SocketHandler ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Get Object -> ConduitT ByteString Object SocketHandler ()
forall (m :: * -> *) o.
MonadThrow m =>
Get o -> ConduitT ByteString o m ()
conduitGet2 Get Object
forall t. Serialize t => Get t
Data.Serialize.get
            ConduitT ByteString Object SocketHandler ()
-> ConduitT Object Void SocketHandler ()
-> ConduitT ByteString Void SocketHandler ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Object Void SocketHandler ()
messageHandlerSink

{- | Sink that delegates the messages depending on their type.
 <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md>
-}
messageHandlerSink :: ConduitT Object Void SocketHandler ()
messageHandlerSink :: ConduitT Object Void SocketHandler ()
messageHandlerSink = (Object -> ConduitT Object Void SocketHandler ())
-> ConduitT Object Void SocketHandler ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Object -> ConduitT Object Void SocketHandler ())
 -> ConduitT Object Void SocketHandler ())
-> (Object -> ConduitT Object Void SocketHandler ())
-> ConduitT Object Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ \Object
rpc -> do
    IO () -> ConduitT Object Void SocketHandler ()
forall a. IO a -> ConduitT Object Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT Object Void SocketHandler ())
-> (String -> IO ())
-> String
-> ConduitT Object Void SocketHandler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
debugM String
logger (String -> ConduitT Object Void SocketHandler ())
-> String -> ConduitT Object Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ String
"Received: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a. Show a => a -> String
show Object
rpc
    case Object -> Either (Doc AnsiStyle) Message
forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
rpc of
        Right (MsgpackRPC.Request (Request FunctionName
fn Int64
i [Object]
ps)) ->
            Int64
-> FunctionName
-> [Object]
-> ConduitT Object Void SocketHandler ()
forall a.
Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest Int64
i FunctionName
fn [Object]
ps
        Right (MsgpackRPC.Response Int64
i Either Object Object
r) ->
            Int64
-> Either Object Object -> ConduitT Object Void SocketHandler ()
forall a.
Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()
handleResponse Int64
i Either Object Object
r
        Right (MsgpackRPC.Notification (Notification NeovimEventId
eventId [Object]
args)) ->
            NeovimEventId -> [Object] -> ConduitT Object Void SocketHandler ()
forall a.
NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification NeovimEventId
eventId [Object]
args
        Left Doc AnsiStyle
e ->
            IO () -> ConduitT Object Void SocketHandler ()
forall a. IO a -> ConduitT Object Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT Object Void SocketHandler ())
-> (String -> IO ())
-> String
-> ConduitT Object Void SocketHandler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
errorM String
logger (String -> ConduitT Object Void SocketHandler ())
-> String -> ConduitT Object Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ String
"Unhandled rpc message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> String
forall a. Show a => a -> String
show Doc AnsiStyle
e

handleResponse :: Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()
handleResponse :: forall a.
Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()
handleResponse Int64
i Either Object Object
result = do
    TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap <- (RPCConfig
 -> TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
-> ConduitT
     a
     Void
     SocketHandler
     (TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients
    Maybe (UTCTime, TMVar (Either Object Object))
mReply <- Int64
-> Map Int64 (UTCTime, TMVar (Either Object Object))
-> Maybe (UTCTime, TMVar (Either Object Object))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int64
i (Map Int64 (UTCTime, TMVar (Either Object Object))
 -> Maybe (UTCTime, TMVar (Either Object Object)))
-> ConduitT
     a
     Void
     SocketHandler
     (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> ConduitT
     a
     Void
     SocketHandler
     (Maybe (UTCTime, TMVar (Either Object Object)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> ConduitT
     a
     Void
     SocketHandler
     (Map Int64 (UTCTime, TMVar (Either Object Object)))
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> IO (Map Int64 (UTCTime, TMVar (Either Object Object)))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap)
    case Maybe (UTCTime, TMVar (Either Object Object))
mReply of
        Maybe (UTCTime, TMVar (Either Object Object))
Nothing ->
            IO () -> ConduitT a Void SocketHandler ()
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT a Void SocketHandler ())
-> IO () -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
logger String
"Received response but could not find a matching recipient."
        Just (UTCTime
_, TMVar (Either Object Object)
reply) -> do
            STM () -> ConduitT a Void SocketHandler ()
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' (STM () -> ConduitT a Void SocketHandler ())
-> ((Map Int64 (UTCTime, TMVar (Either Object Object))
     -> Map Int64 (UTCTime, TMVar (Either Object Object)))
    -> STM ())
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> ConduitT a Void SocketHandler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap ((Map Int64 (UTCTime, TMVar (Either Object Object))
  -> Map Int64 (UTCTime, TMVar (Either Object Object)))
 -> ConduitT a Void SocketHandler ())
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ Int64
-> Map Int64 (UTCTime, TMVar (Either Object Object))
-> Map Int64 (UTCTime, TMVar (Either Object Object))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int64
i
            STM () -> ConduitT a Void SocketHandler ()
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' (STM () -> ConduitT a Void SocketHandler ())
-> STM () -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either Object Object) -> Either Object Object -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either Object Object)
reply Either Object Object
result

lookupFunction ::
    Internal.Config RPCConfig ->
    FunctionName ->
    IO (Maybe (FunctionalityDescription, Internal.FunctionType))
lookupFunction :: Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
rpc (F Text
functionName) = do
    FunctionMap
functionMap <- STM FunctionMap -> IO FunctionMap
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically (STM FunctionMap -> IO FunctionMap)
-> STM FunctionMap -> IO FunctionMap
forall a b. (a -> b) -> a -> b
$ TMVar FunctionMap -> STM FunctionMap
forall a. TMVar a -> STM a
readTMVar (Config RPCConfig -> TMVar FunctionMap
forall env. Config env -> TMVar FunctionMap
Internal.globalFunctionMap Config RPCConfig
rpc)
    Maybe (FunctionalityDescription, FunctionType)
-> IO (Maybe (FunctionalityDescription, FunctionType))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FunctionalityDescription, FunctionType)
 -> IO (Maybe (FunctionalityDescription, FunctionType)))
-> Maybe (FunctionalityDescription, FunctionType)
-> IO (Maybe (FunctionalityDescription, FunctionType))
forall a b. (a -> b) -> a -> b
$ NvimMethod
-> FunctionMap -> Maybe (FunctionalityDescription, FunctionType)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> NvimMethod
NvimMethod Text
functionName) FunctionMap
functionMap

handleRequest :: Int64 -> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest :: forall a.
Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest Int64
requestId FunctionName
functionToCall [Object]
params = do
    Config RPCConfig
cfg <- SocketHandler (Config RPCConfig)
-> ConduitT a Void SocketHandler (Config RPCConfig)
forall (m :: * -> *) a. Monad m => m a -> ConduitT a Void m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SocketHandler (Config RPCConfig)
forall env. Neovim env (Config env)
Internal.ask'
    ConduitT a Void SocketHandler (Async (Maybe ()))
-> ConduitT a Void SocketHandler ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT a Void SocketHandler (Async (Maybe ()))
 -> ConduitT a Void SocketHandler ())
-> (IO (Maybe ())
    -> ConduitT a Void SocketHandler (Async (Maybe ())))
-> IO (Maybe ())
-> ConduitT a Void SocketHandler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async (Maybe ()))
-> ConduitT a Void SocketHandler (Async (Maybe ()))
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async (Maybe ()))
 -> ConduitT a Void SocketHandler (Async (Maybe ())))
-> (IO (Maybe ()) -> IO (Async (Maybe ())))
-> IO (Maybe ())
-> ConduitT a Void SocketHandler (Async (Maybe ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe ()) -> IO (Async (Maybe ()))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO (Maybe ()) -> ConduitT a Void SocketHandler ())
-> IO (Maybe ()) -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (Config RPCConfig -> IO ()
handle Config RPCConfig
cfg)
    () -> ConduitT a Void SocketHandler ()
forall a. a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    handle :: Internal.Config RPCConfig -> IO ()
    handle :: Config RPCConfig -> IO ()
handle Config RPCConfig
rpc =
        Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
rpc FunctionName
functionToCall IO (Maybe (FunctionalityDescription, FunctionType))
-> (Maybe (FunctionalityDescription, FunctionType) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (FunctionalityDescription, FunctionType)
Nothing -> do
                let errM :: String
errM = String
"No provider for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FunctionName -> String
forall a. Show a => a -> String
show FunctionName
functionToCall
                String -> String -> IO ()
debugM String
logger String
errM
                TQueue SomeMessage -> Message -> IO ()
forall (m :: * -> *) message.
(MonadUnliftIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage (Config RPCConfig -> TQueue SomeMessage
forall env. Config env -> TQueue SomeMessage
Internal.eventQueue Config RPCConfig
rpc) (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Int64 -> Either Object Object -> Message
MsgpackRPC.Response Int64
requestId (Object -> Either Object Object
forall a b. a -> Either a b
Left (String -> Object
forall o. NvimObject o => o -> Object
toObject String
errM))
            Just (FunctionalityDescription
copts, Internal.Stateful TQueue SomeMessage
c) -> do
                UTCTime
now <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                TMVar (Either Object Object)
reply <- IO (TMVar (Either Object Object))
-> IO (TMVar (Either Object Object))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar (Either Object Object))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
                let q :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
q = (RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients (RPCConfig
 -> TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
-> (Config RPCConfig -> RPCConfig)
-> Config RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config RPCConfig -> RPCConfig
forall env. Config env -> env
Internal.customConfig) Config RPCConfig
rpc
                IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
debugM String
logger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Executing stateful function with ID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
requestId
                STM () -> IO ()
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' (STM () -> IO ())
-> ((Map Int64 (UTCTime, TMVar (Either Object Object))
     -> Map Int64 (UTCTime, TMVar (Either Object Object)))
    -> STM ())
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
q ((Map Int64 (UTCTime, TMVar (Either Object Object))
  -> Map Int64 (UTCTime, TMVar (Either Object Object)))
 -> IO ())
-> (Map Int64 (UTCTime, TMVar (Either Object Object))
    -> Map Int64 (UTCTime, TMVar (Either Object Object)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Int64
-> (UTCTime, TMVar (Either Object Object))
-> Map Int64 (UTCTime, TMVar (Either Object Object))
-> Map Int64 (UTCTime, TMVar (Either Object Object))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int64
requestId (UTCTime
now, TMVar (Either Object Object)
reply)
                TQueue SomeMessage -> Request -> IO ()
forall (m :: * -> *) message.
(MonadUnliftIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
c (Request -> IO ()) -> Request -> IO ()
forall a b. (a -> b) -> a -> b
$ FunctionName -> Int64 -> [Object] -> Request
Request FunctionName
functionToCall Int64
requestId (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
params)

handleNotification :: NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification :: forall a.
NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification eventId :: NeovimEventId
eventId@(NeovimEventId Text
str) [Object]
args = do
    Config RPCConfig
cfg <- SocketHandler (Config RPCConfig)
-> ConduitT a Void SocketHandler (Config RPCConfig)
forall (m :: * -> *) a. Monad m => m a -> ConduitT a Void m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SocketHandler (Config RPCConfig)
forall env. Neovim env (Config env)
Internal.ask'
    IO (Maybe (FunctionalityDescription, FunctionType))
-> ConduitT
     a
     Void
     SocketHandler
     (Maybe (FunctionalityDescription, FunctionType))
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
cfg (Text -> FunctionName
F Text
str)) ConduitT
  a
  Void
  SocketHandler
  (Maybe (FunctionalityDescription, FunctionType))
-> (Maybe (FunctionalityDescription, FunctionType)
    -> ConduitT a Void SocketHandler ())
-> ConduitT a Void SocketHandler ()
forall a b.
ConduitT a Void SocketHandler a
-> (a -> ConduitT a Void SocketHandler b)
-> ConduitT a Void SocketHandler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (FunctionalityDescription
copts, Internal.Stateful TQueue SomeMessage
c) -> IO () -> ConduitT a Void SocketHandler ()
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT a Void SocketHandler ())
-> IO () -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ do
            String -> String -> IO ()
debugM String
logger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Executing function asynchronously: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
str
            TQueue SomeMessage -> Notification -> IO ()
forall (m :: * -> *) message.
(MonadUnliftIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
c (Notification -> IO ()) -> Notification -> IO ()
forall a b. (a -> b) -> a -> b
$ NeovimEventId -> [Object] -> Notification
Notification NeovimEventId
eventId (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
args)
        Maybe (FunctionalityDescription, FunctionType)
Nothing -> do
            IO () -> ConduitT a Void SocketHandler ()
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT a Void SocketHandler ())
-> IO () -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
logger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Handling event: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
str
            TMVar Subscriptions
subscriptions' <- SocketHandler (TMVar Subscriptions)
-> ConduitT a Void SocketHandler (TMVar Subscriptions)
forall (m :: * -> *) a. Monad m => m a -> ConduitT a Void m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SocketHandler (TMVar Subscriptions)
 -> ConduitT a Void SocketHandler (TMVar Subscriptions))
-> SocketHandler (TMVar Subscriptions)
-> ConduitT a Void SocketHandler (TMVar Subscriptions)
forall a b. (a -> b) -> a -> b
$ (Config RPCConfig -> TMVar Subscriptions)
-> SocketHandler (TMVar Subscriptions)
forall env a. (Config env -> a) -> Neovim env a
Internal.asks' Config RPCConfig -> TMVar Subscriptions
forall env. Config env -> TMVar Subscriptions
Internal.subscriptions
            [Subscription]
subscribers <- IO [Subscription] -> ConduitT a Void SocketHandler [Subscription]
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Subscription] -> ConduitT a Void SocketHandler [Subscription])
-> IO [Subscription]
-> ConduitT a Void SocketHandler [Subscription]
forall a b. (a -> b) -> a -> b
$
                STM [Subscription] -> IO [Subscription]
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically (STM [Subscription] -> IO [Subscription])
-> STM [Subscription] -> IO [Subscription]
forall a b. (a -> b) -> a -> b
$ do
                    Subscriptions
s <- TMVar Subscriptions -> STM Subscriptions
forall a. TMVar a -> STM a
readTMVar TMVar Subscriptions
subscriptions'
                    [Subscription] -> STM [Subscription]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Subscription] -> STM [Subscription])
-> [Subscription] -> STM [Subscription]
forall a b. (a -> b) -> a -> b
$ [Subscription] -> Maybe [Subscription] -> [Subscription]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Subscription] -> [Subscription])
-> Maybe [Subscription] -> [Subscription]
forall a b. (a -> b) -> a -> b
$ NeovimEventId
-> Map NeovimEventId [Subscription] -> Maybe [Subscription]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NeovimEventId
eventId (Subscriptions -> Map NeovimEventId [Subscription]
Internal.byEventId Subscriptions
s)
            [Subscription]
-> (Subscription -> ConduitT a Void SocketHandler ())
-> ConduitT a Void SocketHandler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Subscription]
subscribers ((Subscription -> ConduitT a Void SocketHandler ())
 -> ConduitT a Void SocketHandler ())
-> (Subscription -> ConduitT a Void SocketHandler ())
-> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ \Subscription
subscription -> IO () -> ConduitT a Void SocketHandler ()
forall a. IO a -> ConduitT a Void SocketHandler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT a Void SocketHandler ())
-> IO () -> ConduitT a Void SocketHandler ()
forall a b. (a -> b) -> a -> b
$ Subscription -> [Object] -> IO ()
subAction Subscription
subscription [Object]
args

parseParams :: FunctionalityDescription -> [Object] -> [Object]
parseParams :: FunctionalityDescription -> [Object] -> [Object]
parseParams (Function FunctionName
_ Synchronous
_) [Object]
args = case [Object]
args of
    -- Defining a function on the remote host creates a function that, that
    -- passes all arguments in a list. At the time of this writing, no other
    -- arguments are passed for such a function.
    --
    -- The function generating the function on neovim side is called:
    -- @remote#define#FunctionOnHost@
    [ObjectArray [Object]
fArgs] -> [Object]
fArgs
    [Object]
_ -> [Object]
args
parseParams cmd :: FunctionalityDescription
cmd@(Command FunctionName
_ CommandOptions
opts) [Object]
args = case [Object]
args of
    (ObjectArray [Object]
_ : [Object]
_) ->
        let cmdArgs :: [CommandOption]
cmdArgs = (CommandOption -> Bool) -> [CommandOption] -> [CommandOption]
forall a. (a -> Bool) -> [a] -> [a]
filter CommandOption -> Bool
isPassedViaRPC (CommandOptions -> [CommandOption]
getCommandOptions CommandOptions
opts)
            (CommandArguments
c, [Object]
args') = ((CommandArguments, [Object])
 -> (CommandOption, Object) -> (CommandArguments, [Object]))
-> (CommandArguments, [Object])
-> [(CommandOption, Object)]
-> (CommandArguments, [Object])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (CommandArguments, [Object])
-> (CommandOption, Object) -> (CommandArguments, [Object])
createCommandArguments (CommandArguments
forall a. Default a => a
def, []) ([(CommandOption, Object)] -> (CommandArguments, [Object]))
-> [(CommandOption, Object)] -> (CommandArguments, [Object])
forall a b. (a -> b) -> a -> b
$ [CommandOption] -> [Object] -> [(CommandOption, Object)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CommandOption]
cmdArgs [Object]
args
         in CommandArguments -> Object
forall o. NvimObject o => o -> Object
toObject CommandArguments
c Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [Object]
args'
    [Object]
_ -> FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
cmd [[Object] -> Object
ObjectArray [Object]
args]
  where
    isPassedViaRPC :: CommandOption -> Bool
    isPassedViaRPC :: CommandOption -> Bool
isPassedViaRPC = \case
        CmdSync{} -> Bool
False
        CommandOption
_ -> Bool
True

    -- Neovim passes arguments in a special form, depending on the
    -- CommandOption values used to export the (command) function (e.g. via
    -- 'command' or 'command'').
    createCommandArguments ::
        (CommandArguments, [Object]) ->
        (CommandOption, Object) ->
        (CommandArguments, [Object])
    createCommandArguments :: (CommandArguments, [Object])
-> (CommandOption, Object) -> (CommandArguments, [Object])
createCommandArguments old :: (CommandArguments, [Object])
old@(CommandArguments
c, [Object]
args') = \case
        (CmdRange RangeSpecification
_, Object
o) ->
            (Doc AnsiStyle -> (CommandArguments, [Object]))
-> ((Int, Int) -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) (Int, Int)
-> (CommandArguments, [Object])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((CommandArguments, [Object])
-> Doc AnsiStyle -> (CommandArguments, [Object])
forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\(Int, Int)
r -> (CommandArguments
c{range = Just r}, [Object]
args')) (Either (Doc AnsiStyle) (Int, Int) -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) (Int, Int)
-> (CommandArguments, [Object])
forall a b. (a -> b) -> a -> b
$ Object -> Either (Doc AnsiStyle) (Int, Int)
forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o
        (CmdCount Word
_, Object
o) ->
            (Doc AnsiStyle -> (CommandArguments, [Object]))
-> (Int -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) Int
-> (CommandArguments, [Object])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((CommandArguments, [Object])
-> Doc AnsiStyle -> (CommandArguments, [Object])
forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\Int
n -> (CommandArguments
c{count = Just n}, [Object]
args')) (Either (Doc AnsiStyle) Int -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) Int -> (CommandArguments, [Object])
forall a b. (a -> b) -> a -> b
$ Object -> Either (Doc AnsiStyle) Int
forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o
        (CommandOption
CmdBang, Object
o) ->
            (Doc AnsiStyle -> (CommandArguments, [Object]))
-> (Bool -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) Bool
-> (CommandArguments, [Object])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((CommandArguments, [Object])
-> Doc AnsiStyle -> (CommandArguments, [Object])
forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\Bool
b -> (CommandArguments
c{bang = Just b}, [Object]
args')) (Either (Doc AnsiStyle) Bool -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) Bool -> (CommandArguments, [Object])
forall a b. (a -> b) -> a -> b
$ Object -> Either (Doc AnsiStyle) Bool
forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o
        (CmdNargs String
"*", ObjectArray [Object]
os) ->
            -- CommandArguments -> [String] -> Neovim r st a
            (CommandArguments
c, [Object]
os)
        (CmdNargs String
"+", ObjectArray (Object
o : [Object]
os)) ->
            -- CommandArguments -> String -> [String] -> Neovim r st a
            (CommandArguments
c, Object
o Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [[Object] -> Object
ObjectArray [Object]
os])
        (CmdNargs String
"?", ObjectArray [Object
o]) ->
            -- CommandArguments -> Maybe String -> Neovim r st a
            (CommandArguments
c, [Maybe Object -> Object
forall o. NvimObject o => o -> Object
toObject (Object -> Maybe Object
forall a. a -> Maybe a
Just Object
o)])
        (CmdNargs String
"?", ObjectArray []) ->
            -- CommandArguments -> Maybe String -> Neovim r st a
            (CommandArguments
c, [Maybe Object -> Object
forall o. NvimObject o => o -> Object
toObject (Maybe Object
forall a. Maybe a
Nothing :: Maybe Object)])
        (CmdNargs String
"0", ObjectArray []) ->
            -- CommandArguments -> Neovim r st a
            (CommandArguments
c, [])
        (CmdNargs String
"1", ObjectArray [Object
o]) ->
            -- CommandArguments -> String -> Neovim r st a
            (CommandArguments
c, [Object
o])
        (CommandOption
CmdRegister, Object
o) ->
            (Doc AnsiStyle -> (CommandArguments, [Object]))
-> (String -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) String
-> (CommandArguments, [Object])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((CommandArguments, [Object])
-> Doc AnsiStyle -> (CommandArguments, [Object])
forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\String
r -> (CommandArguments
c{register = Just r}, [Object]
args')) (Either (Doc AnsiStyle) String -> (CommandArguments, [Object]))
-> Either (Doc AnsiStyle) String -> (CommandArguments, [Object])
forall a b. (a -> b) -> a -> b
$ Object -> Either (Doc AnsiStyle) String
forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o
        (CommandOption, Object)
_ -> (CommandArguments, [Object])
old
parseParams Autocmd{} [Object]
args = case [Object]
args of
    [ObjectArray [Object]
fArgs] -> [Object]
fArgs
    [Object]
_ -> [Object]
args