{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# 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.Types.Common
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotificationMessage] -> ShowS
$cshowList :: [NotificationMessage] -> ShowS
show :: NotificationMessage -> String
$cshow :: NotificationMessage -> String
showsPrec :: Int -> NotificationMessage -> ShowS
$cshowsPrec :: Int -> NotificationMessage -> ShowS
Show, NotificationMessage -> NotificationMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotificationMessage -> NotificationMessage -> Bool
$c/= :: NotificationMessage -> NotificationMessage -> Bool
== :: NotificationMessage -> NotificationMessage -> Bool
$c== :: NotificationMessage -> NotificationMessage -> Bool
Eq, 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
$cto :: forall x. Rep NotificationMessage x -> NotificationMessage
$cfrom :: forall x. NotificationMessage -> Rep NotificationMessage x
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestMessage] -> ShowS
$cshowList :: [RequestMessage] -> ShowS
show :: RequestMessage -> String
$cshow :: RequestMessage -> String
showsPrec :: Int -> RequestMessage -> ShowS
$cshowsPrec :: Int -> RequestMessage -> ShowS
Show, RequestMessage -> RequestMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestMessage -> RequestMessage -> Bool
$c/= :: RequestMessage -> RequestMessage -> Bool
== :: RequestMessage -> RequestMessage -> Bool
$c== :: RequestMessage -> RequestMessage -> Bool
Eq, 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
$cto :: forall x. Rep RequestMessage x -> RequestMessage
$cfrom :: forall x. RequestMessage -> Rep RequestMessage x
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseError] -> ShowS
$cshowList :: [ResponseError] -> ShowS
show :: ResponseError -> String
$cshow :: ResponseError -> String
showsPrec :: Int -> ResponseError -> ShowS
$cshowsPrec :: Int -> ResponseError -> ShowS
Show, ResponseError -> ResponseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseError -> ResponseError -> Bool
$c/= :: ResponseError -> ResponseError -> Bool
== :: ResponseError -> ResponseError -> Bool
$c== :: ResponseError -> ResponseError -> Bool
Eq, 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
$cto :: forall x. Rep ResponseError x -> ResponseError
$cfrom :: forall x. ResponseError -> Rep ResponseError x
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ResponseError" forall a b. (a -> b) -> a -> b
$ \Object
v ->
          (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"
     in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResponseError -> ResponseError
go 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{$sel:_code:ResponseError :: LSPErrorCodes |? ErrorCodes
_code = forall a b. b -> a |? b
InR (forall a. LspOpenEnum a => EnumBaseType a -> a
fromOpenEnumBaseType Int32
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseMessage] -> ShowS
$cshowList :: [ResponseMessage] -> ShowS
show :: ResponseMessage -> String
$cshow :: ResponseMessage -> String
showsPrec :: Int -> ResponseMessage -> ShowS
$cshowsPrec :: Int -> ResponseMessage -> ShowS
Show, ResponseMessage -> ResponseMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseMessage -> ResponseMessage -> Bool
$c/= :: ResponseMessage -> ResponseMessage -> Bool
== :: ResponseMessage -> ResponseMessage -> Bool
$c== :: ResponseMessage -> ResponseMessage -> Bool
Eq, 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
$cto :: forall x. Rep ResponseMessage x -> ResponseMessage
$cfrom :: forall x. ResponseMessage -> Rep ResponseMessage x
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 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
$cto :: forall (f :: MessageDirection) (m :: Method f 'Notification) x.
Rep (TNotificationMessage m) x -> TNotificationMessage m
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Notification) x.
TNotificationMessage m -> Rep (TNotificationMessage m) x
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 = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
lspOptions 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 = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TNotificationMessage m -> Encoding
toEncoding = 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 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
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TRequestMessage m) x -> TRequestMessage m
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TRequestMessage m -> Rep (TRequestMessage m) x
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 = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
lspOptions 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 = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TRequestMessage m -> Encoding
toEncoding = 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 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
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseError m) x -> TResponseError m
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseError m -> Rep (TResponseError m) x
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ResponseError" forall a b. (a -> b) -> a -> b
$ \Object
v ->
          forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"code"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"data"
     in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TResponseError m -> TResponseError m
go 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{$sel:_code:TResponseError :: LSPErrorCodes |? ErrorCodes
_code = forall a b. b -> a |? b
InR (forall a. LspOpenEnum a => EnumBaseType a -> a
fromOpenEnumBaseType Int32
n)}
    go TResponseError m
x = TResponseError m
x
instance (ToJSON (ErrorData m)) => ToJSON (TResponseError m) where
  toJSON :: TResponseError m -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: TResponseError m -> Encoding
toEncoding = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 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
$cto :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
Rep (TResponseMessage m) x -> TResponseMessage m
$cfrom :: forall (f :: MessageDirection) (m :: Method f 'Request) x.
TResponseMessage m -> Rep (TResponseMessage m) x
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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
jsonrpc
      , Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (LspId m)
lspid
      , case Either ResponseError (MessageResult m)
result of
          Left ResponseError
err -> Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ResponseError
err
          Right MessageResult m
a -> Key
"result" forall kv v. (KeyValue 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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Response" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
_jsonrpc <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"jsonrpc"
    Maybe (LspId a)
_id <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    -- It is important to use .:! so that "result = null" (without error) gets decoded as Just Null
    Maybe (MessageResult a)
_result <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:! Key
"result"
    Maybe ResponseError
_error <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error"
    Either ResponseError (MessageResult a)
result <- case (Maybe ResponseError
_error, Maybe (MessageResult a)
_result) of
      (Just ResponseError
err, Maybe (MessageResult a)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ResponseError
err
      (Maybe ResponseError
Nothing, Just MessageResult a
res) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right MessageResult a
res
      (Just ResponseError
_err, Just MessageResult a
_res) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"both error and result cannot be present: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Object
o
      (Maybe ResponseError
Nothing, Maybe (MessageResult a)
Nothing) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"both error and result cannot be Nothing"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) = forall a. ToJSON a => a -> Value
toJSON TRequestMessage ('Method_CustomMethod s)
a
  toJSON (NotMess TNotificationMessage ('Method_CustomMethod s)
a) = 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 = forall (s :: Symbol) (f :: MessageDirection).
TRequestMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Request
ReqMess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (s :: Symbol) (f :: MessageDirection).
TNotificationMessage ('Method_CustomMethod s)
-> TCustomMessage s f 'Notification
NotMess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$ Object
o forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
s forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
J.Null
addNullField String
_ Value
v = Value
v