X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=1c425fb89cc49aa0af526b99ab7d5753d261a679;hb=b7ee75f11c842d84221eec57715d96429eb1b689;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..1c425fb 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 @@ -90,6 +94,7 @@ import qualified Data.Text.IO as T import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap +import Data.IORef import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Types @@ -133,6 +138,8 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> Session a -- ^ The session to run. -> IO a runSessionWithConfig config serverExe caps rootDir session = do + -- We use this IORef to make exception non-fatal when the server is supposed to shutdown. + exitOk <- newIORef False pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir @@ -144,7 +151,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 -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do -- Wrap the session around initialize and shutdown calls initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -163,12 +170,22 @@ runSessionWithConfig config serverExe caps rootDir session = do -- Run the actual test result <- session + liftIO $ atomicWriteIORef exitOk True sendNotification Exit ExitParams return result where + catchWhenTrue :: IORef Bool -> IO () -> IO () + catchWhenTrue exitOk a = + a `catch` (\e -> do + x <- readIORef exitOk + unless x $ throw (e :: SomeException)) + -- | 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 @@ -283,6 +300,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 +324,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 +345,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 @@ -436,7 +465,7 @@ getVersionedDoc (TextDocumentIdentifier uri) = do fs <- vfs <$> get let ver = case fs Map.!? uri of - Just (VirtualFile v _) -> Just v + Just (VirtualFile v _ _) -> Just v _ -> Nothing return (VersionedTextDocumentIdentifier uri ver) @@ -491,9 +520,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 +582,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