X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=1b2e7ba867a6ebc4356b008e29a7c4ce53eee962;hp=6156b003dd53876406a592e4278dbe88cfcd98f8;hb=f0a961503e19c2d281c3d6319df1096f5bf6cfcf;hpb=d54524be6dd2b0b2d20530afd7049f22b33129d5 diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 6156b00..1b2e7ba 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 @@ -143,9 +147,8 @@ runSessionWithConfig config serverExe caps rootDir session = do caps (Just TraceOff) Nothing - withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> - runSessionWithHandles serverIn serverOut listenServer 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 @@ -153,7 +156,6 @@ runSessionWithConfig config serverExe caps rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams case lspConfig config of @@ -162,13 +164,14 @@ 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 + -- | 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 @@ -178,13 +181,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.! (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 +288,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 +312,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 +333,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 +423,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,7 +452,7 @@ getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdenti getVersionedDoc (TextDocumentIdentifier uri) = do fs <- vfs <$> get let ver = - case fs Map.!? uri of + case fs Map.!? toNormalizedUri uri of Just (VirtualFile v _ _) -> Just v _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) @@ -491,9 +508,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 +570,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