diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.14.0.2 + +* Compatibility with new lsp-types major version. + ## 0.14.0.1 -- 2021-07-30 * Catch IO exception when sending messages to server (#317) (@berberman) diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.14.0.1 +version: 0.14.0.2 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -36,7 +36,7 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , lsp-types == 1.3.* + , lsp-types == 1.4.* , aeson , time , aeson-pretty @@ -81,7 +81,7 @@ build-depends: base >= 4.10 && < 5 , hspec , lens - , lsp == 1.2.* + , lsp == 1.4.* , lsp-test , data-default , aeson @@ -99,15 +99,13 @@ main-is: FuncTest.hs hs-source-dirs: func-test type: exitcode-stdio-1.0 - build-depends: base <4.16 + build-depends: base , lsp-test , lsp - , data-default , process , lens , unliftio , hspec - , async default-language: Haskell2010 test-suite example @@ -124,7 +122,7 @@ main-is: SimpleBench.hs hs-source-dirs: bench type: exitcode-stdio-1.0 - build-depends: base <4.16 + build-depends: base , lsp-test , lsp , process diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -198,7 +198,9 @@ config <- envOverrideConfig config' let initializeParams = InitializeParams Nothing - (Just pid) + -- Narowing to Int32 here, but it's unlikely that a pid will + -- be outside the range + (Just $ fromIntegral pid) (Just lspTestClientInfo) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) diff --git a/src/Language/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs --- a/src/Language/LSP/Test/Decoding.hs +++ b/src/Language/LSP/Test/Decoding.hs @@ -82,7 +82,7 @@ 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" diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -198,6 +198,7 @@ shouldSkip (FromServerMess SWindowLogMessage _) = True shouldSkip (FromServerMess SWindowShowMessage _) = True shouldSkip (FromServerMess SWindowShowMessageRequest _) = True + shouldSkip (FromServerMess SWindowShowDocument _) = True shouldSkip _ = False -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -169,7 +169,7 @@ data SessionState = SessionState { - curReqId :: !Int + curReqId :: !Int32 , vfs :: !VFS , curDiagnostics :: !(Map.Map NormalizedUri [Diagnostic]) , overridingTimeout :: !Bool @@ -231,6 +231,7 @@ isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowShowDocument _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -307,7 +308,7 @@ respond (FromServerMess SWindowWorkDoneProgressCreate req) = sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right Empty) respond (FromServerMess SWorkspaceApplyEdit r) = do - sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing) + sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing Nothing) respond _ = pure () @@ -353,7 +354,10 @@ 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 @@ -375,12 +379,11 @@ -- 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 } @@ -400,7 +403,7 @@ 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 @@ -411,6 +414,8 @@ 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 @@ -424,7 +429,7 @@ 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/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -139,15 +139,36 @@ do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token + + -- 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 - 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/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} @@ -132,7 +133,37 @@ 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"