Fix getTypeDefinitions

Author: lukel97

lsp-test/src/Language/Haskell/LSP/Test.hs

@@ -604,16 +604,19 @@ getDefinitions doc pos = do
   let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
   case getResponseResult rsp of
-      SingleLoc loc -> pure [loc]
-      MultiLoc locs -> pure locs
+    SingleLoc loc -> pure [loc]
+    MultiLoc locs -> pure locs
 
 -- | Returns the type definition(s) for the term at the specified position.
 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
-               -> Position -- ^ The position the term is at.
-               -> Session [Location] -- ^ The location(s) of the definitions
-getTypeDefinitions doc pos =
+                   -> Position -- ^ The position the term is at.
+                   -> Session [Location] -- ^ The location(s) of the definitions
+getTypeDefinitions doc pos = do
   let params = TextDocumentPositionParams doc pos Nothing
-  in getResponseResult <$> request TextDocumentTypeDefinition params
+  rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse
+  case getResponseResult rsp of
+    SingleLoc loc -> pure [loc]
+    MultiLoc locs -> pure locs
 
 -- | Renames the term at the specified position.
 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
@@ -676,4 +679,4 @@ getCodeLenses tId = do
 --
 -- @since 0.11.0.0
 getRegisteredCapabilities :: Session [Registration]
-getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
+getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get

lsp-test/test/Test.hs

@@ -221,21 +221,13 @@ main = findServer >>= \serverExe -> hspec $ do
       contents <- documentContents doc
       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 
-  -- describe "getCompletions" $
-  --   it "works" $ runSession serverExe def "test/data/renamePass" $ do
-  --     doc <- openDoc "Desktop/simple.hs" "haskell"
-
-  --     -- wait for module to be loaded
-  --     skipMany loggingNotification
-  --     noDiagnostics
-  --     noDiagnostics
+  describe "getCompletions" $
+    it "works" $ runSession serverExe def "test/data/renamePass" $ do
+      doc <- openDoc "Desktop/simple.hs" "haskell"
 
-  --     comps <- getCompletions doc (Position 5 5)
-  --     let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
-  --     liftIO $ do
-  --       item ^. label `shouldBe` "interactWithUser"
-  --       item ^. kind `shouldBe` Just CiFunction
-  --       item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
+      comps <- getCompletions doc (Position 5 5)
+      let item = head comps
+      liftIO $ item ^. label `shouldBe` "foo"
 
   -- describe "getReferences" $
   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
@@ -413,4 +405,4 @@ findServer = do
   let serverName = "dummy-server"
   e <- findExecutable serverName
   e' <- findExeRecursive serverName "dist-newstyle"
-  pure $ fromJust $ e <|> e'
+  pure $ fromJust $ e <|> e'

lsp-test/test/dummy-server/Main.hs

@@ -109,7 +109,14 @@ handlers lfvar = def
       send $ RspCodeAction $ makeResponseMessage req caresults
   , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
       send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
+  , completionHandler = pure $ \req -> do
+      let res = CompletionList (CompletionListType False (List [item]))
+          item =
+            CompletionItem "foo" (Just CiConstant) (List []) Nothing
+            Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+            Nothing Nothing Nothing Nothing Nothing
+      send $ RspCompletion $ makeResponseMessage req res
   }
   where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
 
-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
+mkRange sl sc el ec = Range (Position sl sc) (Position el ec)