add inlay hints lsp-test support

haskell · May 16, 2024 · 9800f9d · 9800f9d
1 parent c15fa82
commit 9800f9d
Show file tree

Hide file tree

Showing 3 changed files with 59 additions and 0 deletions.
diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs
@@ -124,6 +124,11 @@ module Language.LSP.Test (
   getAndResolveCodeLenses,
   resolveCodeLens,
 
+  -- ** Inlay Hints
+  getInlayHints,
+  getAndResolveInlayHints,
+  resolveInlayHint,
+
   -- ** Call hierarchy
   prepareCallHierarchy,
   incomingCalls,
@@ -981,6 +986,28 @@ resolveCodeLens cl = do
     Right cl -> return cl
     Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)
 
+-- | Returns the inlay hints in the specified range.
+getInlayHints :: TextDocumentIdentifier -> Range -> Session [InlayHint]
+getInlayHints tId range = do
+  rsp <- request SMethod_TextDocumentInlayHint (InlayHintParams Nothing tId range)
+  pure $ absorbNull $ getResponseResult rsp
+
+{- | Returns the inlay hints in the specified range, resolving any with
+ a non empty _data_ field.
+-}
+getAndResolveInlayHints :: TextDocumentIdentifier -> Range -> Session [InlayHint]
+getAndResolveInlayHints tId range = do
+  inlayHints <- getInlayHints tId range
+  for inlayHints $ \inlayHint -> if isJust (inlayHint ^. L.data_) then resolveInlayHint inlayHint else pure inlayHint
+
+-- | Resolves the provided inlay hint.
+resolveInlayHint :: InlayHint -> Session InlayHint
+resolveInlayHint ih = do
+  rsp <- request SMethod_InlayHintResolve ih
+  case rsp ^. L.result of
+    Right ih -> return ih
+    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)
+
 -- | Pass a param and return the response from `prepareCallHierarchy`
 prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem]
 prepareCallHierarchy = resolveRequestWithListResp SMethod_TextDocumentPrepareCallHierarchy

diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module DummyServer where
 
@@ -256,4 +257,25 @@ handlers =
         case tokens of
           Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing
           Right tokens -> resp $ Right $ InL tokens
+    , requestHandler SMethod_TextDocumentInlayHint $ \req resp -> do
+        let TRequestMessage _ _ _ params = req
+            InlayHintParams _ _ (Range start end) = params
+            ih =
+              InlayHint
+                end
+                (InL ":: Text")
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                Nothing
+                (Just $ toJSON start)
+        resp $ Right $ InL [ih]
+    , requestHandler SMethod_InlayHintResolve $ \req resp -> do
+        let TRequestMessage _ _ _ params = req
+            (InlayHint {_data_= Just data_, ..}) = params
+            start :: Position
+            Success start = fromJSON data_
+            ih = InlayHint {_data_ = Nothing, _tooltip = Just $ InL $ "start at " <> T.pack (show start),  ..}
+        resp $ Right ih
     ]
diff --git a/lsp-test/test/Test.hs b/lsp-test/test/Test.hs
@@ -454,3 +454,13 @@ main = hspec $ around withDummyServer $ do
       let doc = TextDocumentIdentifier (Uri "")
       InL toks <- getSemanticTokens doc
       liftIO $ toks ^. L.data_ `shouldBe` [0, 1, 2, 1, 0]
+
+  describe "inlay hints" $ do
+    it "get works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
+      inlayHints <- getInlayHints doc (Range (Position 1 2) (Position 3 4))
+      liftIO $ head inlayHints ^. L.label `shouldBe` InL ":: Text"
+    it "resolve tooltip works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
+      inlayHints <- getAndResolveInlayHints doc (Range (Position 1 2) (Position 3 4))
+      liftIO $ head inlayHints ^. L.tooltip `shouldBe` Just (InL $ "start at " <> T.pack (show (Position 1 2)))