X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=151eef7f1687fa0a357058f00f92d425a962d437;hp=c4b90fb944489828f718d173db11bb902bc1e822;hb=20750dca8684bcb05a7c91e8654257ad36e57ebe;hpb=c92237720248d8ce94f84ac6aef6409ab116897f diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index c4b90fb..151eef7 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -8,7 +8,7 @@ Module : Language.Haskell.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com Stability : experimental -Portability : POSIX +Portability : non-portable Provides the framework to start functionally testing . @@ -137,7 +137,6 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> Session a -- ^ The session to run. -> IO a runSessionWithConfig config serverExe caps rootDir session = do - pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir @@ -148,8 +147,8 @@ runSessionWithConfig config serverExe caps rootDir session = do caps (Just TraceOff) Nothing - withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> - runSessionWithHandles serverIn serverOut (\h c -> listenServer h c) config caps rootDir $ do + withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> + runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -157,7 +156,6 @@ runSessionWithConfig config serverExe caps rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams case lspConfig config of @@ -165,14 +163,14 @@ runSessionWithConfig config serverExe caps rootDir session = do Nothing -> return () -- Run the actual test - result <- session - return result + session where - -- | Listens to the server output, makes sure it matches the record and - -- signals any semaphores - -- Note that on Windows, we cannot kill a thread stuck in getNextMessage. - -- So we have to wait for the exit notification to kill the process first - -- and then getNextMessage will fail. + -- | Asks the server to shutdown and exit politely + exitServer :: Session () + exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams + + -- | Listens to the server output until the shutdown ack, + -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do msgBytes <- getNextMessage serverOut @@ -182,13 +180,15 @@ runSessionWithConfig config serverExe caps rootDir session = do let msg = decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) - listenServer serverOut context + case msg of + (RspShutdown _) -> return () + _ -> listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get - let file = vfs Map.! toNormalizedUri (doc ^. uri) + let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri) return $ Rope.toText $ Language.Haskell.LSP.VFS._text file -- | Parses an ApplyEditRequest, checks that it is for the passed document @@ -273,7 +273,7 @@ sendNotification TextDocumentDidOpen params = do n :: DidOpenTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidOpen params' oldVFS <- vfs <$> get - newVFS <- liftIO $ openVFS oldVFS n + let (newVFS,_) = openVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -283,7 +283,7 @@ sendNotification TextDocumentDidClose params = do n :: DidCloseTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidClose params' oldVFS <- vfs <$> get - newVFS <- liftIO $ closeVFS oldVFS n + let (newVFS,_) = closeVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -292,7 +292,7 @@ sendNotification TextDocumentDidChange params = do n :: DidChangeTextDocumentNotification n = NotificationMessage "2.0" TextDocumentDidChange params' oldVFS <- vfs <$> get - newVFS <- liftIO $ changeFromClientVFS oldVFS n + let (newVFS,_) = changeFromClientVFS oldVFS n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -377,7 +377,7 @@ noDiagnostics = do -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) getDocumentSymbols doc = do - ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse + ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr case mRes of Just (DSDocumentSymbols (List xs)) -> return (Left xs) @@ -388,7 +388,7 @@ getDocumentSymbols doc = do getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult] getCodeActions doc range = do ctx <- getCodeActionContext doc - rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx) + rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing) case rsp ^. result of Just (List xs) -> return xs @@ -406,7 +406,7 @@ getAllCodeActions doc = do where go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] go ctx acc diag = do - ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx) + ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) case mErr of Just e -> throw (UnexpectedResponseError rspLid e) @@ -428,7 +428,7 @@ getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args + execParams = ExecuteCommandParams (cmd ^. command) args Nothing request_ WorkspaceExecuteCommand execParams -- | Executes a code action. @@ -449,10 +449,10 @@ executeCodeAction action = do -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do - fs <- vfs <$> get + fs <- vfsMap . vfs <$> get let ver = case fs Map.!? toNormalizedUri uri of - Just (VirtualFile v _ _) -> Just v + Just vf -> Just (virtualFileVersion vf) _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) @@ -487,7 +487,7 @@ applyEdit doc edit = do -- | Returns the completions for the position in the document. getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getCompletions doc pos = do - rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos) + rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing) case getResponseResult rsp of Completions (List items) -> return items @@ -500,7 +500,7 @@ getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. -> Session [Location] -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl - params = ReferenceParams doc pos ctx + params = ReferenceParams doc pos ctx Nothing in getResponseResult <$> request TextDocumentReferences params -- | Returns the definition(s) for the term at the specified position. @@ -508,7 +508,7 @@ getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. -> Session [Location] -- ^ The location(s) of the definitions getDefinitions doc pos = do - let params = TextDocumentPositionParams doc pos + let params = TextDocumentPositionParams doc pos Nothing rsp <- request TextDocumentDefinition params :: Session DefinitionResponse case getResponseResult rsp of SingleLoc loc -> pure [loc] @@ -519,13 +519,13 @@ 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 = - let params = TextDocumentPositionParams doc pos + let params = TextDocumentPositionParams doc pos Nothing in getResponseResult <$> request TextDocumentTypeDefinition params -- | Renames the term at the specified position. rename :: TextDocumentIdentifier -> Position -> String -> Session () rename doc pos newName = do - let params = RenameParams doc pos (T.pack newName) + let params = RenameParams doc pos (T.pack newName) Nothing rsp <- request TextDocumentRename params :: Session RenameResponse let wEdit = getResponseResult rsp req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) @@ -534,13 +534,13 @@ rename doc pos newName = do -- | Returns the hover information at the specified position. getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = - let params = TextDocumentPositionParams doc pos + let params = TextDocumentPositionParams doc pos Nothing in getResponseResult <$> request TextDocumentHover params -- | Returns the highlighted occurences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos = - let params = TextDocumentPositionParams doc pos + let params = TextDocumentPositionParams doc pos Nothing in getResponseResult <$> request TextDocumentDocumentHighlight params -- | Checks the response for errors and throws an exception if needed. @@ -553,14 +553,14 @@ getResponseResult rsp = fromMaybe exc (rsp ^. result) -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () formatDoc doc opts = do - let params = DocumentFormattingParams doc opts + let params = DocumentFormattingParams doc opts Nothing edits <- getResponseResult <$> request TextDocumentFormatting params applyTextEdits doc edits -- | Applies formatting to the specified range in a document. formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () formatRange doc opts range = do - let params = DocumentRangeFormattingParams doc range opts + let params = DocumentRangeFormattingParams doc range opts Nothing edits <- getResponseResult <$> request TextDocumentRangeFormatting params applyTextEdits doc edits @@ -573,6 +573,6 @@ applyTextEdits doc edits = -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do - rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse + rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res