{-# 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.Scientific
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
    { forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> Text
_jsonrpc :: Text
    , forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> SMethod m
_method  :: SMethod m
    , forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params  :: MessageParams m
    } deriving 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 = 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 (NotificationMessage m) where
  toJSON :: NotificationMessage m -> Value
toJSON     = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: NotificationMessage m -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
lspOptions

data RequestMessage (m :: Method f Request) = RequestMessage
    { forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> Text
_jsonrpc :: Text
    , forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> LspId m
_id      :: LspId m
    , forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> SMethod m
_method  :: SMethod m
    , forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> MessageParams m
_params  :: MessageParams m
    } deriving 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 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
Null
addNullField String
_ Value
v = Value
v

instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where
  parseJSON :: Value -> Parser (RequestMessage 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), FromJSON (SMethod m)) => ToJSON (RequestMessage m) where
  toJSON :: RequestMessage m -> Value
toJSON     = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions
  toEncoding :: RequestMessage m -> Encoding
toEncoding = 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) = forall a. ToJSON a => a -> Value
toJSON RequestMessage 'CustomMethod
a
  toJSON (NotMess NotificationMessage 'CustomMethod
a) = 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 = forall (f :: From).
RequestMessage 'CustomMethod -> CustomMessage 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 FromJSON (CustomMessage p Notification) where
  parseJSON :: Value -> Parser (CustomMessage p 'Notification)
parseJSON Value
v = forall (f :: From).
NotificationMessage 'CustomMethod -> CustomMessage 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

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

data ErrorCode = ParseError
               | InvalidRequest
               | MethodNotFound
               | InvalidParams
               | InternalError
               | ServerErrorStart
               | ServerErrorEnd
               | ServerNotInitialized
               | UnknownErrorCode
               | RequestCancelled
               | ContentModified
               | ServerCancelled
               | RequestFailed
               | ErrorCodeCustom Int32
               -- ^ Note: server error codes are reserved from -32099 to -32000
               deriving (ReadPrec [ErrorCode]
ReadPrec ErrorCode
Int -> ReadS ErrorCode
ReadS [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
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
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)
  toJSON ErrorCode
ServerCancelled      = Scientific -> Value
Number (-Scientific
32802)
  toJSON ErrorCode
RequestFailed        = Scientific -> Value
Number (-Scientific
32803)
  toJSON (ErrorCodeCustom Int32
n)  = Scientific -> Value
Number (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)

instance FromJSON ErrorCode where
  parseJSON :: Value -> Parser ErrorCode
parseJSON (Number (-32700)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ParseError
  parseJSON (Number (-32600)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InvalidRequest
  parseJSON (Number (-32601)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
MethodNotFound
  parseJSON (Number (-32602)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InvalidParams
  parseJSON (Number (-32603)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
InternalError
  parseJSON (Number (-32099)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerErrorStart
  parseJSON (Number (-32000)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerErrorEnd
  parseJSON (Number (-32002)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerNotInitialized
  parseJSON (Number (-32001)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
UnknownErrorCode
  parseJSON (Number (-32800)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
RequestCancelled
  parseJSON (Number (-32801)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ContentModified
  parseJSON (Number (-32802)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
ServerCancelled
  parseJSON (Number (-32803)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorCode
RequestFailed
  parseJSON (Number Scientific
n       ) = case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
    Just Int32
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> ErrorCode
ErrorCodeCustom Int32
i)
    Maybe Int32
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't convert ErrorCode to bounded integer."
  parseJSON Value
_                 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't parse 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]
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
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)

deriveJSON lspOptions ''ResponseError

-- | Either result or error must be Just.
data ResponseMessage (m :: Method f Request) =
  ResponseMessage
    { forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Text
_jsonrpc :: Text
    , forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Maybe (LspId m)
_id      :: Maybe (LspId m)
    , forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result  :: Either ResponseError (ResponseResult m)
    } deriving 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" 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 (ResponseResult m)
result of
        Left  ResponseError
err -> Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ResponseError
err
        Right ResponseResult m
a   -> Key
"result" 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 = 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 (ResponseResult 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 (ResponseResult a)
result   <- case (Maybe ResponseError
_error, Maybe (ResponseResult a)
_result) of
      (Just ResponseError
err, Maybe (ResponseResult 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 ResponseResult 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 ResponseResult a
res
      (Just ResponseError
_err, Just ResponseResult 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 (ResponseResult 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 :: 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