module Neovim.RPC.EventHandler (
runEventHandler,
) where
import Neovim.Classes
import Neovim.Context hiding (ask, asks)
import Neovim.Plugin.IPC
import Neovim.Plugin.IPC.Internal
import Neovim.RPC.Common
import Neovim.RPC.FunctionCall
import Control.Applicative
import Control.Concurrent.STM hiding (writeTQueue)
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Conduit as C
import Data.Conduit.Binary (sinkHandle)
import qualified Data.Map as Map
import Data.MessagePack
import Data.Serialize (encode)
import System.IO (IOMode (WriteMode))
import System.Log.Logger
import Prelude
runEventHandler :: SocketType
-> ConfigWrapper RPCConfig
-> IO ()
runEventHandler socketType env =
runEventHandlerContext env $ do
h <- createHandle WriteMode socketType
eventHandlerSource
$= eventHandler
$$ addCleanup (cleanUpHandle h) (sinkHandle h)
newtype EventHandler a =
EventHandler (ResourceT (ReaderT (ConfigWrapper RPCConfig) (StateT Int64 IO)) a)
deriving ( Functor, Applicative, Monad, MonadState Int64, MonadIO
, MonadReader (ConfigWrapper RPCConfig))
runEventHandlerContext :: ConfigWrapper RPCConfig -> EventHandler a -> IO a
runEventHandlerContext env (EventHandler a) =
evalStateT (runReaderT (runResourceT a) env) 1
eventHandlerSource :: Source EventHandler SomeMessage
eventHandlerSource = asks _eventQueue >>= \q ->
forever $ yield =<< atomically' (readTQueue q)
eventHandler :: ConduitM SomeMessage ByteString EventHandler ()
eventHandler = await >>= \case
Nothing -> return ()
Just message -> handleMessage (fromMessage message) >> eventHandler
yield' :: (MonadIO io) => Object -> ConduitM i ByteString io ()
yield' o = do
liftIO . debugM "EventHandler" $ "Sending: " ++ show o
yield $ encode o
handleMessage :: Maybe RPCMessage -> ConduitM i ByteString EventHandler ()
handleMessage = \case
Just (FunctionCall fn params reply time) -> do
i <- get
modify succ
rs <- asks (recipients . customConfig)
atomically' . modifyTVar rs $ Map.insert i (time, reply)
yield' $ ObjectArray
[ toObject (0 :: Int64)
, ObjectInt i
, toObject fn
, toObject params
]
Just (Response i e res) ->
yield' $ ObjectArray
[ toObject (1 :: Int64)
, ObjectInt i
, toObject e
, toObject res
]
Just (NotificationCall fn params) ->
yield' $ ObjectArray
[ ObjectInt 2
, toObject fn
, toObject params
]
Nothing -> return ()