X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=c4b90fb944489828f718d173db11bb902bc1e822;hb=c92237720248d8ce94f84ac6aef6409ab116897f;hp=696f84aa4df05bae70d411feb75675de2f2a076e;hpb=59380ca81c003f777fdfd48b92fbe873474fb9a8;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 696f84a..c4b90fb 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -41,7 +41,9 @@ module Language.Haskell.LSP.Test , initializeResponse -- ** Documents , openDoc + , openDoc' , closeDoc + , changeDoc , documentContents , getDocumentEdit , getDocUri @@ -77,6 +79,8 @@ module Language.Haskell.LSP.Test , formatRange -- ** Edits , applyEdit + -- ** Code lenses + , getCodeLenses ) where import Control.Applicative.Combinators @@ -133,6 +137,7 @@ 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 @@ -144,8 +149,7 @@ runSessionWithConfig config serverExe caps rootDir session = do (Just TraceOff) Nothing withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> - runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do - + runSessionWithHandles serverIn serverOut (\h c -> listenServer h c) config caps rootDir $ do -- Wrap the session around initialize and shutdown calls initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -162,13 +166,13 @@ runSessionWithConfig config serverExe caps rootDir session = do -- Run the actual test result <- session - - sendNotification Exit ExitParams - return result 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. listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do msgBytes <- getNextMessage serverOut @@ -184,7 +188,7 @@ runSessionWithConfig config serverExe caps rootDir session = do documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get - let file = vfs Map.! (doc ^. uri) + let file = 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 @@ -283,6 +287,15 @@ sendNotification TextDocumentDidClose params = do modify (\s -> s { vfs = newVFS }) sendMessage n +sendNotification TextDocumentDidChange params = do + let params' = fromJust $ decode $ encode params + n :: DidChangeTextDocumentNotification + n = NotificationMessage "2.0" TextDocumentDidChange params' + oldVFS <- vfs <$> get + newVFS <- liftIO $ changeFromClientVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + sendNotification method params = sendMessage (NotificationMessage "2.0" method params) -- | Sends a response to the server. @@ -298,19 +311,20 @@ initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) -- | Opens a text document and sends a notification to the client. openDoc :: FilePath -> String -> Session TextDocumentIdentifier openDoc file languageId = do - item <- getDocItem file languageId - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) - TextDocumentIdentifier <$> getDocUri file - where - -- | Reads in a text document as the first version. - getDocItem :: FilePath -- ^ The path to the text document to read in. - -> String -- ^ The language ID, e.g "haskell" for .hs files. - -> Session TextDocumentItem - getDocItem file languageId = do context <- ask let fp = rootDir context file contents <- liftIO $ T.readFile fp - return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents + openDoc' file languageId contents + +-- | This is a variant of `openDoc` that takes the file content as an argument. +openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier +openDoc' file languageId contents = do + context <- ask + let fp = rootDir context file + uri = filePathToUri fp + item = TextDocumentItem uri (T.pack languageId) 0 contents + sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) + pure $ TextDocumentIdentifier uri -- | Closes a text document and sends a notification to the client. closeDoc :: TextDocumentIdentifier -> Session () @@ -318,10 +332,12 @@ closeDoc docId = do let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) sendNotification TextDocumentDidClose params - oldVfs <- vfs <$> get - let notif = NotificationMessage "" TextDocumentDidClose params - newVfs <- liftIO $ closeVFS oldVfs notif - modify $ \s -> s { vfs = newVfs } +-- | Changes a text document and sends a notification to the client +changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () +changeDoc docId changes = do + verDoc <- getVersionedDoc docId + let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) + sendNotification TextDocumentDidChange params -- | Gets the Uri for the file corrected to the session directory. getDocUri :: FilePath -> Session Uri @@ -406,7 +422,7 @@ getCodeActionContext doc = do -- | Returns the current diagnostics that have been sent to the client. -- Note that this does not wait for more to come in. getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic] -getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get +getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get -- | Executes a command. executeCommand :: Command -> Session () @@ -435,8 +451,8 @@ getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdenti getVersionedDoc (TextDocumentIdentifier uri) = do fs <- vfs <$> get let ver = - case fs Map.!? uri of - Just (VirtualFile v _) -> Just v + case fs Map.!? toNormalizedUri uri of + Just (VirtualFile v _ _) -> Just v _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) @@ -491,9 +507,12 @@ getReferences doc pos inclDecl = 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 = +getDefinitions doc pos = do let params = TextDocumentPositionParams doc pos - in getResponseResult <$> request TextDocumentDefinition params + rsp <- request TextDocumentDefinition params :: Session DefinitionResponse + case getResponseResult rsp of + 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. @@ -550,3 +569,10 @@ applyTextEdits doc edits = let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) in updateState (ReqApplyWorkspaceEdit req) + +-- | Returns the code lenses for the specified document. +getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getCodeLenses tId = do + rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse + case getResponseResult rsp of + List res -> pure res