diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for lsp-test +## 0.5.3.0 -- 2019-06-13 + +* Update to haskell-lsp-0.14.0.0 (@cocreature) +* Support `TextDocumentDidChange` (@cocreature) +* Add non-file based `openDoc` (@cocreature) +* Fix `getDefinitions` for `SingleLoc` (@cocreature) +* Add `getCodeLenses` (@cocreature) + ## 0.5.2.0 -- 2019-04-28 * Add `satisfy` parser combinator diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.5.2.3 +version: 0.5.3.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -36,10 +36,11 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.13.0 && < 0.14 + , haskell-lsp == 0.14.* , aeson , aeson-pretty , ansi-terminal + , async , bytestring , conduit , conduit-parse @@ -78,7 +79,7 @@ build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp >= 0.13.0 && < 0.14 + , haskell-lsp == 0.14.* , lsp-test , data-default , aeson diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -41,7 +41,9 @@ , initializeResponse -- ** Documents , openDoc + , openDoc' , closeDoc + , changeDoc , documentContents , getDocumentEdit , getDocUri @@ -90,6 +92,7 @@ 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 +136,8 @@ -> 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 +149,7 @@ (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 +168,22 @@ -- 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 +298,15 @@ 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 +322,20 @@ -- | Opens a text document and sends a notification to the client. openDoc :: FilePath -> String -> Session TextDocumentIdentifier openDoc file languageId = do - item <- getDocItem file languageId + context <- ask + let fp = rootDir context file + contents <- liftIO $ T.readFile fp + 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) - 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 + pure $ TextDocumentIdentifier uri -- | Closes a text document and sends a notification to the client. closeDoc :: TextDocumentIdentifier -> Session () @@ -318,10 +343,12 @@ 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 diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -123,7 +123,7 @@ decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage decodeFromServerMsg reqMap bytes = - case HM.lookup "method" (fromJust $ decode bytes :: Object) of + case HM.lookup "method" obj of Just methodStr -> case fromJSON methodStr of Success method -> case method of -- We can work out the type of the message @@ -141,6 +141,10 @@ WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" + CustomServerMethod _ + | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes + | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes + | otherwise -> NotCustomServer $ fromJust $ decode bytes Error e -> error e @@ -149,3 +153,4 @@ Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type Nothing -> error "Couldn't match up response with request" Nothing -> error "Couldn't decode message" + where obj = fromJust $ decode bytes :: Object diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs --- a/src/Language/Haskell/LSP/Test/Messages.hs +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -59,6 +59,7 @@ (ReqApplyWorkspaceEdit m) -> request m (ReqShowMessage m) -> request m (ReqUnregisterCapability m) -> request m + (ReqCustomServer m) -> request m (RspInitialize m) -> response m (RspShutdown m) -> response m (RspHover m) -> response m @@ -87,6 +88,7 @@ (RspDocumentColor m) -> response m (RspColorPresentation m) -> response m (RspFoldingRange m) -> response m + (RspCustomServer m) -> response m (NotPublishDiagnostics m) -> notification m (NotLogMessage m) -> notification m (NotShowMessage m) -> notification m @@ -95,6 +97,7 @@ (NotProgressDone m) -> notification m (NotTelemetry m) -> notification m (NotCancelRequestFromServer m) -> notification m + (NotCustomServer m) -> notification m handleClientMessage :: forall a. @@ -145,4 +148,5 @@ (NotDidChangeWatchedFiles m) -> notification m (NotDidChangeWorkspaceFolders m) -> notification m (NotProgressCancel m) -> notification m - (UnknownFromClientMessage m) -> error $ "Unknown message sent from client: " ++ show m + (ReqCustomClient m) -> request m + (NotCustomClient m) -> notification m diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -1,7 +1,6 @@ module Language.Haskell.LSP.Test.Server (withServer) where -import Control.Concurrent -import Control.Exception +import Control.Concurrent.Async import Control.Monad import Language.Haskell.LSP.Test.Compat import System.IO @@ -13,15 +12,12 @@ -- separate command and arguments let cmd:args = words serverExe createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } - (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc - - -- Need to continuously consume to stderr else it gets blocked - -- Can't pass NoStream either to std_err - hSetBuffering serverErr NoBuffering - errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn - - pid <- getProcessID serverProc - - finally (f serverIn serverOut pid) $ do - killThread errSinkThread - terminateProcess serverProc + withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering serverErr NoBuffering + hSetBinaryMode serverErr True + let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn + withAsync errSinkThread $ \_ -> do + pid <- getProcessID serverProc + f serverIn serverOut pid diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -197,6 +197,10 @@ hSetBuffering serverIn NoBuffering hSetBuffering serverOut NoBuffering + -- This is required to make sure that we don’t get any + -- newline conversion or weird encoding issues. + hSetBinaryMode serverIn True + hSetBinaryMode serverOut True reqMap <- newMVar newRequestMap messageChan <- newChan diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -62,8 +62,12 @@ it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" + -- warm up the cache + getDocumentSymbols doc + -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc - liftIO $ threadDelay 5000000 + -- longer than the original timeout + liftIO $ threadDelay (5 * 10^6) -- shouldn't throw an exception getDocumentSymbols doc return () @@ -259,12 +263,12 @@ defs <- getDefinitions doc pos liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] - -- describe "getTypeDefinitions" $ - -- it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" - -- let pos = Position 20 23 -- Quit value - -- defs <- getTypeDefinitions doc pos - -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 5 10 12)] -- Type definition + describe "getTypeDefinitions" $ + it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let pos = Position 20 23 -- Quit value + defs <- getTypeDefinitions doc pos + liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition describe "waitForDiagnosticsSource" $ it "works" $ runSession "hie" fullCaps "test/data" $ do