{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

{- |
Module      :  Neovim.Plugin.IPC.Classes
Description :  Classes used for Inter Plugin Communication
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
Portability :  GHC
-}
module Neovim.Plugin.IPC.Classes (
    SomeMessage (..),
    Message (..),
    FunctionCall (..),
    Request (..),
    Notification (..),
    writeMessage,
    readSomeMessage,
    UTCTime,
    getCurrentTime,
    module Data.Int,
) where

import Neovim.Classes (
    Generic,
    Int64,
    Pretty (pretty),
    (<+>),
 )
import Neovim.Plugin.Classes (FunctionName, NeovimEventId)

import Data.Data (cast)
import Data.Int (Int64)
import Data.MessagePack (Object)
import Data.Time (UTCTime, formatTime, getCurrentTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Prettyprinter (hardline, nest, viaShow)
import UnliftIO (
    MonadIO (..),
    MonadUnliftIO,
    TMVar,
    TQueue,
    Typeable,
    atomically,
    evaluate,
    readTQueue,
    writeTQueue,
 )

import Control.DeepSeq (NFData, deepseq, rnf)
import Prelude

{- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed
 Hierarchy of Exceptions/, Simon Marlow, 2006.

 User-extensible messages must be put into a value of this type, so that it
 can be sent to other plugins.
-}
data SomeMessage = forall msg. Message msg => SomeMessage msg

{- | This class allows type safe casting of 'SomeMessage' to an actual message.
 The cast is successful if the type you're expecting matches the type in the
 'SomeMessage' wrapper. This way, you can subscribe to an arbitrary message
 type withouth having to pattern match on the constructors. This also allows
 plugin authors to create their own message types without having to change the
 core code of /nvim-hs/.
-}
class (NFData message, Typeable message) => Message message where
    -- | Try to convert a given message to a value of the message type we are
    -- interested in. Will evaluate to 'Nothing' for any other type.
    fromMessage :: SomeMessage -> Maybe message
    fromMessage (SomeMessage msg
message) = msg -> Maybe message
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast msg
message

writeMessage :: (MonadUnliftIO m, Message message) => TQueue SomeMessage -> message -> m ()
writeMessage :: forall (m :: * -> *) message.
(MonadUnliftIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
q message
message = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    () -> IO ()
forall (m :: * -> *) a. MonadIO m => a -> m a
evaluate (message -> ()
forall a. NFData a => a -> ()
rnf message
message)
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue SomeMessage -> SomeMessage -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue SomeMessage
q (message -> SomeMessage
forall msg. Message msg => msg -> SomeMessage
SomeMessage message
message)

readSomeMessage :: MonadIO m => TQueue SomeMessage -> m SomeMessage
readSomeMessage :: forall (m :: * -> *).
MonadIO m =>
TQueue SomeMessage -> m SomeMessage
readSomeMessage TQueue SomeMessage
q = IO SomeMessage -> m SomeMessage
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SomeMessage -> m SomeMessage)
-> IO SomeMessage -> m SomeMessage
forall a b. (a -> b) -> a -> b
$ STM SomeMessage -> IO SomeMessage
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue SomeMessage -> STM SomeMessage
forall a. TQueue a -> STM a
readTQueue TQueue SomeMessage
q)

-- | Haskell representation of supported Remote Procedure Call messages.
data FunctionCall
    = -- | Method name, parameters, callback, timestamp
      FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime
    deriving (Typeable, (forall x. FunctionCall -> Rep FunctionCall x)
-> (forall x. Rep FunctionCall x -> FunctionCall)
-> Generic FunctionCall
forall x. Rep FunctionCall x -> FunctionCall
forall x. FunctionCall -> Rep FunctionCall x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FunctionCall -> Rep FunctionCall x
from :: forall x. FunctionCall -> Rep FunctionCall x
$cto :: forall x. Rep FunctionCall x -> FunctionCall
to :: forall x. Rep FunctionCall x -> FunctionCall
Generic)

instance NFData FunctionCall where
    rnf :: FunctionCall -> ()
rnf (FunctionCall FunctionName
f [Object]
os TMVar (Either Object Object)
v UTCTime
t) = FunctionName
f FunctionName -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Object]
os [Object] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` TMVar (Either Object Object)
v TMVar (Either Object Object) -> () -> ()
forall a b. a -> b -> b
`seq` UTCTime
t UTCTime -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

instance Message FunctionCall

instance Pretty FunctionCall where
    pretty :: forall ann. FunctionCall -> Doc ann
pretty (FunctionCall FunctionName
fname [Object]
args TMVar (Either Object Object)
_ UTCTime
t) =
        Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
            Doc ann
"Function call for:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FunctionName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. FunctionName -> Doc ann
pretty FunctionName
fname
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Arguments:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Object] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [Object]
args
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Timestamp:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (String -> Doc ann) -> (UTCTime -> String) -> UTCTime -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%H:%M:%S (%q)") UTCTime
t

{- | A request is a data type containing the method to call, its arguments and
 an identifier used to map the result to the function that has been called.
-}
data Request = Request
    { Request -> FunctionName
reqMethod :: FunctionName
    -- ^ Name of the function to call.
    , Request -> Int64
reqId :: !Int64
    -- ^ Identifier to map the result to a function call invocation.
    , Request -> [Object]
reqArgs :: [Object]
    -- ^ Arguments for the function.
    }
    deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
/= :: Request -> Request -> Bool
Eq, Eq Request
Eq Request =>
(Request -> Request -> Ordering)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Bool)
-> (Request -> Request -> Request)
-> (Request -> Request -> Request)
-> Ord Request
Request -> Request -> Bool
Request -> Request -> Ordering
Request -> Request -> Request
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Request -> Request -> Ordering
compare :: Request -> Request -> Ordering
$c< :: Request -> Request -> Bool
< :: Request -> Request -> Bool
$c<= :: Request -> Request -> Bool
<= :: Request -> Request -> Bool
$c> :: Request -> Request -> Bool
> :: Request -> Request -> Bool
$c>= :: Request -> Request -> Bool
>= :: Request -> Request -> Bool
$cmax :: Request -> Request -> Request
max :: Request -> Request -> Request
$cmin :: Request -> Request -> Request
min :: Request -> Request -> Request
Ord, Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Request -> ShowS
showsPrec :: Int -> Request -> ShowS
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> ShowS
showList :: [Request] -> ShowS
Show, Typeable, (forall x. Request -> Rep Request x)
-> (forall x. Rep Request x -> Request) -> Generic Request
forall x. Rep Request x -> Request
forall x. Request -> Rep Request x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Request -> Rep Request x
from :: forall x. Request -> Rep Request x
$cto :: forall x. Rep Request x -> Request
to :: forall x. Rep Request x -> Request
Generic)

instance NFData Request

instance Message Request

instance Pretty Request where
    pretty :: forall ann. Request -> Doc ann
pretty Request{Int64
[Object]
FunctionName
reqMethod :: Request -> FunctionName
reqId :: Request -> Int64
reqArgs :: Request -> [Object]
reqMethod :: FunctionName
reqId :: Int64
reqArgs :: [Object]
..} =
        Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
            Doc ann
"Request"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"#"
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int64 -> Doc ann
forall ann. Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
reqId
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Method:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FunctionName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. FunctionName -> Doc ann
pretty FunctionName
reqMethod
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Arguments:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Object] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [Object]
reqArgs

{- | A notification is similar to a 'Request'. It essentially does the same
 thing, but the function is only called for its side effects. This type of
 message is sent by neovim if the caller there does not care about the result
 of the computation.
-}
data Notification = Notification
    { Notification -> NeovimEventId
notEvent :: NeovimEventId
    -- ^ Event name of the notification.
    , Notification -> [Object]
notArgs :: [Object]
    -- ^ Arguments for the function.
    }
    deriving (Notification -> Notification -> Bool
(Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool) -> Eq Notification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Notification -> Notification -> Bool
== :: Notification -> Notification -> Bool
$c/= :: Notification -> Notification -> Bool
/= :: Notification -> Notification -> Bool
Eq, Eq Notification
Eq Notification =>
(Notification -> Notification -> Ordering)
-> (Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool)
-> (Notification -> Notification -> Notification)
-> (Notification -> Notification -> Notification)
-> Ord Notification
Notification -> Notification -> Bool
Notification -> Notification -> Ordering
Notification -> Notification -> Notification
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Notification -> Notification -> Ordering
compare :: Notification -> Notification -> Ordering
$c< :: Notification -> Notification -> Bool
< :: Notification -> Notification -> Bool
$c<= :: Notification -> Notification -> Bool
<= :: Notification -> Notification -> Bool
$c> :: Notification -> Notification -> Bool
> :: Notification -> Notification -> Bool
$c>= :: Notification -> Notification -> Bool
>= :: Notification -> Notification -> Bool
$cmax :: Notification -> Notification -> Notification
max :: Notification -> Notification -> Notification
$cmin :: Notification -> Notification -> Notification
min :: Notification -> Notification -> Notification
Ord, Int -> Notification -> ShowS
[Notification] -> ShowS
Notification -> String
(Int -> Notification -> ShowS)
-> (Notification -> String)
-> ([Notification] -> ShowS)
-> Show Notification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Notification -> ShowS
showsPrec :: Int -> Notification -> ShowS
$cshow :: Notification -> String
show :: Notification -> String
$cshowList :: [Notification] -> ShowS
showList :: [Notification] -> ShowS
Show, Typeable, (forall x. Notification -> Rep Notification x)
-> (forall x. Rep Notification x -> Notification)
-> Generic Notification
forall x. Rep Notification x -> Notification
forall x. Notification -> Rep Notification x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Notification -> Rep Notification x
from :: forall x. Notification -> Rep Notification x
$cto :: forall x. Rep Notification x -> Notification
to :: forall x. Rep Notification x -> Notification
Generic)

instance NFData Notification

instance Message Notification

instance Pretty Notification where
    pretty :: forall ann. Notification -> Doc ann
pretty Notification{[Object]
NeovimEventId
notEvent :: Notification -> NeovimEventId
notArgs :: Notification -> [Object]
notEvent :: NeovimEventId
notArgs :: [Object]
..} =
        Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
            Doc ann
"Notification"
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Event:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NeovimEventId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. NeovimEventId -> Doc ann
pretty NeovimEventId
notEvent
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline
                    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Arguments:"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NeovimEventId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NeovimEventId
notEvent