{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeInType                 #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TupleSections              #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module Language.LSP.Types.Message where

import           Language.LSP.Types.CallHierarchy
import           Language.LSP.Types.Cancellation
import           Language.LSP.Types.CodeAction
import           Language.LSP.Types.CodeLens
import           Language.LSP.Types.Command
import           Language.LSP.Types.Common
import           Language.LSP.Types.Configuration
import           Language.LSP.Types.Completion
import           Language.LSP.Types.Declaration
import           Language.LSP.Types.Definition
import           Language.LSP.Types.Diagnostic
import           Language.LSP.Types.DocumentColor
import           Language.LSP.Types.DocumentHighlight
import           Language.LSP.Types.DocumentLink
import           Language.LSP.Types.DocumentSymbol
import           Language.LSP.Types.FoldingRange
import           Language.LSP.Types.Formatting
import           Language.LSP.Types.Hover
import           Language.LSP.Types.Implementation
import           Language.LSP.Types.Initialize
import           Language.LSP.Types.Location
import           Language.LSP.Types.LspId
import           Language.LSP.Types.Method
import           Language.LSP.Types.Progress
import           Language.LSP.Types.Registration
import           Language.LSP.Types.Rename
import           Language.LSP.Types.References
import           Language.LSP.Types.SelectionRange
import           Language.LSP.Types.SemanticTokens
import           Language.LSP.Types.SignatureHelp
import           Language.LSP.Types.TextDocument
import           Language.LSP.Types.TypeDefinition
import           Language.LSP.Types.Utils
import           Language.LSP.Types.Window
import           Language.LSP.Types.WatchedFiles
import           Language.LSP.Types.WorkspaceEdit
import           Language.LSP.Types.WorkspaceFolders
import           Language.LSP.Types.WorkspaceSymbol

import Data.Kind
import Data.Aeson
import Data.Aeson.TH
import Data.Text (Text)
import Data.String
import GHC.Generics

-- ---------------------------------------------------------------------
-- PARAMS definition
-- Map Methods to params/responses
-- ---------------------------------------------------------------------

-- | Map a method to the message payload type
type family MessageParams (m :: Method f t) :: Type where
-- Client
  -- General
  MessageParams Initialize                         = InitializeParams
  MessageParams Initialized                        = Maybe InitializedParams
  MessageParams Shutdown                           = Empty
  MessageParams Exit                               = Empty
  -- Workspace
  MessageParams WorkspaceDidChangeWorkspaceFolders = DidChangeWorkspaceFoldersParams
  MessageParams WorkspaceDidChangeConfiguration    = DidChangeConfigurationParams
  MessageParams WorkspaceDidChangeWatchedFiles     = DidChangeWatchedFilesParams
  MessageParams WorkspaceSymbol                    = WorkspaceSymbolParams
  MessageParams WorkspaceExecuteCommand            = ExecuteCommandParams
  -- Sync/Document state
  MessageParams TextDocumentDidOpen                = DidOpenTextDocumentParams
  MessageParams TextDocumentDidChange              = DidChangeTextDocumentParams
  MessageParams TextDocumentWillSave               = WillSaveTextDocumentParams
  MessageParams TextDocumentWillSaveWaitUntil      = WillSaveTextDocumentParams
  MessageParams TextDocumentDidSave                = DidSaveTextDocumentParams
  MessageParams TextDocumentDidClose               = DidCloseTextDocumentParams
  -- Completion
  MessageParams TextDocumentCompletion             = CompletionParams
  MessageParams CompletionItemResolve              = CompletionItem
  -- Language Queries
  MessageParams TextDocumentHover                  = HoverParams
  MessageParams TextDocumentSignatureHelp          = SignatureHelpParams
  MessageParams TextDocumentDeclaration            = DeclarationParams
  MessageParams TextDocumentDefinition             = DefinitionParams
  MessageParams TextDocumentTypeDefinition         = TypeDefinitionParams
  MessageParams TextDocumentImplementation         = ImplementationParams
  MessageParams TextDocumentReferences             = ReferenceParams
  MessageParams TextDocumentDocumentHighlight      = DocumentHighlightParams
  MessageParams TextDocumentDocumentSymbol         = DocumentSymbolParams
  -- Code Action/Lens/Link
  MessageParams TextDocumentCodeAction             = CodeActionParams
  MessageParams TextDocumentCodeLens               = CodeLensParams
  MessageParams CodeLensResolve                    = CodeLens
  MessageParams TextDocumentDocumentLink           = DocumentLinkParams
  MessageParams DocumentLinkResolve                = DocumentLink
  -- Syntax highlighting/coloring
  MessageParams TextDocumentDocumentColor          = DocumentColorParams
  MessageParams TextDocumentColorPresentation      = ColorPresentationParams
  -- Formatting
  MessageParams TextDocumentFormatting             = DocumentFormattingParams
  MessageParams TextDocumentRangeFormatting        = DocumentRangeFormattingParams
  MessageParams TextDocumentOnTypeFormatting       = DocumentOnTypeFormattingParams
  -- Rename
  MessageParams TextDocumentRename                 = RenameParams
  MessageParams TextDocumentPrepareRename          = PrepareRenameParams
  -- Folding Range
  MessageParams TextDocumentFoldingRange           = FoldingRangeParams
  -- Selection Range
  MessageParams TextDocumentSelectionRange         = SelectionRangeParams
  -- Call hierarchy
  MessageParams TextDocumentPrepareCallHierarchy   = CallHierarchyPrepareParams
  MessageParams CallHierarchyIncomingCalls         = CallHierarchyIncomingCallsParams
  MessageParams CallHierarchyOutgoingCalls         = CallHierarchyOutgoingCallsParams
  -- Semantic tokens 
  MessageParams TextDocumentSemanticTokens         = Empty
  MessageParams TextDocumentSemanticTokensFull     = SemanticTokensParams
  MessageParams TextDocumentSemanticTokensFullDelta = SemanticTokensDeltaParams
  MessageParams TextDocumentSemanticTokensRange    = SemanticTokensRangeParams 
  MessageParams WorkspaceSemanticTokensRefresh     = Empty
-- Server
  -- Window
  MessageParams WindowShowMessage                  = ShowMessageParams
  MessageParams WindowShowMessageRequest           = ShowMessageRequestParams
  MessageParams WindowShowDocument                 = ShowDocumentParams
  MessageParams WindowLogMessage                   = LogMessageParams
  -- Progress
  MessageParams WindowWorkDoneProgressCreate       = WorkDoneProgressCreateParams
  MessageParams WindowWorkDoneProgressCancel       = WorkDoneProgressCancelParams
  MessageParams Progress                           = ProgressParams SomeProgressParams
  -- Telemetry
  MessageParams TelemetryEvent                     = Value
  -- Client
  MessageParams ClientRegisterCapability           = RegistrationParams
  MessageParams ClientUnregisterCapability         = UnregistrationParams
  -- Workspace
  MessageParams WorkspaceWorkspaceFolders          = Empty
  MessageParams WorkspaceConfiguration             = ConfigurationParams
  MessageParams WorkspaceApplyEdit                 = ApplyWorkspaceEditParams
  -- Document/Diagnostic
  MessageParams TextDocumentPublishDiagnostics     = PublishDiagnosticsParams
  -- Cancel
  MessageParams CancelRequest                      = CancelParams
  -- Custom
  MessageParams CustomMethod                       = Value

-- | Map a request method to the response payload type
type family ResponseResult (m :: Method f Request) :: Type where
-- Even though the specification mentions that the result types are
-- @x | y | ... | null@, they don't actually need to be wrapped in a Maybe since
-- (we think) this is just to account for how the response field is always
-- nullable. I.e. if it is null, then the error field is set

-- Client
  -- General
  ResponseResult Initialize                    = InitializeResult
  ResponseResult Shutdown                      = Empty
  -- Workspace
  ResponseResult WorkspaceSymbol               = List SymbolInformation
  ResponseResult WorkspaceExecuteCommand       = Value
  -- Sync/Document state
  ResponseResult TextDocumentWillSaveWaitUntil = List TextEdit
  -- Completion
  ResponseResult TextDocumentCompletion        = List CompletionItem |? CompletionList
  ResponseResult CompletionItemResolve         = CompletionItem
  -- Language Queries
  ResponseResult TextDocumentHover             = Maybe Hover
  ResponseResult TextDocumentSignatureHelp     = SignatureHelp
  ResponseResult TextDocumentDeclaration       = Location |? List Location |? List LocationLink
  ResponseResult TextDocumentDefinition        = Location |? List Location |? List LocationLink
  ResponseResult TextDocumentTypeDefinition    = Location |? List Location |? List LocationLink
  ResponseResult TextDocumentImplementation    = Location |? List Location |? List LocationLink
  ResponseResult TextDocumentReferences        = List Location
  ResponseResult TextDocumentDocumentHighlight = List DocumentHighlight
  ResponseResult TextDocumentDocumentSymbol    = List DocumentSymbol |? List SymbolInformation
  -- Code Action/Lens/Link
  ResponseResult TextDocumentCodeAction        = List (Command |? CodeAction)
  ResponseResult TextDocumentCodeLens          = List CodeLens
  ResponseResult CodeLensResolve               = CodeLens
  ResponseResult TextDocumentDocumentLink      = List DocumentLink
  ResponseResult DocumentLinkResolve           = DocumentLink
  -- Syntax highlighting/coloring
  ResponseResult TextDocumentDocumentColor     = List ColorInformation
  ResponseResult TextDocumentColorPresentation = List ColorPresentation
  -- Formatting
  ResponseResult TextDocumentFormatting        = List TextEdit
  ResponseResult TextDocumentRangeFormatting   = List TextEdit
  ResponseResult TextDocumentOnTypeFormatting  = List TextEdit
  -- Rename
  ResponseResult TextDocumentRename            = WorkspaceEdit
  ResponseResult TextDocumentPrepareRename     = Maybe (Range |? RangeWithPlaceholder)
  -- FoldingRange
  ResponseResult TextDocumentFoldingRange      = List FoldingRange
  ResponseResult TextDocumentSelectionRange    = List SelectionRange
  -- Call hierarchy
  ResponseResult TextDocumentPrepareCallHierarchy = Maybe (List CallHierarchyItem)
  ResponseResult CallHierarchyIncomingCalls    = Maybe (List CallHierarchyIncomingCall)
  ResponseResult CallHierarchyOutgoingCalls    = Maybe (List CallHierarchyOutgoingCall)
  -- Semantic tokens 
  ResponseResult TextDocumentSemanticTokens          = Empty
  ResponseResult TextDocumentSemanticTokensFull      = Maybe SemanticTokens
  ResponseResult TextDocumentSemanticTokensFullDelta = Maybe (SemanticTokens |? SemanticTokensDelta)
  ResponseResult TextDocumentSemanticTokensRange     = Maybe SemanticTokens 
  ResponseResult WorkspaceSemanticTokensRefresh      = Empty
  -- Custom can be either a notification or a message
-- Server
  -- Window
  ResponseResult WindowShowMessageRequest      = Maybe MessageActionItem
  ResponseResult WindowShowDocument            = ShowDocumentResult
  ResponseResult WindowWorkDoneProgressCreate  = Empty
  -- Capability
  ResponseResult ClientRegisterCapability      = Empty
  ResponseResult ClientUnregisterCapability    = Empty
  -- Workspace
  ResponseResult WorkspaceWorkspaceFolders     = Maybe (List WorkspaceFolder)
  ResponseResult WorkspaceConfiguration        = List Value
  ResponseResult WorkspaceApplyEdit            = ApplyWorkspaceEditResponseBody
-- Custom
  ResponseResult CustomMethod                  = Value


-- ---------------------------------------------------------------------
{-
$ Notifications and Requests

Notification and requests ids starting with '$/' are messages which are protocol
implementation dependent and might not be implementable in all clients or
servers. For example if the server implementation uses a single threaded
synchronous programming language then there is little a server can do to react
to a '$/cancelRequest'. If a server or client receives notifications or requests
starting with '$/' it is free to ignore them if they are unknown.

-}

data NotificationMessage (m :: Method f Notification) =
  NotificationMessage
    { NotificationMessage m -> Text
_jsonrpc :: Text
    , NotificationMessage m -> SMethod m
_method  :: SMethod m
    , NotificationMessage m -> MessageParams m
_params  :: MessageParams m
    } deriving (forall x. NotificationMessage m -> Rep (NotificationMessage m) x)
-> (forall x.
    Rep (NotificationMessage m) x -> NotificationMessage m)
-> Generic (NotificationMessage m)
forall x. Rep (NotificationMessage m) x -> NotificationMessage m
forall x. NotificationMessage m -> Rep (NotificationMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: From) (m :: Method f 'Notification) x.
Rep (NotificationMessage m) x -> NotificationMessage m
forall (f :: From) (m :: Method f 'Notification) x.
NotificationMessage m -> Rep (NotificationMessage m) x
$cto :: forall (f :: From) (m :: Method f 'Notification) x.
Rep (NotificationMessage m) x -> NotificationMessage m
$cfrom :: forall (f :: From) (m :: Method f 'Notification) x.
NotificationMessage m -> Rep (NotificationMessage m) x
Generic

deriving instance Eq   (MessageParams m) => Eq (NotificationMessage m)
deriving instance Show (MessageParams m) => Show (NotificationMessage m)

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

data RequestMessage (m :: Method f Request) = RequestMessage
    { RequestMessage m -> Text
_jsonrpc :: Text
    , RequestMessage m -> LspId m
_id      :: LspId m
    , RequestMessage m -> SMethod m
_method  :: SMethod m
    , RequestMessage m -> MessageParams m
_params  :: MessageParams m
    } deriving (forall x. RequestMessage m -> Rep (RequestMessage m) x)
-> (forall x. Rep (RequestMessage m) x -> RequestMessage m)
-> Generic (RequestMessage m)
forall x. Rep (RequestMessage m) x -> RequestMessage m
forall x. RequestMessage m -> Rep (RequestMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: From) (m :: Method f 'Request) x.
Rep (RequestMessage m) x -> RequestMessage m
forall (f :: From) (m :: Method f 'Request) x.
RequestMessage m -> Rep (RequestMessage m) x
$cto :: forall (f :: From) (m :: Method f 'Request) x.
Rep (RequestMessage m) x -> RequestMessage m
$cfrom :: forall (f :: From) (m :: Method f 'Request) x.
RequestMessage m -> Rep (RequestMessage m) x
Generic

deriving instance Eq   (MessageParams m) => Eq (RequestMessage m)
deriving instance (Read (SMethod m), Read (MessageParams m)) => Read (RequestMessage m)
deriving instance Show (MessageParams m) => Show (RequestMessage 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
Null
addNullField String
_ Value
v = Value
v

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

-- | A custom message data type is needed to distinguish between
-- notifications and requests, since a CustomMethod can be both!
data CustomMessage f t where
  ReqMess :: RequestMessage (CustomMethod :: Method f Request) -> CustomMessage f Request
  NotMess :: NotificationMessage (CustomMethod :: Method f Notification) -> CustomMessage f Notification

deriving instance Show (CustomMessage p t)

instance ToJSON (CustomMessage p t) where
  toJSON :: CustomMessage p t -> Value
toJSON (ReqMess RequestMessage 'CustomMethod
a) = RequestMessage 'CustomMethod -> Value
forall a. ToJSON a => a -> Value
toJSON RequestMessage 'CustomMethod
a
  toJSON (NotMess NotificationMessage 'CustomMethod
a) = NotificationMessage 'CustomMethod -> Value
forall a. ToJSON a => a -> Value
toJSON NotificationMessage 'CustomMethod
a

instance FromJSON (CustomMessage p Request) where
  parseJSON :: Value -> Parser (CustomMessage p 'Request)
parseJSON Value
v = RequestMessage 'CustomMethod -> CustomMessage p 'Request
forall (f :: From).
RequestMessage 'CustomMethod -> CustomMessage f 'Request
ReqMess (RequestMessage 'CustomMethod -> CustomMessage p 'Request)
-> Parser (RequestMessage 'CustomMethod)
-> Parser (CustomMessage p 'Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (RequestMessage 'CustomMethod)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
instance FromJSON (CustomMessage p Notification) where
  parseJSON :: Value -> Parser (CustomMessage p 'Notification)
parseJSON Value
v = NotificationMessage 'CustomMethod -> CustomMessage p 'Notification
forall (f :: From).
NotificationMessage 'CustomMethod -> CustomMessage f 'Notification
NotMess (NotificationMessage 'CustomMethod
 -> CustomMessage p 'Notification)
-> Parser (NotificationMessage 'CustomMethod)
-> Parser (CustomMessage p 'Notification)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (NotificationMessage 'CustomMethod)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- ---------------------------------------------------------------------
-- Response Message
-- ---------------------------------------------------------------------

data ErrorCode = ParseError
               | InvalidRequest
               | MethodNotFound
               | InvalidParams
               | InternalError
               | ServerErrorStart
               | ServerErrorEnd
               | ServerNotInitialized
               | UnknownErrorCode
               | RequestCancelled
               | ContentModified
               -- ^ Note: server error codes are reserved from -32099 to -32000
               deriving (ReadPrec [ErrorCode]
ReadPrec ErrorCode
Int -> ReadS ErrorCode
ReadS [ErrorCode]
(Int -> ReadS ErrorCode)
-> ReadS [ErrorCode]
-> ReadPrec ErrorCode
-> ReadPrec [ErrorCode]
-> Read ErrorCode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ErrorCode]
$creadListPrec :: ReadPrec [ErrorCode]
readPrec :: ReadPrec ErrorCode
$creadPrec :: ReadPrec ErrorCode
readList :: ReadS [ErrorCode]
$creadList :: ReadS [ErrorCode]
readsPrec :: Int -> ReadS ErrorCode
$creadsPrec :: Int -> ReadS ErrorCode
Read,Int -> ErrorCode -> ShowS
[ErrorCode] -> ShowS
ErrorCode -> String
(Int -> ErrorCode -> ShowS)
-> (ErrorCode -> String)
-> ([ErrorCode] -> ShowS)
-> Show ErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorCode] -> ShowS
$cshowList :: [ErrorCode] -> ShowS
show :: ErrorCode -> String
$cshow :: ErrorCode -> String
showsPrec :: Int -> ErrorCode -> ShowS
$cshowsPrec :: Int -> ErrorCode -> ShowS
Show,ErrorCode -> ErrorCode -> Bool
(ErrorCode -> ErrorCode -> Bool)
-> (ErrorCode -> ErrorCode -> Bool) -> Eq ErrorCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorCode -> ErrorCode -> Bool
$c/= :: ErrorCode -> ErrorCode -> Bool
== :: ErrorCode -> ErrorCode -> Bool
$c== :: ErrorCode -> ErrorCode -> Bool
Eq)

instance ToJSON ErrorCode where
  toJSON :: ErrorCode -> Value
toJSON ErrorCode
ParseError           = Scientific -> Value
Number (-Scientific
32700)
  toJSON ErrorCode
InvalidRequest       = Scientific -> Value
Number (-Scientific
32600)
  toJSON ErrorCode
MethodNotFound       = Scientific -> Value
Number (-Scientific
32601)
  toJSON ErrorCode
InvalidParams        = Scientific -> Value
Number (-Scientific
32602)
  toJSON ErrorCode
InternalError        = Scientific -> Value
Number (-Scientific
32603)
  toJSON ErrorCode
ServerErrorStart     = Scientific -> Value
Number (-Scientific
32099)
  toJSON ErrorCode
ServerErrorEnd       = Scientific -> Value
Number (-Scientific
32000)
  toJSON ErrorCode
ServerNotInitialized = Scientific -> Value
Number (-Scientific
32002)
  toJSON ErrorCode
UnknownErrorCode     = Scientific -> Value
Number (-Scientific
32001)
  toJSON ErrorCode
RequestCancelled     = Scientific -> Value
Number (-Scientific
32800)
  toJSON ErrorCode
ContentModified      = Scientific -> Value
Number (-Scientific
32801)

instance FromJSON ErrorCode where
  parseJSON :: Value -> Parser ErrorCode
parseJSON (Number (-32700)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ParseError
  parseJSON (Number (-32600)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InvalidRequest
  parseJSON (Number (-32601)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
MethodNotFound
  parseJSON (Number (-32602)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InvalidParams
  parseJSON (Number (-32603)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InternalError
  parseJSON (Number (-32099)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerErrorStart
  parseJSON (Number (-32000)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerErrorEnd
  parseJSON (Number (-32002)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerNotInitialized
  parseJSON (Number (-32001)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
UnknownErrorCode
  parseJSON (Number (-32800)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
RequestCancelled
  parseJSON (Number (-32801)) = ErrorCode -> Parser ErrorCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ContentModified
  parseJSON Value
_                 = String -> Parser ErrorCode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ErrorCode"

-- -------------------------------------

data ResponseError =
  ResponseError
    { ResponseError -> ErrorCode
_code    :: ErrorCode
    , ResponseError -> Text
_message :: Text
    , ResponseError -> Maybe Value
_xdata   :: Maybe Value
    } deriving (ReadPrec [ResponseError]
ReadPrec ResponseError
Int -> ReadS ResponseError
ReadS [ResponseError]
(Int -> ReadS ResponseError)
-> ReadS [ResponseError]
-> ReadPrec ResponseError
-> ReadPrec [ResponseError]
-> Read ResponseError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ResponseError]
$creadListPrec :: ReadPrec [ResponseError]
readPrec :: ReadPrec ResponseError
$creadPrec :: ReadPrec ResponseError
readList :: ReadS [ResponseError]
$creadList :: ReadS [ResponseError]
readsPrec :: Int -> ReadS ResponseError
$creadsPrec :: Int -> ReadS ResponseError
Read,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
showList :: [ResponseError] -> ShowS
$cshowList :: [ResponseError] -> ShowS
show :: ResponseError -> String
$cshow :: ResponseError -> String
showsPrec :: Int -> ResponseError -> ShowS
$cshowsPrec :: Int -> ResponseError -> ShowS
Show,ResponseError -> ResponseError -> Bool
(ResponseError -> ResponseError -> Bool)
-> (ResponseError -> ResponseError -> Bool) -> Eq ResponseError
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)

deriveJSON lspOptions ''ResponseError

-- | Either result or error must be Just.
data ResponseMessage (m :: Method f Request) =
  ResponseMessage
    { ResponseMessage m -> Text
_jsonrpc :: Text
    , ResponseMessage m -> Maybe (LspId m)
_id      :: Maybe (LspId m)
    , ResponseMessage m -> Either ResponseError (ResponseResult m)
_result  :: Either ResponseError (ResponseResult m)
    } deriving (forall x. ResponseMessage m -> Rep (ResponseMessage m) x)
-> (forall x. Rep (ResponseMessage m) x -> ResponseMessage m)
-> Generic (ResponseMessage m)
forall x. Rep (ResponseMessage m) x -> ResponseMessage m
forall x. ResponseMessage m -> Rep (ResponseMessage m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: From) (m :: Method f 'Request) x.
Rep (ResponseMessage m) x -> ResponseMessage m
forall (f :: From) (m :: Method f 'Request) x.
ResponseMessage m -> Rep (ResponseMessage m) x
$cto :: forall (f :: From) (m :: Method f 'Request) x.
Rep (ResponseMessage m) x -> ResponseMessage m
$cfrom :: forall (f :: From) (m :: Method f 'Request) x.
ResponseMessage m -> Rep (ResponseMessage m) x
Generic

deriving instance Eq   (ResponseResult m) => Eq (ResponseMessage m)
deriving instance Read (ResponseResult m) => Read (ResponseMessage m)
deriving instance Show (ResponseResult m) => Show (ResponseMessage m)

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

instance FromJSON (ResponseResult a) => FromJSON (ResponseMessage a) where
  parseJSON :: Value -> Parser (ResponseMessage a)
parseJSON = String
-> (Object -> Parser (ResponseMessage a))
-> Value
-> Parser (ResponseMessage a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Response" ((Object -> Parser (ResponseMessage a))
 -> Value -> Parser (ResponseMessage a))
-> (Object -> Parser (ResponseMessage a))
-> Value
-> Parser (ResponseMessage 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"
    -- It is important to use .:! so that "result = null" (without error) gets decoded as Just Null
    Maybe (ResponseResult a)
_result  <- Object
o Object -> Key -> Parser (Maybe (ResponseResult a))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:! Key
"result"
    Maybe ResponseError
_error   <- Object
o Object -> Key -> Parser (Maybe ResponseError)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error"
    Either ResponseError (ResponseResult a)
result   <- case (Maybe ResponseError
_error, Maybe (ResponseResult a)
_result) of
      (Just ResponseError
err, Maybe (ResponseResult a)
Nothing) -> Either ResponseError (ResponseResult a)
-> Parser (Either ResponseError (ResponseResult a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult a)
 -> Parser (Either ResponseError (ResponseResult a)))
-> Either ResponseError (ResponseResult a)
-> Parser (Either ResponseError (ResponseResult a))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (ResponseResult a)
forall a b. a -> Either a b
Left ResponseError
err
      (Maybe ResponseError
Nothing, Just ResponseResult a
res) -> Either ResponseError (ResponseResult a)
-> Parser (Either ResponseError (ResponseResult a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult a)
 -> Parser (Either ResponseError (ResponseResult a)))
-> Either ResponseError (ResponseResult a)
-> Parser (Either ResponseError (ResponseResult a))
forall a b. (a -> b) -> a -> b
$ ResponseResult a -> Either ResponseError (ResponseResult a)
forall a b. b -> Either a b
Right ResponseResult a
res
      (Just ResponseError
_err, Just ResponseResult a
_res) -> String -> Parser (Either ResponseError (ResponseResult a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Either ResponseError (ResponseResult a)))
-> String -> Parser (Either ResponseError (ResponseResult 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 (ResponseResult a)
Nothing) -> String -> Parser (Either ResponseError (ResponseResult a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"both error and result cannot be Nothing"
    ResponseMessage a -> Parser (ResponseMessage a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseMessage a -> Parser (ResponseMessage a))
-> ResponseMessage a -> Parser (ResponseMessage a)
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId a)
-> Either ResponseError (ResponseResult a)
-> ResponseMessage a
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (ResponseResult m)
-> ResponseMessage m
ResponseMessage Text
_jsonrpc Maybe (LspId a)
_id Either ResponseError (ResponseResult a)
result

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

-- | Map a method to the Request/Notification type with the correct
-- payload
type family Message (m :: Method f t) :: Type where
  Message (CustomMethod :: Method f t) = CustomMessage f t
  Message (m :: Method f Request) = RequestMessage m
  Message (m :: Method f Notification) = NotificationMessage m

-- Some helpful type synonyms
type ClientMessage (m :: Method FromClient t) = Message m
type ServerMessage (m :: Method FromServer t) = Message m