Add MarkupContent to HoverResponse

And deprecate the old MarkedString as per the LSP spec.

Closes #141

Addresses some of #134

Author: alanz

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
@@ -1749,11 +1750,10 @@ interface Hover {
 }
 
 
-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:
@@ -1762,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
@@ -1780,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
@@ -1792,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)
 

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"))

test/WorkspaceEditSpec.hs

@@ -20,6 +20,6 @@ spec = do
   describe "editTextEdit" $
     it "edits a multiline text edit" $
       let orig = TextEdit (Range (Position 1 1) (Position 2 2)) "hello\nworld"
-          inner = TextEdit (Range (Position 0 3) (Position 1 3)) "ios\ngo" 
+          inner = TextEdit (Range (Position 0 3) (Position 1 3)) "ios\ngo"
           expected = TextEdit (Range (Position 1 1) (Position 2 2)) "helios\ngold"
          in editTextEdit orig inner `shouldBe` expected

test/WorkspaceFoldersSpec.hs

@@ -32,7 +32,7 @@ spec = describe "workspace folders" $
             in handleMessage initCb tvarCtx clStr jsonStr
 
     let starterWorkspaces = List [wf0]
-        initParams = InitializeParams 
+        initParams = InitializeParams
           Nothing Nothing (Just (Uri "/foo")) Nothing fullCaps Nothing (Just starterWorkspaces)
         initMsg :: InitializeRequest
         initMsg = RequestMessage "2.0" (IdInt 0) Initialize initParams