Add MarkupContent to HoverResponse

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for haskell-lsp
 
+## 0.8.3.0
+
+* Add `MarkupContent` to `HoverResponse`, and (some) json roundtrip tests.
+
 ## 0.8.2.0 -- 2019-04-11
 
 * Add `applyTextEdit` and `editTextEdit` helpers

example/Main.hs

@@ -238,7 +238,7 @@ reactor lf inp = do
 
         let
           ht = Just $ J.Hover ms (Just range)
-          ms = J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ]
+          ms = J.HoverContentsMS $ J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ]
           range = J.Range pos pos
         reactorSend $ RspHover $ Core.makeResponseMessage req ht
 

haskell-lsp-types/ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for haskell-lsp-types
 
+## 0.8.3.0
+
+* Add `MarkupContent` to `HoverResponse`, and (some) json roundtrip tests.
+
 ## 0.8.2.0 -- 2019-04-11
 
 * Add `applyTextEdit` and `editTextEdit` helpers

haskell-lsp-types/haskell-lsp-types.cabal

@@ -1,5 +1,5 @@
 name:                haskell-lsp-types
-version:             0.8.2.0
+version:             0.8.3.0
 synopsis:            Haskell library for the Microsoft Language Server Protocol, data types
 
 description:         An implementation of the types to allow language implementors to

haskell-lsp-types/src/Language/Haskell/LSP/Types/DataTypesJSON.hs

@@ -18,14 +18,15 @@ import           Data.Aeson.TH
 import           Data.Aeson.Types
 import           Data.Text                                  (Text)
 import qualified Data.Text                                  as T
+import           Language.Haskell.LSP.Types.ClientCapabilities
 import           Language.Haskell.LSP.Types.Command
 import           Language.Haskell.LSP.Types.Constants
-import           Language.Haskell.LSP.Types.ClientCapabilities
 import           Language.Haskell.LSP.Types.Diagnostic
 import           Language.Haskell.LSP.Types.DocumentFilter
 import           Language.Haskell.LSP.Types.List
-import           Language.Haskell.LSP.Types.Message
 import           Language.Haskell.LSP.Types.Location
+import           Language.Haskell.LSP.Types.MarkupContent
+import           Language.Haskell.LSP.Types.Message
 import           Language.Haskell.LSP.Types.Symbol
 import           Language.Haskell.LSP.Types.TextDocument
 import           Language.Haskell.LSP.Types.Uri
