{-# 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 =
Config RPCConfig -> EventHandler () -> IO ()
forall a. Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext Config RPCConfig
env (EventHandler () -> IO ())
-> (ConduitT () Void EventHandler () -> EventHandler ())
-> ConduitT () Void EventHandler ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void EventHandler () -> EventHandler ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void EventHandler () -> IO ())
-> ConduitT () Void EventHandler () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ConduitT () SomeMessage EventHandler ()
eventHandlerSource
ConduitT () SomeMessage EventHandler ()
-> ConduitM SomeMessage Void EventHandler ()
-> ConduitT () Void EventHandler ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler
ConduitM SomeMessage EncodedResponse EventHandler ()
-> ConduitM EncodedResponse Void EventHandler ()
-> ConduitM SomeMessage Void EventHandler ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Handle -> ConduitM EncodedResponse Void EventHandler ()
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 ( a -> EventHandler b -> EventHandler a
(a -> b) -> EventHandler a -> EventHandler b
(forall a b. (a -> b) -> EventHandler a -> EventHandler b)
-> (forall a b. a -> EventHandler b -> EventHandler a)
-> Functor EventHandler
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
<$ :: a -> EventHandler b -> EventHandler a
$c<$ :: forall a b. a -> EventHandler b -> EventHandler a
fmap :: (a -> b) -> EventHandler a -> EventHandler b
$cfmap :: forall a b. (a -> b) -> EventHandler a -> EventHandler b
Functor, Functor EventHandler
a -> EventHandler a
Functor EventHandler
-> (forall a. a -> EventHandler a)
-> (forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b)
-> (forall a b c.
(a -> b -> c)
-> EventHandler a -> EventHandler b -> EventHandler c)
-> (forall a b. EventHandler a -> EventHandler b -> EventHandler b)
-> (forall a b. EventHandler a -> EventHandler b -> EventHandler a)
-> Applicative EventHandler
EventHandler a -> EventHandler b -> EventHandler b
EventHandler a -> EventHandler b -> EventHandler a
EventHandler (a -> b) -> EventHandler a -> EventHandler b
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
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
<* :: EventHandler a -> EventHandler b -> EventHandler a
$c<* :: forall a b. EventHandler a -> EventHandler b -> EventHandler a
*> :: EventHandler a -> EventHandler b -> EventHandler b
$c*> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
liftA2 :: (a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
$cliftA2 :: forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
<*> :: EventHandler (a -> b) -> EventHandler a -> EventHandler b
$c<*> :: forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
pure :: a -> EventHandler a
$cpure :: forall a. a -> EventHandler a
$cp1Applicative :: Functor EventHandler
Applicative, Applicative EventHandler
a -> EventHandler a
Applicative EventHandler
-> (forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b)
-> (forall a b. EventHandler a -> EventHandler b -> EventHandler b)
-> (forall a. a -> EventHandler a)
-> Monad EventHandler
EventHandler a -> (a -> EventHandler b) -> EventHandler b
EventHandler a -> EventHandler b -> EventHandler b
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 :: a -> EventHandler a
$creturn :: forall a. a -> EventHandler a
>> :: EventHandler a -> EventHandler b -> EventHandler b
$c>> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
>>= :: EventHandler a -> (a -> EventHandler b) -> EventHandler b
$c>>= :: forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
$cp1Monad :: Applicative EventHandler
Monad, Monad EventHandler
Monad EventHandler
-> (forall a. IO a -> EventHandler a) -> MonadIO EventHandler
IO a -> EventHandler a
forall a. IO a -> EventHandler a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> EventHandler a
$cliftIO :: forall a. IO a -> EventHandler a
$cp1MonadIO :: Monad EventHandler
MonadIO
, MonadReader (Internal.Config RPCConfig))
runEventHandlerContext
:: Internal.Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext :: Config RPCConfig -> EventHandler a -> IO a
runEventHandlerContext Config RPCConfig
env (EventHandler ResourceT (ReaderT (Config RPCConfig) IO) a
a) =
ReaderT (Config RPCConfig) IO a -> Config RPCConfig -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ResourceT (ReaderT (Config RPCConfig) IO) a
-> ReaderT (Config RPCConfig) IO a
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 = (Config RPCConfig -> TQueue SomeMessage)
-> ConduitT () SomeMessage EventHandler (TQueue SomeMessage)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config RPCConfig -> TQueue SomeMessage
forall env. Config env -> TQueue SomeMessage
Internal.eventQueue ConduitT () SomeMessage EventHandler (TQueue SomeMessage)
-> (TQueue SomeMessage -> ConduitT () SomeMessage EventHandler ())
-> ConduitT () SomeMessage EventHandler ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TQueue SomeMessage
q ->
ConduitT () SomeMessage EventHandler ()
-> ConduitT () SomeMessage EventHandler ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConduitT () SomeMessage EventHandler ()
-> ConduitT () SomeMessage EventHandler ())
-> ConduitT () SomeMessage EventHandler ()
-> ConduitT () SomeMessage EventHandler ()
forall a b. (a -> b) -> a -> b
$ SomeMessage -> ConduitT () SomeMessage EventHandler ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (SomeMessage -> ConduitT () SomeMessage EventHandler ())
-> ConduitT () SomeMessage EventHandler SomeMessage
-> ConduitT () SomeMessage EventHandler ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TQueue SomeMessage
-> ConduitT () SomeMessage EventHandler SomeMessage
forall (m :: * -> *).
MonadIO m =>
TQueue SomeMessage -> m SomeMessage
readSomeMessage TQueue SomeMessage
q
eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()
eventHandler = ConduitT
SomeMessage EncodedResponse EventHandler (Maybe SomeMessage)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT
SomeMessage EncodedResponse EventHandler (Maybe SomeMessage)
-> (Maybe SomeMessage
-> ConduitM SomeMessage EncodedResponse EventHandler ())
-> ConduitM SomeMessage EncodedResponse EventHandler ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe SomeMessage
Nothing ->
() -> ConduitM SomeMessage EncodedResponse EventHandler ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just SomeMessage
message -> do
(Maybe FunctionCall, Maybe Message)
-> ConduitM SomeMessage EncodedResponse EventHandler ()
forall i.
(Maybe FunctionCall, Maybe Message)
-> ConduitM i EncodedResponse EventHandler ()
handleMessage (SomeMessage -> Maybe FunctionCall
forall message. Message message => SomeMessage -> Maybe message
fromMessage SomeMessage
message, SomeMessage -> Maybe 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' :: Message -> ConduitM i EncodedResponse io ()
yield' Message
o = do
IO () -> ConduitM i EncodedResponse io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitM i EncodedResponse io ())
-> (String -> IO ()) -> String -> ConduitM i EncodedResponse io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
debugM String
"EventHandler" (String -> ConduitM i EncodedResponse io ())
-> String -> ConduitM i EncodedResponse io ()
forall a b. (a -> b) -> a -> b
$ String
"Sending: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message -> String
forall a. Show a => a -> String
show Message
o
EncodedResponse -> ConduitM i EncodedResponse io ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (EncodedResponse -> ConduitM i EncodedResponse io ())
-> (Object -> EncodedResponse)
-> Object
-> ConduitM i EncodedResponse io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> EncodedResponse
forall a. a -> Flush a
Chunk (ByteString -> EncodedResponse)
-> (Object -> ByteString) -> Object -> EncodedResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> ByteString
forall a. Serialize a => a -> ByteString
encode (Object -> ConduitM i EncodedResponse io ())
-> Object -> ConduitM i EncodedResponse io ()
forall a b. (a -> b) -> a -> b
$ Message -> Object
forall o. NvimObject o => o -> Object
toObject Message
o
EncodedResponse -> ConduitM i EncodedResponse io ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield EncodedResponse
forall a. Flush a
Flush
handleMessage :: (Maybe FunctionCall, Maybe MsgpackRPC.Message)
-> ConduitM i EncodedResponse EventHandler ()
handleMessage :: (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 <- (Config RPCConfig -> RPCConfig)
-> ConduitT i EncodedResponse EventHandler RPCConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config RPCConfig -> RPCConfig
forall env. Config env -> env
Internal.customConfig)
Int64
messageId <- STM Int64 -> ConduitT i EncodedResponse EventHandler Int64
forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' (STM Int64 -> ConduitT i EncodedResponse EventHandler Int64)
-> STM Int64 -> ConduitT i EncodedResponse EventHandler Int64
forall a b. (a -> b) -> a -> b
$ do
Int64
i <- TVar Int64 -> STM Int64
forall a. TVar a -> STM a
readTVar (RPCConfig -> TVar Int64
nextMessageId RPCConfig
cfg)
TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (RPCConfig -> TVar Int64
nextMessageId RPCConfig
cfg) Int64 -> Int64
forall a. Enum a => a -> a
succ
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' (RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients RPCConfig
cfg) ((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)))
-> STM ()
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
i (UTCTime
time, TMVar (Either Object Object)
reply)
Int64 -> STM Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
i
Message -> ConduitM i EncodedResponse EventHandler ()
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' (Message -> ConduitM i EncodedResponse EventHandler ())
-> Message -> ConduitM i EncodedResponse EventHandler ()
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{}) ->
Message -> ConduitM i EncodedResponse EventHandler ()
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
r
(Maybe FunctionCall
_, Just n :: Message
n@MsgpackRPC.Notification{}) ->
Message -> ConduitM i EncodedResponse EventHandler ()
forall (io :: * -> *) i.
MonadIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
n
(Maybe FunctionCall, Maybe Message)
_ ->
() -> ConduitM i EncodedResponse EventHandler ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()