{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

{- |
Module      :  Neovim.RPC.EventHandler
Description :  Event handling loop
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
-}
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 (forever)
import Control.Monad.Reader (
    MonadReader,
    ReaderT (runReaderT),
 )
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 (MonadUnliftIO, modifyTVar', readTVar)
import Prelude

{- | This function will establish a connection to the given socket and write
 msgpack-rpc requests to it.
-}
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 ()
-> ConduitT SomeMessage Void EventHandler ()
-> ConduitT () Void EventHandler ()
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
            ConduitM SomeMessage EncodedResponse EventHandler ()
-> ConduitT EncodedResponse Void EventHandler ()
-> ConduitT SomeMessage Void EventHandler ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Handle -> ConduitT EncodedResponse Void EventHandler ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitM EncodedResponse o m ()
sinkHandleFlush Handle
writeableHandle

-- | Convenient monad transformer stack for the event handler
newtype EventHandler a
    = EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a)
    deriving
        ( (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
$cfmap :: forall a b. (a -> b) -> EventHandler a -> EventHandler b
fmap :: forall a b. (a -> b) -> EventHandler a -> EventHandler b
$c<$ :: forall a b. a -> EventHandler b -> EventHandler a
<$ :: forall a b. a -> EventHandler b -> EventHandler a
Functor
        , Functor EventHandler
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
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
$cpure :: forall a. a -> EventHandler a
pure :: forall a. a -> EventHandler a
$c<*> :: forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
<*> :: forall a b.
EventHandler (a -> b) -> EventHandler a -> EventHandler b
$cliftA2 :: forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
liftA2 :: forall a b c.
(a -> b -> c) -> EventHandler a -> EventHandler b -> EventHandler c
$c*> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
*> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
$c<* :: forall a b. EventHandler a -> EventHandler b -> EventHandler a
<* :: forall a b. EventHandler a -> EventHandler b -> EventHandler a
Applicative
        , Applicative EventHandler
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
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
$c>>= :: forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
>>= :: forall a b.
EventHandler a -> (a -> EventHandler b) -> EventHandler b
$c>> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
>> :: forall a b. EventHandler a -> EventHandler b -> EventHandler b
$creturn :: forall a. a -> EventHandler a
return :: forall a. a -> EventHandler a
Monad
        , Monad EventHandler
Monad EventHandler =>
(forall a. IO a -> EventHandler a) -> MonadIO EventHandler
forall a. IO a -> EventHandler a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> EventHandler a
liftIO :: forall a. IO a -> EventHandler a
MonadIO
        , MonadIO EventHandler
MonadIO EventHandler =>
(forall b.
 ((forall a. EventHandler a -> IO a) -> IO b) -> EventHandler b)
-> MonadUnliftIO 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
$cwithRunInIO :: forall b.
((forall a. EventHandler a -> IO a) -> IO b) -> EventHandler b
withRunInIO :: 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) =
    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 a b.
ConduitT () SomeMessage EventHandler a
-> (a -> ConduitT () SomeMessage EventHandler b)
-> ConduitT () SomeMessage EventHandler b
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 o. Monad m => ConduitT i o m (Maybe i)
await ConduitT
  SomeMessage EncodedResponse EventHandler (Maybe SomeMessage)
-> (Maybe SomeMessage
    -> ConduitM SomeMessage EncodedResponse EventHandler ())
-> ConduitM SomeMessage EncodedResponse EventHandler ()
forall a b.
ConduitT SomeMessage EncodedResponse EventHandler a
-> (a -> ConduitT SomeMessage EncodedResponse EventHandler b)
-> ConduitT SomeMessage EncodedResponse EventHandler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe SomeMessage
Nothing ->
            () -> ConduitM SomeMessage EncodedResponse EventHandler ()
forall a. a -> ConduitT SomeMessage EncodedResponse EventHandler a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- i.e. close the conduit -- TODO signal shutdown globally
        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' :: (MonadUnliftIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io ()
yield' :: forall (io :: * -> *) i.
MonadUnliftIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
o = do
    IO () -> ConduitM i EncodedResponse io ()
forall a. IO a -> ConduitT i EncodedResponse io a
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 :: 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 <- (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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
i
        Message -> ConduitM i EncodedResponse EventHandler ()
forall (io :: * -> *) i.
MonadUnliftIO 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.
MonadUnliftIO 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.
MonadUnliftIO io =>
Message -> ConduitM i EncodedResponse io ()
yield' Message
n
    (Maybe FunctionCall, Maybe Message)
_ ->
        () -> ConduitM i EncodedResponse EventHandler ()
forall a. a -> ConduitT i EncodedResponse EventHandler a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- i.e. skip to next message