{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeInType #-}

module Language.LSP.Protocol.Message.Types where

import Language.LSP.Protocol.Internal.Method
import Language.LSP.Protocol.Message.LspId
import Language.LSP.Protocol.Message.Meta
import Language.LSP.Protocol.Message.Method ()
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Utils.Misc

import Data.Aeson hiding (Null)
import Data.Aeson qualified as J
import Data.Aeson.TH
import Data.Kind
import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Generics
import GHC.TypeLits (KnownSymbol)
import Prettyprinter

-- 'RequestMessage', 'ResponseMessage', 'ResponseError', and 'NotificationMessage'
-- aren't present in the metamodel, although they should be.
-- https://github.com/microsoft/vscode-languageserver-node/issues/1079

-- | Notification message type as defined in the spec.
data NotificationMessage = NotificationMessage
  { NotificationMessage -> Text
_jsonrpc :: Text
  , NotificationMessage -> Text
_method :: Text
  , NotificationMessage -> Maybe Value
_params :: Maybe Value
  }
  deriving stock (Int -> NotificationMessage -> ShowS
[NotificationMessage] -> ShowS
NotificationMessage -> String
(Int -> NotificationMessage -> ShowS)
-> (NotificationMessage -> String)
-> ([NotificationMessage] -> ShowS)
-> Show NotificationMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotificationMessage -> ShowS
showsPrec :: Int -> NotificationMessage -> ShowS
$cshow :: NotificationMessage -> String
show :: NotificationMessage -> String
$cshowList :: [NotificationMessage] -> ShowS
showList :: [NotificationMessage] -> ShowS
Show, NotificationMessage -> NotificationMessage -> Bool
(NotificationMessage -> NotificationMessage -> Bool)
-> (NotificationMessage -> NotificationMessage -> Bool)
-> Eq NotificationMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotificationMessage -> NotificationMessage -> Bool
== :: NotificationMessage -> NotificationMessage -> Bool
$c/= :: NotificationMessage -> NotificationMessage -> Bool
/= :: NotificationMessage -> NotificationMessage -> Bool
Eq, (forall x. NotificationMessage -> Rep NotificationMessage x)
-> (forall x. Rep NotificationMessage x -> NotificationMessage)
-> Generic NotificationMessage
forall x. Rep NotificationMessage x -> NotificationMessage
forall x. NotificationMessage -> Rep NotificationMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NotificationMessage -> Rep NotificationMessage x
from :: forall x. NotificationMessage -> Rep NotificationMessage x
$cto :: forall x. Rep NotificationMessage x -> NotificationMessage
to :: forall x. Rep NotificationMessage x -> NotificationMessage
Generic)

deriveJSON lspOptions ''NotificationMessage
deriving via ViaJSON NotificationMessage instance Pretty NotificationMessage

-- This isn't present in the metamodel.

-- | Request message type as defined in the spec.
data RequestMessage = RequestMessage
  { RequestMessage -> Text
_jsonrpc :: Text
  , RequestMessage -> Int32 |? Text
_id :: Int32 |? Text
  , RequestMessage -> Text
_method :: Text
  , RequestMessage -> Maybe Value
_params :: Maybe Value
  }
  deriving stock (Int -> RequestMessage -> ShowS
[RequestMessage] -> ShowS
RequestMessage -> String
(Int -> RequestMessage -> ShowS)
-> (RequestMessage -> String)
-> ([RequestMessage] -> ShowS)
-> Show RequestMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestMessage -> ShowS
showsPrec :: Int -> RequestMessage -> ShowS
$cshow :: RequestMessage -> String
show :: RequestMessage -> String
$cshowList :: [RequestMessage] -> ShowS
showList :: [RequestMessage] -> ShowS
Show, RequestMessage -> RequestMessage -> Bool
(RequestMessage -> RequestMessage -> Bool)
-> (RequestMessage -> RequestMessage -> Bool) -> Eq RequestMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestMessage -> RequestMessage -> Bool
== :: RequestMessage -> RequestMessage -> Bool
$c/= :: RequestMessage -> RequestMessage -> Bool
/= :: RequestMessage -> RequestMessage -> Bool
Eq, (forall x. RequestMessage -> Rep RequestMessage x)
-> (forall x. Rep RequestMessage x -> RequestMessage)
-> Generic RequestMessage
forall x. Rep RequestMessage x -> RequestMessage
forall x. RequestMessage -> Rep RequestMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RequestMessage -> Rep RequestMessage x
from :: forall x. RequestMessage -> Rep RequestMessage x
$cto :: forall x. Rep RequestMessage x -> RequestMessage
to :: forall x. Rep RequestMessage x -> RequestMessage
Generic)

deriveJSON lspOptions ''RequestMessage
deriving via ViaJSON RequestMessage instance Pretty RequestMessage

-- | Response error type as defined in the spec.
data ResponseError = ResponseError
  { ResponseError -> LSPErrorCodes |? ErrorCodes
_code :: LSPErrorCodes |? ErrorCodes
  , ResponseError -> Text
_message :: Text
  , ResponseError -> Maybe Value
_xdata :: Maybe Value
  }
  deriving stock (Int -> ResponseError -> ShowS
[ResponseError] -> ShowS
ResponseError -> String
(Int -> ResponseError -> ShowS)
-> (ResponseError -> String)
-> ([ResponseError] -> ShowS)
-> Show ResponseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseError -> ShowS
showsPrec :: Int -> ResponseError -> ShowS
$cshow :: ResponseError -> String
show :: ResponseError -> String
$cshowList :: [ResponseError] -> ShowS
showList :: [ResponseError] -> ShowS
Show, ResponseError -> ResponseError -> Bool
(ResponseError -> ResponseError -> Bool)
-> (ResponseError -> ResponseError -> Bool) -> Eq ResponseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseError -> ResponseError -> Bool
== :: ResponseError -> ResponseError -> Bool
$c/= :: ResponseError -> ResponseError -> Bool
/= :: ResponseError -> ResponseError -> Bool
Eq, (forall x. ResponseError -> Rep ResponseError x)
-> (forall x. Rep ResponseError x -> ResponseError)
-> Generic ResponseError
forall x. Rep ResponseError x -> ResponseError
forall x. ResponseError -> Rep ResponseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ResponseError -> Rep ResponseError x
from :: forall x. ResponseError -> Rep ResponseError x
$cto :: forall x. Rep ResponseError x -> ResponseError
to :: forall x. Rep ResponseError x -> ResponseError
Generic)

{- Note [ErrorCodes and LSPErrorCodes]

Confusingly, the metamodel defines _two_ enums for error codes. One of
these covers JSON RPC errors and one covers LSP-specific errors. We want
to accept either, mostly so we can make use of the pre-specified enum values.

However, _both_ of them are listed as accepting custom values. This means
that `LSPErrorCodes |? ErrorCodes` isn't quite right: when we parse it from
JSON, if we get an error code that isn't a known value of `LSPErrorCodes`, we
will just use the custom value constructor, without trying `ErrorCodes`.

It's hard to find any other good way of representing things properly with what
we've got, so in the end we decided to patch up the JSON parsing with a custom
instance.
-}
deriveToJSON lspOptions ''ResponseError
instance FromJSON ResponseError where
  parseJSON :: Value -> Parser ResponseError
parseJSON =
    let errorCode :: Value -> Parser ResponseError
errorCode = String
-> (Object -> Parser ResponseError)
-> Value
-> Parser ResponseError
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ResponseError" ((Object -> Parser ResponseError) -> Value -> Parser ResponseError)
-> (Object -> Parser ResponseError)
-> Value
-> Parser ResponseError
forall a b. (a -> b) -> a -> b
$ \Object
v ->
          (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError
            ((LSPErrorCodes |? ErrorCodes)
 -> Text -> Maybe Value -> ResponseError)
-> Parser (LSPErrorCodes |? ErrorCodes)
-> Parser (Text -> Maybe Value -> ResponseError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (LSPErrorCodes |? ErrorCodes)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
            Parser (Text -> Maybe Value -> ResponseError)
-> Parser Text -> Parser (Maybe Value -> ResponseError)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
            Parser (Maybe Value -> ResponseError)
-> Parser (Maybe Value) -> Parser ResponseError
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Value)
forall v. FromJSON v => Object -> Key -> Parser (Maybe v)
.:!? Key
"data"
     in (ResponseError -> ResponseError)
-> Parser ResponseError -> Parser ResponseError
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResponseError -> ResponseError
go (Parser ResponseError -> Parser ResponseError)
-> (Value -> Parser ResponseError) -> Value -> Parser ResponseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser ResponseError
errorCode
   where
    go :: ResponseError -> ResponseError
    go :: ResponseError -> ResponseError
go x :: ResponseError
x@(ResponseError (InL (LSPErrorCodes_Custom Int32
n)) Text
_ Maybe Value
_) =
      ResponseError
x{_code = InR (fromOpenEnumBaseType n)}
    go ResponseError
x = ResponseError
x

deriving via ViaJSON ResponseError instance Pretty ResponseError

-- | Response message type as defined in the spec.
data ResponseMessage = ResponseMessage
  { ResponseMessage -> Text
_jsonrpc :: Text
  , ResponseMessage -> Int32 |? (Text |? Null)
_id :: Int32 |? Text |? Null
  , ResponseMessage -> Maybe Value
_result :: Maybe Value
  , ResponseMessage -> Maybe ResponseError
_error :: Maybe ResponseError
  }
  deriving stock (Int -> ResponseMessage -> ShowS
[ResponseMessage] -> ShowS
ResponseMessage -> String
(Int -> ResponseMessage -> ShowS)
-> (ResponseMessage -> String)
-> ([ResponseMessage] -> ShowS)
-> Show ResponseMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseMessage -> ShowS
showsPrec :: Int -> ResponseMessage -> ShowS
$cshow :: ResponseMessage -> String
show :: ResponseMessage -> String
$cshowList :: [ResponseMessage] -> ShowS
showList :: [ResponseMessage] -> ShowS
Show, ResponseMessage -> ResponseMessage -> Bool
(ResponseMessage -> ResponseMessage -> Bool)
-> (ResponseMessage -> ResponseMessage -> Bool)
-> Eq ResponseMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseMessage -> ResponseMessage -> Bool
== :: ResponseMessage -> ResponseMessage -> Bool
$c/= :: ResponseMessage -> ResponseMessage -> Bool
/= :: ResponseMessage -> ResponseMessage -> Bool
Eq, (forall x. ResponseMessage -> Rep ResponseMessage x)
-> (forall x. Rep ResponseMessage x -> ResponseMessage)
-> Generic ResponseMessage
forall x. Rep ResponseMessage x -> ResponseMessage
forall x. ResponseMessage -> Rep ResponseMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ResponseMessage -> Rep ResponseMessage x
from :: forall x. ResponseMessage -> Rep ResponseMessage x
$cto :: forall x. Rep ResponseMessage x -> ResponseMessage
to :: forall x. Rep ResponseMessage x -> ResponseMessage
Generic)

deriveJSON lspOptions ''ResponseMessage

deriving via ViaJSON ResponseMessage instance Pretty ResponseMessage

-----

-- | Typed notification message, containing the correct parameter payload.
data TNotificationMessage (m :: Method f Notification) = TNotificationMessage
  { forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> Text
_jsonrpc :: Text
  , forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> SMethod m
_method :: SMethod m
  , forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params :: MessageParams m
  }
  deriving stock ((forall x.
 TNotificationMessage m -> Rep (TNotificationMessage m) x)
-> (forall x.
    Rep (TNotificationMessage m) x -> TNotificationMessage m)
-> Generic (TNotificationMessage m)
forall x. Rep (TNotificationMessage m) x -> TNotificationMessage m
forall x. TNotificationMessage m -> Rep (TNotificationMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: MessageDirection) (m :: Method f 'Notification) x.
Rep (TNotificationMessage m) x -> TNotificationMessage m
forall (f :: MessageDirection) (m :: Method f 'Notification) x.
TNotificationMessage m -> Rep (TNotificationMessage m) x
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Notification) x.
TNotificationMessage m -> Rep (TNotificationMessage m) x
from :: forall x. TNotificationMessage m -> Rep (TNotificationMessage m) x
$cto :: forall (f :: MessageDirection) (m :: Method f 'Notification) x.
Rep (TNotificationMessage m) x -> TNotificationMessage m
to :: forall x. Rep (TNotificationMessage m) x -> TNotificationMessage m
Generic)

deriving stock instance Eq (MessageParams m) => Eq (TNotificationMessage m)
deriving stock instance Show (MessageParams m) => Show (TNotificationMessage m)

{- Note [Missing 'params']
The 'params' field on requrests and notificaoins may be omitted according to the
JSON-RPC spec, but that doesn't quite work the way we want with the generic aeson
instance. Even if the 'MessageParams' type family happens to resolve to a 'Maybe',
we handle it generically and so we end up asserting that it must be present.

We fix this in a slightly dumb way by just adding the field in if it is missing,
set to null (which parses correctly for those 'Maybe' parameters also).
-}

instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (TNotificationMessage m) where
  -- See Note [Missing 'params']
  parseJSON :: Value -> Parser (TNotificationMessage m)
parseJSON = Options -> Value -> Parser (TNotificationMessage m)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
lspOptions (Value -> Parser (TNotificationMessage m))
-> (Value -> Value) -> Value -> Parser (TNotificationMessage m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value -> Value
addNullField String
"params"
instance (ToJSON (MessageParams m)) => ToJSON (TNotificationMessage m) where
  toJSON :: TNotificationMessage m -> Value
toJSON = Options -> TNotificationMessage m -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TNotificationMessage m -> Encoding
toEncoding = Options -> TNotificationMessage m -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
lspOptions

deriving via ViaJSON (TNotificationMessage m) instance (ToJSON (MessageParams m)) => Pretty (TNotificationMessage m)

-- | Typed request message, containing the correct parameter payload.
data TRequestMessage (m :: Method f Request) = TRequestMessage
  { forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> Text
_jsonrpc :: Text
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> LspId m
_id :: LspId m
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> SMethod m
_method :: SMethod m
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> MessageParams m
_params :: MessageParams m
  }
  deriving stock ((forall x. TRequestMessage m -> Rep (TRequestMessage m) x)
-> (forall x. Rep (TRequestMessage m) x -> TRequestMessage m)
-> Generic (TRequestMessage m)
forall x. Rep (TRequestMessage m) x -> TRequestMessage m
forall x. TRequestMessage m -> Rep (TRequestMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TRequestMessage m) x -> TRequestMessage m
forall (f :: MessageDirection) (m :: Method f 'Request) x.
TRequestMessage m -> Rep (TRequestMessage m) x
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TRequestMessage m -> Rep (TRequestMessage m) x
from :: forall x. TRequestMessage m -> Rep (TRequestMessage m) x
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TRequestMessage m) x -> TRequestMessage m
to :: forall x. Rep (TRequestMessage m) x -> TRequestMessage m
Generic)

deriving stock instance Eq (MessageParams m) => Eq (TRequestMessage m)
deriving stock instance Show (MessageParams m) => Show (TRequestMessage m)

instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (TRequestMessage m) where
  -- See Note [Missing 'params']
  parseJSON :: Value -> Parser (TRequestMessage m)
parseJSON = Options -> Value -> Parser (TRequestMessage m)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
lspOptions (Value -> Parser (TRequestMessage m))
-> (Value -> Value) -> Value -> Parser (TRequestMessage m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value -> Value
addNullField String
"params"
instance (ToJSON (MessageParams m)) => ToJSON (TRequestMessage m) where
  toJSON :: TRequestMessage m -> Value
toJSON = Options -> TRequestMessage m -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TRequestMessage m -> Encoding
toEncoding = Options -> TRequestMessage m -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
lspOptions

deriving via ViaJSON (TRequestMessage m) instance (ToJSON (MessageParams m)) => Pretty (TRequestMessage m)

data TResponseError (m :: Method f Request) = TResponseError
  { forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseError m -> LSPErrorCodes |? ErrorCodes
_code :: LSPErrorCodes |? ErrorCodes
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseError m -> Text
_message :: Text
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseError m -> Maybe (ErrorData m)
_xdata :: Maybe (ErrorData m)
  }
  deriving stock ((forall x. TResponseError m -> Rep (TResponseError m) x)
-> (forall x. Rep (TResponseError m) x -> TResponseError m)
-> Generic (TResponseError m)
forall x. Rep (TResponseError m) x -> TResponseError m
forall x. TResponseError m -> Rep (TResponseError m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseError m) x -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseError m -> Rep (TResponseError m) x
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseError m -> Rep (TResponseError m) x
from :: forall x. TResponseError m -> Rep (TResponseError m) x
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseError m) x -> TResponseError m
to :: forall x. Rep (TResponseError m) x -> TResponseError m
Generic)

deriving stock instance Eq (ErrorData m) => Eq (TResponseError m)
deriving stock instance Show (ErrorData m) => Show (TResponseError m)

instance (FromJSON (ErrorData m)) => FromJSON (TResponseError m) where
  parseJSON :: Value -> Parser (TResponseError m)
parseJSON =
    let errorCode :: Value -> Parser (TResponseError m)
errorCode = String
-> (Object -> Parser (TResponseError m))
-> Value
-> Parser (TResponseError m)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ResponseError" ((Object -> Parser (TResponseError m))
 -> Value -> Parser (TResponseError m))
-> (Object -> Parser (TResponseError m))
-> Value
-> Parser (TResponseError m)
forall a b. (a -> b) -> a -> b
$ \Object
v ->
          (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError
            ((LSPErrorCodes |? ErrorCodes)
 -> Text -> Maybe (ErrorData m) -> TResponseError m)
-> Parser (LSPErrorCodes |? ErrorCodes)
-> Parser (Text -> Maybe (ErrorData m) -> TResponseError m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (LSPErrorCodes |? ErrorCodes)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
            Parser (Text -> Maybe (ErrorData m) -> TResponseError m)
-> Parser Text -> Parser (Maybe (ErrorData m) -> TResponseError m)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
            Parser (Maybe (ErrorData m) -> TResponseError m)
-> Parser (Maybe (ErrorData m)) -> Parser (TResponseError m)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe (ErrorData m))
forall v. FromJSON v => Object -> Key -> Parser (Maybe v)
.:!? Key
"data"
     in (TResponseError m -> TResponseError m)
-> Parser (TResponseError m) -> Parser (TResponseError m)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TResponseError m -> TResponseError m
go (Parser (TResponseError m) -> Parser (TResponseError m))
-> (Value -> Parser (TResponseError m))
-> Value
-> Parser (TResponseError m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (TResponseError m)
errorCode
   where
    go :: TResponseError m -> TResponseError m
    go :: TResponseError m -> TResponseError m
go x :: TResponseError m
x@(TResponseError (InL (LSPErrorCodes_Custom Int32
n)) Text
_ Maybe (ErrorData m)
_) =
      TResponseError m
x{_code = InR (fromOpenEnumBaseType n)}
    go TResponseError m
x = TResponseError m
x
instance (ToJSON (ErrorData m)) => ToJSON (TResponseError m) where
  toJSON :: TResponseError m -> Value
toJSON = Options -> TResponseError m -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TResponseError m -> Encoding
toEncoding = Options -> TResponseError m -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
lspOptions

deriving via ViaJSON (TResponseError m) instance (ToJSON (ErrorData m)) => Pretty (TResponseError m)

-- TODO: similar functions for the others?
toUntypedResponseError :: (ToJSON (ErrorData m)) => TResponseError m -> ResponseError
toUntypedResponseError :: forall {f :: MessageDirection} (m :: Method f 'Request).
ToJSON (ErrorData m) =>
TResponseError m -> ResponseError
toUntypedResponseError (TResponseError LSPErrorCodes |? ErrorCodes
c Text
m Maybe (ErrorData m)
d) = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError LSPErrorCodes |? ErrorCodes
c Text
m ((ErrorData m -> Value) -> Maybe (ErrorData m) -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorData m -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe (ErrorData m)
d)

-- | A typed response message with a correct result payload.
data TResponseMessage (m :: Method f Request) = TResponseMessage
  { forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Text
_jsonrpc :: Text
  , forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Maybe (LspId m)
_id :: Maybe (LspId m)
  , -- TODO: use `TResponseError m` for the error type, this will require quite a lot of adaptation downstream
    forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result :: Either ResponseError (MessageResult m)
  }
  deriving stock ((forall x. TResponseMessage m -> Rep (TResponseMessage m) x)
-> (forall x. Rep (TResponseMessage m) x -> TResponseMessage m)
-> Generic (TResponseMessage m)
forall x. Rep (TResponseMessage m) x -> TResponseMessage m
forall x. TResponseMessage m -> Rep (TResponseMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseMessage m) x -> TResponseMessage m
forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseMessage m -> Rep (TResponseMessage m) x
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseMessage m -> Rep (TResponseMessage m) x
from :: forall x. TResponseMessage m -> Rep (TResponseMessage m) x
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseMessage m) x -> TResponseMessage m
to :: forall x. Rep (TResponseMessage m) x -> TResponseMessage m
Generic)

deriving stock instance (Eq (MessageResult m), Eq (ErrorData m)) => Eq (TResponseMessage m)
deriving stock instance (Show (MessageResult m), Show (ErrorData m)) => Show (TResponseMessage m)

instance (ToJSON (MessageResult m), ToJSON (ErrorData m)) => ToJSON (TResponseMessage m) where
  toJSON :: TResponseMessage m -> Value
toJSON TResponseMessage{$sel:_jsonrpc:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Text
_jsonrpc = Text
jsonrpc, $sel:_id:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Maybe (LspId m)
_id = Maybe (LspId m)
lspid, $sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result = Either ResponseError (MessageResult m)
result} =
    [Pair] -> Value
object
      [ Key
"jsonrpc" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
jsonrpc
      , Key
"id" Key -> Maybe (LspId m) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe (LspId m)
lspid
      , case Either ResponseError (MessageResult m)
result of
          Left ResponseError
err -> Key
"error" Key -> ResponseError -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ResponseError
err
          Right MessageResult m
a -> Key
"result" Key -> MessageResult m -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MessageResult m
a
      ]

instance (FromJSON (MessageResult a), FromJSON (ErrorData a)) => FromJSON (TResponseMessage a) where
  parseJSON :: Value -> Parser (TResponseMessage a)
parseJSON = String
-> (Object -> Parser (TResponseMessage a))
-> Value
-> Parser (TResponseMessage a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Response" ((Object -> Parser (TResponseMessage a))
 -> Value -> Parser (TResponseMessage a))
-> (Object -> Parser (TResponseMessage a))
-> Value
-> Parser (TResponseMessage a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
_jsonrpc <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
    Maybe (LspId a)
_id <- Object
o Object -> Key -> Parser (Maybe (LspId a))
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    Maybe (MessageResult a)
_result <- Object
o Object -> Key -> Parser (Maybe (MessageResult a))
forall v. FromJSON v => Object -> Key -> Parser (Maybe v)
.:!? Key
"result"
    Maybe ResponseError
_error <- Object
o Object -> Key -> Parser (Maybe ResponseError)
forall v. FromJSON v => Object -> Key -> Parser (Maybe v)
.:!? Key
"error"
    Either ResponseError (MessageResult a)
result <- case (Maybe ResponseError
_error, Maybe (MessageResult a)
_result) of
      (Just ResponseError
err, Maybe (MessageResult a)
Nothing) -> Either ResponseError (MessageResult a)
-> Parser (Either ResponseError (MessageResult a))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (MessageResult a)
 -> Parser (Either ResponseError (MessageResult a)))
-> Either ResponseError (MessageResult a)
-> Parser (Either ResponseError (MessageResult a))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (MessageResult a)
forall a b. a -> Either a b
Left ResponseError
err
      (Maybe ResponseError
Nothing, Just MessageResult a
res) -> Either ResponseError (MessageResult a)
-> Parser (Either ResponseError (MessageResult a))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (MessageResult a)
 -> Parser (Either ResponseError (MessageResult a)))
-> Either ResponseError (MessageResult a)
-> Parser (Either ResponseError (MessageResult a))
forall a b. (a -> b) -> a -> b
$ MessageResult a -> Either ResponseError (MessageResult a)
forall a b. b -> Either a b
Right MessageResult a
res
      (Just ResponseError
_err, Just MessageResult a
_res) -> String -> Parser (Either ResponseError (MessageResult a))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Either ResponseError (MessageResult a)))
-> String -> Parser (Either ResponseError (MessageResult a))
forall a b. (a -> b) -> a -> b
$ String
"both error and result cannot be present: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
o
      (Maybe ResponseError
Nothing, Maybe (MessageResult a)
Nothing) -> String -> Parser (Either ResponseError (MessageResult a))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"both error and result cannot be Nothing"
    TResponseMessage a -> Parser (TResponseMessage a)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (TResponseMessage a -> Parser (TResponseMessage a))
-> TResponseMessage a -> Parser (TResponseMessage a)
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId a)
-> Either ResponseError (MessageResult a)
-> TResponseMessage a
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
_jsonrpc Maybe (LspId a)
_id Either ResponseError (MessageResult a)
result

deriving via ViaJSON (TResponseMessage m) instance (ToJSON (MessageResult m), ToJSON (ErrorData m)) => Pretty (TResponseMessage m)

{- | A typed custom message. A special data type is needed to distinguish between
 notifications and requests, since a CustomMethod can be both!
-}
data TCustomMessage s f t where
  ReqMess :: TRequestMessage (Method_CustomMethod s :: Method f Request) -> TCustomMessage s f Request
  NotMess :: TNotificationMessage (Method_CustomMethod s :: Method f Notification) -> TCustomMessage s f Notification

deriving stock instance Show (TCustomMessage s f t)

instance ToJSON (TCustomMessage s f t) where
  toJSON :: TCustomMessage s f t -> Value
toJSON (ReqMess TRequestMessage ('Method_CustomMethod s)
a) = TRequestMessage ('Method_CustomMethod s) -> Value
forall a. ToJSON a => a -> Value
toJSON TRequestMessage ('Method_CustomMethod s)
a
  toJSON (NotMess TNotificationMessage ('Method_CustomMethod s)
a) = TNotificationMessage ('Method_CustomMethod s) -> Value
forall a. ToJSON a => a -> Value
toJSON TNotificationMessage ('Method_CustomMethod s)
a

instance KnownSymbol s => FromJSON (TCustomMessage s f Request) where
  parseJSON :: Value -> Parser (TCustomMessage s f 'Request)
parseJSON Value
v = TRequestMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Request
forall (s :: Symbol) (f :: MessageDirection).
TRequestMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Request
ReqMess (TRequestMessage ('Method_CustomMethod s)
 -> TCustomMessage s f 'Request)
-> Parser (TRequestMessage ('Method_CustomMethod s))
-> Parser (TCustomMessage s f 'Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (TRequestMessage ('Method_CustomMethod s))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
instance KnownSymbol s => FromJSON (TCustomMessage s f Notification) where
  parseJSON :: Value -> Parser (TCustomMessage s f 'Notification)
parseJSON Value
v = TNotificationMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Notification
forall (s :: Symbol) (f :: MessageDirection).
TNotificationMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Notification
NotMess (TNotificationMessage ('Method_CustomMethod s)
 -> TCustomMessage s f 'Notification)
-> Parser (TNotificationMessage ('Method_CustomMethod s))
-> Parser (TCustomMessage s f 'Notification)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (TNotificationMessage ('Method_CustomMethod s))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

deriving via ViaJSON (TCustomMessage s f t) instance (KnownSymbol s) => Pretty (TCustomMessage s f t)

-- ---------------------------------------------------------------------
-- Helper Type Families
-- ---------------------------------------------------------------------

{- | Map a method to the Request/Notification type with the correct
 payload.
-}
type TMessage :: forall f t. Method f t -> Type
type family TMessage m where
  TMessage (Method_CustomMethod s :: Method f t) = TCustomMessage s f t
  TMessage (m :: Method f Request) = TRequestMessage m
  TMessage (m :: Method f Notification) = TNotificationMessage m

-- Some helpful type synonyms
type TClientMessage (m :: Method ClientToServer t) = TMessage m
type TServerMessage (m :: Method ServerToClient t) = TMessage m

{- | Replace a missing field in an object with a null field, to simplify parsing
 This is a hack to allow other types than Maybe to work like Maybe in allowing the field to be missing.
 See also this issue: https://github.com/haskell/aeson/issues/646
-}
addNullField :: String -> Value -> Value
addNullField :: String -> Value -> Value
addNullField String
s (Object Object
o) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
o Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> String -> Key
forall a. IsString a => String -> a
fromString String
s Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
J.Null
addNullField String
_ Value
v = Value
v