{-# 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 =
    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

-- | Convenient monad transformer stack for the event handler
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 () -- i.e. close the conduit -- TODO signal shutdown globally
        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 () -- i.e. skip to next message