diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,8 @@ # Revision history for haskell-lsp-types +* ResponseMessage results are now an Either type (@greenhat) +* Support for GHC 8.10.1 + ## 0.21.0.0 * Stop getCompletionPrefix from crashing if beforePos is empty diff --git a/haskell-lsp-types.cabal b/haskell-lsp-types.cabal --- a/haskell-lsp-types.cabal +++ b/haskell-lsp-types.cabal @@ -1,5 +1,5 @@ name: haskell-lsp-types -version: 0.21.0.0 +version: 0.22.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to @@ -10,7 +10,7 @@ license-file: LICENSE author: Alan Zimmerman maintainer: alan.zimm@gmail.com -copyright: Alan Zimmerman, 2016-2018 +copyright: Alan Zimmerman, 2016-2020 category: Development build-type: Simple extra-source-files: ChangeLog.md, README.md @@ -32,6 +32,7 @@ , Language.Haskell.LSP.Types.Diagnostic , Language.Haskell.LSP.Types.DocumentFilter , Language.Haskell.LSP.Types.FoldingRange + , Language.Haskell.LSP.Types.Hover , Language.Haskell.LSP.Types.List , Language.Haskell.LSP.Types.Location , Language.Haskell.LSP.Types.MarkupContent @@ -46,7 +47,7 @@ -- other-extensions: ghc-options: -Wall -- ghc-options: -Werror - build-depends: base >= 4.9 && < 4.14 + build-depends: base >= 4.9 && < 4.15 , aeson >=1.2.2.0 , binary , bytestring diff --git a/src/Language/Haskell/LSP/Types.hs b/src/Language/Haskell/LSP/Types.hs --- a/src/Language/Haskell/LSP/Types.hs +++ b/src/Language/Haskell/LSP/Types.hs @@ -7,6 +7,7 @@ , module Language.Haskell.LSP.Types.Diagnostic , module Language.Haskell.LSP.Types.DocumentFilter , module Language.Haskell.LSP.Types.FoldingRange + , module Language.Haskell.LSP.Types.Hover , module Language.Haskell.LSP.Types.List , module Language.Haskell.LSP.Types.Location , module Language.Haskell.LSP.Types.MarkupContent @@ -29,6 +30,7 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.MarkupContent diff --git a/src/Language/Haskell/LSP/Types/DataTypesJSON.hs b/src/Language/Haskell/LSP/Types/DataTypesJSON.hs --- a/src/Language/Haskell/LSP/Types/DataTypesJSON.hs +++ b/src/Language/Haskell/LSP/Types/DataTypesJSON.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -28,7 +27,6 @@ import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.List import Language.Haskell.LSP.Types.Location -import Language.Haskell.LSP.Types.MarkupContent import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Progress import Language.Haskell.LSP.Types.Symbol @@ -1725,138 +1723,6 @@ type PublishDiagnosticsNotification = NotificationMessage ServerMethod PublishDiagnosticsParams - --- --------------------------------------------------------------------- -{- -Hover Request - -The hover request is sent from the client to the server to request hover -information at a given text document position. - - Changed: In 2.0 the request uses TextDocumentPositionParams with a proper - textDocument and position property. In 1.0 the uri of the referenced text - document was inlined into the params object. - -Request - - method: 'textDocument/hover' - params: TextDocumentPositionParams - -Response - - result: Hover | null defined as follows: - - -/** - * The result of a hover request. - */ -interface Hover { - /** - * The hover's content - */ - contents: MarkedString | MarkedString[] | MarkupContent; - - /** - * An optional range is a range inside a text document - * that is used to visualize a hover, e.g. by changing the background color. - */ - range?: Range; -} - - -/** - * MarkedString can be used to render human readable text. It is either a markdown string - * or a code-block that provides a language and a code snippet. The language identifier - * is semantically equal to the optional language identifier in fenced code blocks in GitHub - * issues. See https://help.github.com/articles/creating-and-highlighting-code-blocks/#syntax-highlighting - * - * The pair of a language and a value is an equivalent to markdown: - * ```${language} - * ${value} - * ``` - * - * Note that markdown strings will be sanitized - that means html will be escaped. -* @deprecated use MarkupContent instead. -*/ -type MarkedString = string | { language: string; value: string }; - - error: code and message set in case an exception happens during the hover - request. - -Registration Options: TextDocumentRegistrationOptions - --} - -data LanguageString = - LanguageString - { _language :: Text - , _value :: Text - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''LanguageString - -{-# DEPRECATED MarkedString, PlainString, CodeString "Use MarkupContent instead, since 3.3.0 (11/24/2017)" #-} -data MarkedString = - PlainString T.Text - | CodeString LanguageString - deriving (Eq,Read,Show) - -instance ToJSON MarkedString where - toJSON (PlainString x) = toJSON x - toJSON (CodeString x) = toJSON x -instance FromJSON MarkedString where - parseJSON (A.String t) = pure $ PlainString t - parseJSON o = CodeString <$> parseJSON o - --- ------------------------------------- - -data HoverContents = - HoverContentsMS (List MarkedString) - | HoverContents MarkupContent - deriving (Read,Show,Eq) - -instance ToJSON HoverContents where - toJSON (HoverContentsMS x) = toJSON x - toJSON (HoverContents x) = toJSON x -instance FromJSON HoverContents where - parseJSON v@(A.String _) = HoverContentsMS <$> parseJSON v - parseJSON v@(A.Array _) = HoverContentsMS <$> parseJSON v - parseJSON v@(A.Object _) = HoverContents <$> parseJSON v - <|> HoverContentsMS <$> parseJSON v - parseJSON _ = mempty - --- ------------------------------------- - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup HoverContents where - (<>) = mappend -#endif - -instance Monoid HoverContents where - mempty = HoverContentsMS (List []) - - HoverContents h1 `mappend` HoverContents h2 = HoverContents (h1 `mappend` h2) - HoverContents h1 `mappend` HoverContentsMS (List h2s) = HoverContents (mconcat (h1: (map toMarkupContent h2s))) - HoverContentsMS (List h1s) `mappend` HoverContents h2 = HoverContents (mconcat ((map toMarkupContent h1s) ++ [h2])) - HoverContentsMS (List h1s) `mappend` HoverContentsMS (List h2s) = HoverContentsMS (List (h1s `mappend` h2s)) - -toMarkupContent :: MarkedString -> MarkupContent -toMarkupContent (PlainString s) = unmarkedUpContent s -toMarkupContent (CodeString (LanguageString lang s)) = markedUpContent lang s - --- ------------------------------------- - -data Hover = - Hover - { _contents :: HoverContents - , _range :: Maybe Range - } deriving (Read,Show,Eq) - -deriveJSON lspOptions ''Hover - - -type HoverRequest = RequestMessage ClientMethod TextDocumentPositionParams (Maybe Hover) -type HoverResponse = ResponseMessage (Maybe Hover) -- --------------------------------------------------------------------- {- diff --git a/src/Language/Haskell/LSP/Types/Hover.hs b/src/Language/Haskell/LSP/Types/Hover.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Types/Hover.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Language.Haskell.LSP.Types.Hover where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.TH +import Data.Text ( Text ) +import Language.Haskell.LSP.Types.Constants +import Language.Haskell.LSP.Types.List +import Language.Haskell.LSP.Types.Location +import Language.Haskell.LSP.Types.MarkupContent +import Language.Haskell.LSP.Types.Message +import Language.Haskell.LSP.Types.TextDocument + +-- --------------------------------------------------------------------- + +{- +/** + * MarkedString can be used to render human readable text. It is either a markdown string + * or a code-block that provides a language and a code snippet. The language identifier + * is semantically equal to the optional language identifier in fenced code blocks in GitHub + * issues. See https://help.github.com/articles/creating-and-highlighting-code-blocks/#syntax-highlighting + * + * The pair of a language and a value is an equivalent to markdown: + * ```${language} + * ${value} + * ``` + * + * Note that markdown strings will be sanitized - that means html will be escaped. +* @deprecated use MarkupContent instead. +*/ +type MarkedString = string | { language: string; value: string }; + + error: code and message set in case an exception happens during the hover + request. + +Registration Options: TextDocumentRegistrationOptions + +-} + +data LanguageString = + LanguageString + { _language :: Text + , _value :: Text + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''LanguageString + +{-# DEPRECATED MarkedString, PlainString, CodeString "Use MarkupContent instead, since 3.3.0 (11/24/2017)" #-} +data MarkedString = + PlainString Text + | CodeString LanguageString + deriving (Eq,Read,Show) + +instance ToJSON MarkedString where + toJSON (PlainString x) = toJSON x + toJSON (CodeString x) = toJSON x +instance FromJSON MarkedString where + parseJSON (String t) = pure $ PlainString t + parseJSON o = CodeString <$> parseJSON o + +-- --------------------------------------------------------------------- +{- +Hover Request + +The hover request is sent from the client to the server to request hover +information at a given text document position. + + Changed: In 2.0 the request uses TextDocumentPositionParams with a proper + textDocument and position property. In 1.0 the uri of the referenced text + document was inlined into the params object. + +Request + + method: 'textDocument/hover' + params: TextDocumentPositionParams + +Response + + result: Hover | null defined as follows: + + +/** + * The result of a hover request. + */ +interface Hover { + /** + * The hover's content + */ + contents: MarkedString | MarkedString[] | MarkupContent; + + /** + * An optional range is a range inside a text document + * that is used to visualize a hover, e.g. by changing the background color. + */ + range?: Range; +} + +-} + + +-- ------------------------------------- + +data HoverContents = + HoverContentsMS (List MarkedString) + | HoverContents MarkupContent + deriving (Read,Show,Eq) + +instance ToJSON HoverContents where + toJSON (HoverContentsMS x) = toJSON x + toJSON (HoverContents x) = toJSON x +instance FromJSON HoverContents where + parseJSON v@(String _) = HoverContentsMS <$> parseJSON v + parseJSON v@(Array _) = HoverContentsMS <$> parseJSON v + parseJSON v@(Object _) = HoverContents <$> parseJSON v + <|> HoverContentsMS <$> parseJSON v + parseJSON _ = mempty + +-- ------------------------------------- + +#if __GLASGOW_HASKELL__ >= 804 +instance Semigroup HoverContents where + (<>) = mappend +#endif + +instance Monoid HoverContents where + mempty = HoverContentsMS (List []) + + HoverContents h1 `mappend` HoverContents h2 = HoverContents (h1 `mappend` h2) + HoverContents h1 `mappend` HoverContentsMS (List h2s) = HoverContents (mconcat (h1: (map toMarkupContent h2s))) + HoverContentsMS (List h1s) `mappend` HoverContents h2 = HoverContents (mconcat ((map toMarkupContent h1s) ++ [h2])) + HoverContentsMS (List h1s) `mappend` HoverContentsMS (List h2s) = HoverContentsMS (List (h1s `mappend` h2s)) + +toMarkupContent :: MarkedString -> MarkupContent +toMarkupContent (PlainString s) = unmarkedUpContent s +toMarkupContent (CodeString (LanguageString lang s)) = markedUpContent lang s + +-- ------------------------------------- + +data Hover = + Hover + { _contents :: HoverContents + , _range :: Maybe Range + } deriving (Read,Show,Eq) + +deriveJSON lspOptions ''Hover + +type HoverRequest = RequestMessage ClientMethod TextDocumentPositionParams (Maybe Hover) +type HoverResponse = ResponseMessage (Maybe Hover) diff --git a/src/Language/Haskell/LSP/Types/Lens.hs b/src/Language/Haskell/LSP/Types/Lens.hs --- a/src/Language/Haskell/LSP/Types/Lens.hs +++ b/src/Language/Haskell/LSP/Types/Lens.hs @@ -14,6 +14,7 @@ import Language.Haskell.LSP.Types.Diagnostic import Language.Haskell.LSP.Types.DocumentFilter import Language.Haskell.LSP.Types.FoldingRange +import Language.Haskell.LSP.Types.Hover import Language.Haskell.LSP.Types.Message import Language.Haskell.LSP.Types.Location import Language.Haskell.LSP.Types.Symbol diff --git a/src/Language/Haskell/LSP/Types/MarkupContent.hs b/src/Language/Haskell/LSP/Types/MarkupContent.hs --- a/src/Language/Haskell/LSP/Types/MarkupContent.hs +++ b/src/Language/Haskell/LSP/Types/MarkupContent.hs @@ -156,3 +156,4 @@ MarkupContent _ s1 `mappend` MarkupContent MkMarkdown s2 = MarkupContent MkMarkdown (s1 `mappend` s2) -- --------------------------------------------------------------------- + diff --git a/src/Language/Haskell/LSP/Types/Message.hs b/src/Language/Haskell/LSP/Types/Message.hs --- a/src/Language/Haskell/LSP/Types/Message.hs +++ b/src/Language/Haskell/LSP/Types/Message.hs @@ -3,12 +3,10 @@ {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.LSP.Types.Message where -import Control.Monad import qualified Data.Aeson as A import Data.Aeson.TH import Data.Aeson.Types import Data.Hashable -import Data.Maybe -- For <= 8.2.2 import Data.Text (Text) import Language.Haskell.LSP.Types.Constants @@ -369,6 +367,28 @@ -- ------------------------------------- +{- + https://microsoft.github.io/language-server-protocol/specification#responseMessage + + interface ResponseError { + /** + * A number indicating the error type that occurred. + */ + code: number; + + /** + * A string providing a short description of the error. + */ + message: string; + + /** + * A primitive or structured value that contains additional + * information about the error. Can be omitted. + */ + data?: string | number | boolean | array | object | null; + } +-} + data ResponseError = ResponseError { _code :: ErrorCode @@ -380,30 +400,58 @@ -- --------------------------------------------------------------------- --- | Either result or error must be Just. +{- + https://microsoft.github.io/language-server-protocol/specification#responseMessage + + interface ResponseMessage extends Message { + /** + * The request id. + */ + id: number | string | null; + + /** + * The result of a request. This member is REQUIRED on success. + * This member MUST NOT exist if there was an error invoking the method. + */ + result?: string | number | boolean | object | null; + + /** + * The error object in case a request fails. + */ + error?: ResponseError; + } +-} + data ResponseMessage a = ResponseMessage { _jsonrpc :: Text , _id :: LspIdRsp - , _result :: Maybe a - , _error :: Maybe ResponseError + , _result :: Either ResponseError a } deriving (Read,Show,Eq) -deriveToJSON lspOptions ''ResponseMessage +instance ToJSON a => ToJSON (ResponseMessage a) where + toJSON (ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result }) + = object + [ "jsonrpc" .= jsonrpc + , "id" .= lspid + , case result of + Left err -> "error" .= err + Right a -> "result" .= a + ] instance FromJSON a => FromJSON (ResponseMessage a) where parseJSON = withObject "Response" $ \o -> do - rsp <- ResponseMessage - <$> o .: "jsonrpc" - <*> o .: "id" - -- It is important to use .:! so that result = null gets decoded as Just Nothing - <*> o .:! "result" - <*> o .:! "error" - -- We make sure that one of them is present. Without this check we can end up - -- parsing a Request as a ResponseMessage. - unless (isJust (_result rsp) || isJust (_error rsp)) $ - fail "ResponseMessage must either have a result or an error" - pure rsp + _jsonrpc <- o .: "jsonrpc" + _id <- o .: "id" + -- It is important to use .:! so that "result = null" (without error) gets decoded as Just Null + _result <- o .:! "result" + _error <- o .:? "error" + result <- case (_error, _result) of + ((Just err), Nothing ) -> pure $ Left err + (Nothing , (Just res)) -> pure $ Right res + ((Just _), (Just _)) -> fail $ "Both error and result cannot be present" + (Nothing, Nothing) -> fail "Both error and result cannot be Nothing" + return $ ResponseMessage _jsonrpc _id $ result type ErrorResponse = ResponseMessage ()