{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Neovim.RPC.EventHandler (
runEventHandler,
) where
import Neovim.Classes
import Neovim.Context
import qualified Neovim.Context.Internal as Internal
import Neovim.Plugin.IPC.Classes
import qualified Neovim.RPC.Classes as MsgpackRPC
import Neovim.RPC.Common
import Neovim.RPC.FunctionCall
import Control.Applicative
import Control.Concurrent.STM hiding (writeTQueue)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Conduit as C
import qualified Data.Map as Map
import Data.Serialize (encode)
import System.IO (Handle)
import System.Log.Logger
import Prelude
runEventHandler :: Handle
-> Internal.Config RPCConfig
-> IO ()
runEventHandler :: Handle -> Config RPCConfig -> IO ()
runEventHandler Handle
writeableHandle Config RPCConfig
env =
forall a. Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext Config RPCConfig
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ do
ConduitT () SomeMessage EventHandler ()
eventHandlerSource
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitM EncodedResponse o m ()
sinkHandleFlush Handle
writeableHandle)
newtype EventHandler a =
EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a)
deriving ( forall a b. a -> EventHandler b -> EventHandler a
forall a b. (a -> b) -> EventHandler a -> EventHandler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> EventHandler b -> EventHandler a
$c<$ :: forall a b. a -> EventHandler b -> EventHandler a
fmap :: forall a b. (a -> b) -> EventHandler a -> EventHandler b
$cfmap :: forall a b. (a -> b) -> EventHandler a -> EventHandler b
Functor, Functor EventHandler
forall a. a -> EventHandler a
forall a b. EventHandler a -> EventHandler b -> EventHandler a
forall a b. EventHandler a -> EventHandler b -> EventHandler b
forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. EventHandler a -> EventHandler b -> EventHandler a
$c<* :: forall a b. EventHandler a -> EventHandler b -> EventHandler a
*> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
$c*> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
liftA2 :: forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
$cliftA2 :: forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
<*> :: forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
$c<*> :: forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
pure :: forall a. a -> EventHandler a
$cpure :: forall a. a -> EventHandler a
Applicative, Applicative EventHandler
forall a. a -> EventHandler a
forall a b. EventHandler a -> EventHandler b -> EventHandler b
forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> EventHandler a
$creturn :: forall a. a -> EventHandler a
>> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
$c>> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
>>= :: forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
$c>>= :: forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
Monad, Monad EventHandler
forall a. IO a -> EventHandler a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> EventHandler a
$cliftIO :: forall a. IO a -> EventHandler a
MonadIO
, MonadReader (Internal.Config RPCConfig))
runEventHandlerContext
:: Internal.Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext :: forall a. Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext Config RPCConfig
env (EventHandler ResourceT (ReaderT (Config RPCConfig) IO) a
a) =
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT ResourceT (ReaderT (Config RPCConfig) IO) a
a) Config RPCConfig
env
eventHandlerSource :: ConduitT () SomeMessage EventHandler ()
eventHandlerSource :: ConduitT () SomeMessage EventHandler ()
eventHandlerSource = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env. Config env -> TQueue SomeMessage
Internal.eventQueue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TQueue SomeMessage
q ->
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
TQueue SomeMessage -> m SomeMessage
readSomeMessage TQueue SomeMessage
q
eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe SomeMessage
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just SomeMessage
message -> do
forall i.
(Maybe FunctionCall, Maybe Message)
-> ConduitM i EncodedResponse EventHandler ()
handleMessage (forall message. Message message => SomeMessage -> Maybe message
fromMessage SomeMessage
message, forall message. Message message => SomeMessage -> Maybe message
fromMessage SomeMessage
message)
ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler
type EncodedResponse = C.Flush ByteString
yield' :: (MonadIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io ()
yield' :: forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
o = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> IO ()
debugM [Char]
"EventHandler" forall a b. (a -> b) -> a -> b
$ [Char]
"Sending: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Message
o
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Flush a
Chunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall o. NvimObject o => o -> Object
toObject Message
o
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a. Flush a
Flush
handleMessage :: (Maybe FunctionCall, Maybe MsgpackRPC.Message)
-> ConduitM i EncodedResponse EventHandler ()
handleMessage :: forall i.
(Maybe FunctionCall, Maybe Message)
-> ConduitM i EncodedResponse EventHandler ()
handleMessage = \case
(Just (FunctionCall FunctionName
fn [Object]
params TMVar (Either Object Object)
reply UTCTime
time), Maybe Message
_) -> do
RPCConfig
cfg <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall env. Config env -> env
Internal.customConfig)
Int64
messageId <- forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' forall a b. (a -> b) -> a -> b
$ do
Int64
i <- forall a. TVar a -> STM a
readTVar (RPCConfig -> TVar Int64
nextMessageId RPCConfig
cfg)
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (RPCConfig -> TVar Int64
nextMessageId RPCConfig
cfg) forall a. Enum a => a -> a
succ
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients RPCConfig
cfg) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int64
i (UTCTime
time, TMVar (Either Object Object)
reply)
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
i
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' forall a b. (a -> b) -> a -> b
$ Request -> Message
MsgpackRPC.Request (FunctionName -> Int64 -> [Object] -> Request
Request FunctionName
fn Int64
messageId [Object]
params)
(Maybe FunctionCall
_, Just r :: Message
r@MsgpackRPC.Response{}) ->
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
r
(Maybe FunctionCall
_, Just n :: Message
n@MsgpackRPC.Notification{}) ->
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
n
(Maybe FunctionCall, Maybe Message)
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()