{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module Neovim.RPC.EventHandler (
runEventHandler,
) where
import Neovim.Classes (NvimObject (toObject))
import Neovim.Context (MonadIO (..), asks)
import qualified Neovim.Context.Internal as Internal
import Neovim.Plugin.IPC.Classes (
FunctionCall (..),
Message (fromMessage),
Request (Request),
SomeMessage,
readSomeMessage,
)
import qualified Neovim.RPC.Classes as MsgpackRPC
import Neovim.RPC.Common (RPCConfig (nextMessageId, recipients))
import Neovim.RPC.FunctionCall (atomically')
import Conduit as C (
ConduitM,
ConduitT,
Flush (..),
ResourceT,
await,
runConduit,
runResourceT,
sinkHandleFlush,
yield,
(.|),
)
import Control.Monad.Reader (
MonadReader,
ReaderT (runReaderT),
forever,
)
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Serialize (encode)
import System.IO (Handle)
import System.Log.Logger (debugM)
import UnliftIO (modifyTVar', readTVar)
import Prelude
import UnliftIO (MonadUnliftIO)
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
, MonadIO EventHandler
forall b.
((forall a. EventHandler a -> IO a) -> IO b) -> EventHandler b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b.
((forall a. EventHandler a -> IO a) -> IO b) -> EventHandler b
$cwithRunInIO :: forall b.
((forall a. EventHandler a -> IO a) -> IO b) -> EventHandler b
MonadUnliftIO
, 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' :: (MonadUnliftIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io ()
yield' :: forall (io :: * -> *) i.
MonadUnliftIO 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
. String -> String -> IO ()
debugM String
"EventHandler" forall a b. (a -> b) -> a -> b
$ String
"Sending: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
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.
MonadUnliftIO 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.
MonadUnliftIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
r
(Maybe FunctionCall
_, Just n :: Message
n@MsgpackRPC.Notification{}) ->
forall (io :: * -> *) i.
MonadUnliftIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
n
(Maybe FunctionCall, Maybe Message)
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()