{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- |
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
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


-- | 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 ()
-> 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)


-- | Convenient monad transformer stack for the event handler
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 () -- 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' :: (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 () -- i.e. skip to next message