From c51be74dc2e9ef3d0f7c6052b41e9d4218ecf651 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 15 Dec 2021 08:51:57 +0000 Subject: [PATCH 1/5] Improve error message --- lsp-test/src/Language/LSP/Test/Decoding.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lsp-test/src/Language/LSP/Test/Decoding.hs b/lsp-test/src/Language/LSP/Test/Decoding.hs index ea0b14340..c5cefd632 100644 --- a/lsp-test/src/Language/LSP/Test/Decoding.hs +++ b/lsp-test/src/Language/LSP/Test/Decoding.hs @@ -82,7 +82,7 @@ decodeFromServerMsg reqMap bytes = unP $ parse p obj Just m -> Just $ (m, Pair m (Const newMap)) unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg) unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg) - unP (Error e) = error e + unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e {- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" From a851ed7939528a30660af4d1070423627b3cd4f7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 15 Dec 2021 00:23:37 +0000 Subject: [PATCH 2/5] Add test for #374 --- lsp-test/src/Language/LSP/Test/Session.hs | 2 +- lsp-test/test/DummyServer.hs | 24 ++++++++++++++--- lsp-test/test/Test.hs | 33 ++++++++++++++++++++++- 3 files changed, 54 insertions(+), 5 deletions(-) diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index 616278490..d3361f7ab 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -425,7 +425,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do vers <- textDocumentVersions uri pure $ map (\(v, e) -> TextDocumentEdit v (List [InL e])) $ zip vers edits - getChangeParams uri (List edits) = do + getChangeParams uri (List edits) = do map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits) mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index 286101e78..d1763b702 100644 --- a/lsp-test/test/DummyServer.hs +++ b/lsp-test/test/DummyServer.hs @@ -139,15 +139,33 @@ handlers = do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token + , notificationHandler STextDocumentDidChange $ \noti -> do + let NotificationMessage _ _ params = noti + void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params) + , requestHandler SWorkspaceExecuteCommand $ \req resp -> do - let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req + case req of + RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) -> do + let Success docUri = fromJSON val edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] params = ApplyWorkspaceEditParams (Just "Howdy edit") $ WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing Nothing - resp $ Right Null - void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) + resp $ Right Null + void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) + RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [val]))) -> do + let + Success versionedDocUri = fromJSON val + edit = List [InL (TextEdit (mkRange 0 0 0 5) "howdy")] + documentEdit = TextDocumentEdit versionedDocUri edit + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit Nothing (Just (List [InL documentEdit])) Nothing + resp $ Right Null + void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) + RequestMessage _ _ _ (ExecuteCommandParams _ name _) -> + error $ "unsupported command: " <> show name , requestHandler STextDocumentCodeAction $ \req resp -> do let RequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params diff --git a/lsp-test/test/Test.hs b/lsp-test/test/Test.hs index 9088d21c9..cbea65b2c 100644 --- a/lsp-test/test/Test.hs +++ b/lsp-test/test/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} @@ -132,7 +133,37 @@ main = hspec $ around withDummyServer $ do in runSessionWithHandles hin hout def fullCaps "." sesh `shouldThrow` selector - describe "text document VFS" $ + describe "text document VFS" $ do + it "sends back didChange notifications (documentChanges)" $ \(hin, hout) -> + runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/refactor/Main.hs" "haskell" + VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc + + let args = toJSON (VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion) + reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [args])) + + request_ SWorkspaceExecuteCommand reqParams + + editReq <- message SWorkspaceApplyEdit + liftIO $ do + let Just (List [InL(TextDocumentEdit vdoc (List [InL edit_]))]) = + editReq ^. params . edit . documentChanges + vdoc `shouldBe` VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion + edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" + + change <- customNotification "custom/textDocument/didChange" + let NotMess (NotificationMessage _ _ (c::Value)) = change + Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c + VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc + + contents <- documentContents doc + + liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" + VersionedTextDocumentIdentifier _ afterVersion <- getVersionedDoc doc + liftIO $ afterVersion `shouldNotBe` beforeVersion + + liftIO $ reportedVersion `shouldNotBe` beforeVersion + it "sends back didChange notifications" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" From b58cf8bed63110d0a7c819509ec615edcd25018e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 15 Dec 2021 21:27:49 +0000 Subject: [PATCH 3/5] Add fix --- lsp-test/src/Language/LSP/Test/Session.hs | 9 +++++++-- lsp-types/src/Language/LSP/Types/Lens.hs | 5 +++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index d3361f7ab..e539ab8da 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -354,7 +354,10 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do allChangeParams <- case r ^. params . edit . documentChanges of Just (List cs) -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs - return $ mapMaybe getParamsFromDocumentChange cs + -- replace the user provided version numbers with the VFS ones + 1 + -- (technically we should check that the user versions match the VFS ones) + cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs + return $ mapMaybe getParamsFromDocumentChange cs' -- Then fall back to the changes field Nothing -> case r ^. params . edit . changes of Just cs -> do @@ -401,7 +404,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do return $ s { vfs = newVFS } getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams - getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = + getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do DidChangeTextDocumentParams docId (List $ map editToChangeEvent edits) editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent @@ -412,6 +415,8 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing + bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = + head <$> textDocumentVersions uri -- For a uri returns an infinite list of versions [n,n+1,n+2,...] -- where n is the current version diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 32e6c08d3..1e8c25f0b 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE ExplicitNamespaces #-} module Language.LSP.Types.Lens where @@ -19,6 +20,7 @@ import Language.LSP.Types.CodeAction import Language.LSP.Types.CodeLens import Language.LSP.Types.DocumentColor import Language.LSP.Types.Command +import Language.LSP.Types.Common (type (|?)) import Language.LSP.Types.Completion import Language.LSP.Types.Configuration import Language.LSP.Types.Declaration @@ -391,3 +393,6 @@ makeFieldsNoPrefix ''SemanticTokensEdit makeFieldsNoPrefix ''SemanticTokensDelta makeFieldsNoPrefix ''SemanticTokensDeltaPartialResult makeFieldsNoPrefix ''SemanticTokensWorkspaceClientCapabilities + +-- Unions +makePrisms ''(|?) \ No newline at end of file From 32593ee3cbb6e29d9edb85d2813a952c841b9e60 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 16 Dec 2021 19:42:58 +0000 Subject: [PATCH 4/5] avoid double version bump --- lsp-test/src/Language/LSP/Test/Session.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index e539ab8da..81c828ef8 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -379,12 +379,11 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do -- Update VFS to new document versions let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams latestVersions = map ((^. textDocument) . last) sortedVersions - bumpedVersions = map (version . _Just +~ 1) latestVersions - forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s - update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t + update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS in s { vfs = newVFS } From 4e93686f462eb2a46b434e31905645a8acc6b76d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 16 Dec 2021 22:35:58 +0000 Subject: [PATCH 5/5] add a comment --- lsp-test/test/DummyServer.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index d1763b702..0085d0832 100644 --- a/lsp-test/test/DummyServer.hs +++ b/lsp-test/test/DummyServer.hs @@ -139,9 +139,12 @@ handlers = do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token - , notificationHandler STextDocumentDidChange $ \noti -> do - let NotificationMessage _ _ params = noti - void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params) + + -- this handler is used by the + -- "text document VFS / sends back didChange notifications (documentChanges)" test + , notificationHandler STextDocumentDidChange $ \noti -> do + let NotificationMessage _ _ params = noti + void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params) , requestHandler SWorkspaceExecuteCommand $ \req resp -> do case req of