lsp-test 0.5.2.3 → 0.5.3.0
raw patch · 8 files changed
+92/−43 lines, 8 filesdep +asyncdep ~haskell-lspPVP ok
version bump matches the API change (PVP)
Dependencies added: async
Dependency ranges changed: haskell-lsp
API changes (from Hackage documentation)
+ Language.Haskell.LSP.Test: changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
+ Language.Haskell.LSP.Test: openDoc' :: FilePath -> String -> Text -> Session TextDocumentIdentifier
Files
- ChangeLog.md +8/−0
- lsp-test.cabal +4/−3
- src/Language/Haskell/LSP/Test.hs +44/−17
- src/Language/Haskell/LSP/Test/Decoding.hs +6/−1
- src/Language/Haskell/LSP/Test/Messages.hs +5/−1
- src/Language/Haskell/LSP/Test/Server.hs +10/−14
- src/Language/Haskell/LSP/Test/Session.hs +4/−0
- test/Test.hs +11/−7
ChangeLog.md view
@@ -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
lsp-test.cabal view
@@ -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
src/Language/Haskell/LSP/Test.hs view
@@ -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
src/Language/Haskell/LSP/Test/Decoding.hs view
@@ -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
src/Language/Haskell/LSP/Test/Messages.hs view
@@ -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
src/Language/Haskell/LSP/Test/Server.hs view
@@ -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
src/Language/Haskell/LSP/Test/Session.hs view
@@ -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
test/Test.hs view
@@ -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