diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for haskell-lsp +## 0.9.0.0 + +* Add `MarkupContent` to `HoverResponse`, and (some) json roundtrip tests. + ## 0.8.2.0 -- 2019-04-11 * Add `applyTextEdit` and `editTextEdit` helpers diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -238,7 +238,7 @@ 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 diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.8.2.0 +version: 0.9.0.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 @@ , filepath , hslogger , hashable - , haskell-lsp-types >= 0.8 + , haskell-lsp-types >= 0.8.3 , lens >= 4.15.2 , mtl , network-uri @@ -94,30 +94,34 @@ main-is: Main.hs other-modules: Spec CapabilitiesSpec + JsonSpec DiagnosticsSpec MethodSpec ServerCapabilitiesSpec + TypesSpec URIFilePathSpec VspSpec 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 diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/JsonSpec.hs @@ -0,0 +1,71 @@ +{-# 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 + , pure HoverContentsEmpty] + +-- | 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 + +-- --------------------------------------------------------------------- diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs --- a/test/ServerCapabilitiesSpec.hs +++ b/test/ServerCapabilitiesSpec.hs @@ -24,7 +24,7 @@ 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")) diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/TypesSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module TypesSpec where + +import Data.Monoid +import qualified Language.Haskell.LSP.Types as J +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = diagnosticsSpec + +-- --------------------------------------------------------------------- + +diagnosticsSpec :: Spec +diagnosticsSpec = do + describe "MarkupContent" $ do + it "appends two plainstrings" $ do + J.unmarkedUpContent "string1\n" <> J.unmarkedUpContent "string2\n" + `shouldBe` J.unmarkedUpContent "string1\nstring2\n" + it "appends a marked up and a plain string" $ do + J.markedUpContent "haskell" "foo :: Int" <> J.unmarkedUpContent "string2\n" + `shouldBe` J.MarkupContent J.MkMarkdown "```haskell\nfoo :: Int\n```\nstring2\n" + it "appends a plain string and a marked up string" $ do + J.unmarkedUpContent "string2\n" <> J.markedUpContent "haskell" "foo :: Int" + `shouldBe` J.MarkupContent J.MkMarkdown "string2\n```haskell\nfoo :: Int\n```\n" + +-- --------------------------------------------------------------------- diff --git a/test/WorkspaceEditSpec.hs b/test/WorkspaceEditSpec.hs --- a/test/WorkspaceEditSpec.hs +++ b/test/WorkspaceEditSpec.hs @@ -20,6 +20,6 @@ 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 diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs --- a/test/WorkspaceFoldersSpec.hs +++ b/test/WorkspaceFoldersSpec.hs @@ -32,7 +32,7 @@ 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