@@ -499,7 +500,7 @@ interface ServerCapabilities {
          *
          * Since 3.10.0
          */
-        foldingRangeProvider?: boolean | FoldingRangeProviderOptions | (FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions);     
+        foldingRangeProvider?: boolean | FoldingRangeProviderOptions | (FoldingRangeProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions);
         /**
          * The server provides execute command support.
          */
@@ -544,7 +545,7 @@ data TDS = TDSOptions TextDocumentSyncOptions
 
 instance FromJSON TDS where
     parseJSON x = TDSOptions <$> parseJSON x <|> TDSKind <$> parseJSON x
-    
+
 instance ToJSON TDS where
     toJSON (TDSOptions x) = toJSON x
     toJSON (TDSKind x) = toJSON x
@@ -553,7 +554,7 @@ data GotoOptions = GotoOptionsStatic Bool
                  | GotoOptionsDynamic
                     { -- | A document selector to identify the scope of the registration. If set to null
                       -- the document selector provided on the client side will be used.
-                      _documentSelector :: Maybe DocumentSelector 
+                      _documentSelector :: Maybe DocumentSelector
                       -- | The id used to register the request. The id can be used to deregister
                       -- the request again. See also Registration#id.
                     , _id :: Maybe Text
@@ -624,7 +625,7 @@ data WorkspaceOptions =
   deriving (Show, Read, Eq)
 
 deriveJSON lspOptions ''WorkspaceOptions
-      
+
 data InitializeResponseCapabilitiesInner =
   InitializeResponseCapabilitiesInner
     { -- | Defines how text documents are synced. Is either a detailed structure
@@ -1232,19 +1233,19 @@ Request:
 method: ‘workspace/configuration’
 params: ConfigurationParams defined as follows
 export interface ConfigurationParams {
-	items: ConfigurationItem[];
+        items: ConfigurationItem[];
 }
 
 export interface ConfigurationItem {
-	/**
-	 * The scope to get the configuration section for.
-	 */
-	scopeUri?: string;
-
-	/**
-	 * The configuration section asked for.
-	 */
-	section?: string;
+        /**
+         * The scope to get the configuration section for.
+         */
+        scopeUri?: string;
+
+        /**
+         * The configuration section asked for.
+         */
+        section?: string;
 }
 Response:
 
@@ -1731,26 +1732,28 @@ Response
 
     result: Hover | null defined as follows:
 
+
 /**
- * The result of a hove request.
+ * The result of a hover request.
  */
 interface Hover {
-    /**
-     * The hover's content
-     */
-    contents: MarkedString | MarkedString[];
+        /**
+         * The hover's content
+         */
+        contents: MarkedString | MarkedString[] | MarkupContent;
 
-    /**
-     * An optional range
-     */
-    range?: Range;
+        /**
+         * 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;
 }
 
-Where MarkedString is defined as follows:
+
 /**
  * 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 sematically equal to the optional language identifier in fenced code blocks in GitHub
+ * 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:
@@ -1759,7 +1762,8 @@ Where MarkedString is defined as follows:
  * ```
  *
  * 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
@@ -1777,6 +1781,7 @@ data LanguageString =
 
 deriveJSON lspOptions ''LanguageString
 
+{-# DEPRECATED MarkedString, PlainString, CodeString "Use MarkupContent instead, since 3.3.0 (11/24/2017)" #-}
 data MarkedString =
     PlainString T.Text
   | CodeString LanguageString
@@ -1789,9 +1794,32 @@ 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.Null)     = HoverContentsMS <$> parseJSON v
+  parseJSON v@(A.Array _)  = HoverContentsMS <$> parseJSON v
+  parseJSON v@(A.Object o) = do
+    mk <- o .:? "kind" :: Parser (Maybe MarkupKind)
+    case mk of
+      Nothing -> HoverContentsMS <$> parseJSON v
+      _       -> HoverContents   <$> parseJSON v
+  parseJSON _ = fail "HoverContents"
+
+-- -------------------------------------
+
 data Hover =
   Hover
-    { _contents :: List MarkedString
+    { _contents :: HoverContents
     , _range    :: Maybe Range
     } deriving (Read,Show,Eq)
 
@@ -2852,4 +2880,3 @@ data TraceNotification =
   } deriving (Show, Read, Eq)
 
 deriveJSON lspOptions ''TraceNotification
-

haskell-lsp-types/src/Language/Haskell/LSP/Types/MarkupContent.hs

@@ -23,15 +23,15 @@ import           Language.Haskell.LSP.Types.Constants
  * are reserved for internal usage.
  */
 export namespace MarkupKind {
-	/**
-	 * Plain text is supported as a content format
-	 */
-	export const PlainText: 'plaintext' = 'plaintext';
+        /**
+         * Plain text is supported as a content format
+         */
+        export const PlainText: 'plaintext' = 'plaintext';
 
-	/**
-	 * Markdown is supported as a content format
-	 */
-	export const Markdown: 'markdown' = 'markdown';
+        /**
+         * Markdown is supported as a content format
+         */
+        export const Markdown: 'markdown' = 'markdown';
 }
 export type MarkupKind = 'plaintext' | 'markdown';
 -}
@@ -78,15 +78,15 @@ instance FromJSON MarkupKind where
  * remove HTML from the markdown to avoid script execution.
  */
 export interface MarkupContent {
-	/**
-	 * The type of the Markup
-	 */
-	kind: MarkupKind;
+        /**
+         * The type of the Markup
+         */
+        kind: MarkupKind;
 
-	/**
-	 * The content itself
-	 */
-	value: string;
+        /**
+         * The content itself
+         */
+        value: string;
 }
 -}
 

haskell-lsp.cabal

@@ -1,5 +1,5 @@
 name:                haskell-lsp
-version:             0.8.2.0
+version:             0.8.3.0
 synopsis:            Haskell library for the Microsoft Language Server Protocol
 
 description:         An implementation of the types, and basic message server to
@@ -44,7 +44,7 @@ library
                      , filepath
                      , hslogger
                      , hashable
-                     , haskell-lsp-types >= 0.8
+                     , haskell-lsp-types >= 0.8.3
                      , lens >= 4.15.2
                      , mtl
                      , network-uri
@@ -94,6 +94,7 @@ test-suite haskell-lsp-test
   main-is:             Main.hs
   other-modules:       Spec
                        CapabilitiesSpec
+                       JsonSpec
                        DiagnosticsSpec
                        MethodSpec
                        ServerCapabilitiesSpec
@@ -102,22 +103,24 @@ test-suite haskell-lsp-test
                        WorkspaceEditSpec
                        WorkspaceFoldersSpec
   build-depends:       base
+                     , QuickCheck
                      , aeson
                      , bytestring
                      , containers
                      , data-default
                      , directory
                      , filepath
-                     , hspec
                      , hashable
+                     , haskell-lsp
+                     , hspec
                      -- , hspec-jenkins
                      , lens >= 4.15.2
                      , network-uri
+                     , quickcheck-instances
                      , sorted-list == 0.2.1.*
-                     , yi-rope
-                     , haskell-lsp
-                     , text
                      , stm
+                     , text
+                     , yi-rope
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   default-language:    Haskell2010
 

test/JsonSpec.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | Test for JSON serialization
+module JsonSpec where
+
+import           Language.Haskell.LSP.Types
+
+import           Data.Aeson
+import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import           Test.QuickCheck               hiding (Success)
+import           Test.QuickCheck.Instances     ()
+
+-- import Debug.Trace
+-- ---------------------------------------------------------------------
+
+{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = describe "dispatcher" jsonSpec
+
+-- ---------------------------------------------------------------------
+
+jsonSpec :: Spec
+jsonSpec = do
+  describe "General JSON instances round trip" $ do
+  -- DataTypesJSON
+    prop "LanguageString"    (propertyJsonRoundtrip :: LanguageString -> Bool)
+    prop "MarkedString"      (propertyJsonRoundtrip :: MarkedString -> Bool)
+    prop "MarkupContent"     (propertyJsonRoundtrip :: MarkupContent -> Bool)
+    prop "HoverContents"     (propertyJsonRoundtrip :: HoverContents -> Bool)
+
+
+-- ---------------------------------------------------------------------
+
+propertyJsonRoundtrip :: (Eq a, ToJSON a, FromJSON a) => a -> Bool
+propertyJsonRoundtrip a = Success a == fromJSON (toJSON a)
+
+-- ---------------------------------------------------------------------
+
+instance Arbitrary LanguageString where
+  arbitrary = LanguageString <$> arbitrary <*> arbitrary
+
+instance Arbitrary MarkedString where
+  arbitrary = oneof [PlainString <$> arbitrary, CodeString <$> arbitrary]
+
+instance Arbitrary MarkupContent where
+  arbitrary = MarkupContent <$> arbitrary <*> arbitrary
+
+instance Arbitrary MarkupKind where
+  arbitrary = oneof [pure MkPlainText,pure MkMarkdown]
+
+instance Arbitrary HoverContents where
+  arbitrary = oneof [HoverContentsMS <$> arbitrary, HoverContents <$> arbitrary]
+
+-- | make lists of maximum length 3 for test performance
+smallList :: Gen a -> Gen [a]
+smallList = resize 3 . listOf
+
+instance (Arbitrary a) => Arbitrary (List a) where
+  arbitrary = List <$> arbitrary
+
+-- ---------------------------------------------------------------------

test/ServerCapabilitiesSpec.hs

@@ -24,7 +24,7 @@ spec = describe "server capabilities" $ do
     describe "encodes" $
       it "just id" $
         encode (FoldingRangeOptionsDynamicDocument Nothing (Just "foo")) `shouldBe` "{\"id\":\"foo\"}"
-  it "decodes" $ 
+  it "decodes" $
     let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}"
         Just caps = decode input :: Maybe InitializeResponseCapabilitiesInner
       in caps ^. colorProvider `shouldBe` Just (ColorOptionsDynamicDocument (Just documentFilters) (Just "abc123"))