From: Luke Lau Date: Fri, 23 Aug 2019 18:45:57 +0000 (+0100) Subject: Merge pull request #45 from cocreature/satisfy-maybe X-Git-Tag: 0.6.1.0~1 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=4ef4204dae8f187c280582f202e6c77f8e4f767a;hp=1294a1fbb1578d87cc1fb4c10bc5f91e54cf9904 Merge pull request #45 from cocreature/satisfy-maybe Add a more general satisfyMaybe helper --- diff --git a/.travis.yml b/.travis.yml index 494ec7d..cb44faf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,37 +1,110 @@ language: c - sudo: false +os: +- linux +- osx +- windows + +dist: xenial + +ghc: +- 8.6.5 +cabal: '2.4' + cache: directories: - - .stack-work - - $HOME/.stack - - $HOME/haskell-ide-engine/.stack-work - timeout: 1000 + - "$HOME/.cabal" + - "$HOME/.ghc" + - "$HOME/haskell-ide-engine/dist-newstyle" + - "dist-newstyle" addons: apt: + sources: + - sourceline: ppa:hvr/ghc + packages: + - npm + - ghc-8.6.5 + - cabal-install-2.4 + homebrew: packages: + - ghc + - cabal-install - npm + update: true before_install: - - mkdir -p ~/.local/bin - - export PATH=$HOME/.local/bin:$PATH - - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - - mkdir -p haskell-ide-engine - - cd $HOME/haskell-ide-engine +- | + if [[ "$TRAVIS_OS_NAME" == "windows" ]]; then + choco source add -n mistuke -s https://www.myget.org/F/mistuke/api/v2 + choco install cabal-head -pre + choco install ghc --ignore-dependencies + choco install nodejs.install + /C/ProgramData/chocolatey/bin/RefreshEnv.cmd + + # ghc/cabal paths + export PATH=/C/ProgramData/chocolatey/lib/ghc/tools/ghc-8.6.5/bin:${PATH} + export PATH=${APPDATA}/cabal/bin:${PATH} + # nodejs paths + export PATH=/C/Program\ Files/nodejs:${PATH} + export PATH=${APPDATA}/npm:${PATH} + fi +# these are taken from the haskell language setup +- export PATH=/opt/ghc/8.6.5/bin:${PATH} +- export PATH=/opt/cabal/2.4/bin:${PATH} +- export PATH=$HOME/.cabal/bin:${PATH} +- npm update +- npm i -g javascript-typescript-langserver +- mkdir -p $HOME/haskell-ide-engine +- pushd $HOME/haskell-ide-engine - git init - git remote add origin https://github.com/haskell/haskell-ide-engine.git - git pull origin master - - git checkout 4c64789597cec9e73c9aeb901d9f6d0bb58251d9 - - git submodule init - - git submodule sync +- git checkout 0f697c8919747effca54be8a9b494896aea7d947 - git submodule update --init - - stack --no-terminal --skip-ghc-check -j2 install - - stack exec hoogle generate - - cd $TRAVIS_BUILD_DIR - - npm update - - npm i -g javascript-typescript-langserver +- cabal v2-update +- | + if [[ "$TRAVIS_OS_NAME" == "windows" ]]; then + cabal v2-install hie -j2 --overwrite-policy=always --install-method=copy + else + cabal v2-install hie -j2 --overwrite-policy=always + fi +- | + if [[ "$TRAVIS_OS_NAME" == "windows" ]]; then + cabal v2-install hoogle -j2 --overwrite-policy=always --install-method=copy + else + cabal v2-install hoogle -j2 --overwrite-policy=always + fi +- hoogle generate +- popd +# needs to be old-install for cabal-helper to find it +- cabal v1-install Cabal --constraint "Cabal == 2.4.1.0" +install: +- cabal v2-build script: - - stack test +# until cabal v2-test supports streaming results we use v2-run +# skipping for now testing the manual javascript session +- cabal v2-run lsp-test:test:tests -- --skip="manual javascript session passes a test" + +jobs: + include: + - stage: deploy + deploy: + - provider: hackage + username: bubba + password: + secure: M95r2TETDB9ndhqV0xCA9XSRw9k3tBj1xgTTAvB9b/aK3198XekZTak24a+etDNeq8cUke8wmWbN7UfBBlXiDmYYK+DfUFj5ilrkNRO+cAHQzx6TQ+yGr4GhTGhu76zA0g9PZLwMoaZdUELdOkNtRDh0EjC/PVMIp84ZKn2hBLJrptkeBbI5XDArd9I6gvu9mEuPjQ595GdHkKQdQJNEDyr1BQ9BwqUxCHj3HbUjkkfpdgujxE93wzj82/HMzGncYxeH5m5YWvK3ayX22cY3ZXK3D6jgZFB/wdp3uGwoUl1HGaVjAl6XbyV0ALMQkGTWOPrfI3HWqOtOcs349poMckDFseG1LmTXtWa3cG+8bcdzZtCbbo4pLu57e6DULivmvOw64R/tPPUx/evBRhstYVevYLrN0hJLwP3jWYl4BheHSCoDsv8cTFPaNYI/f0LgHF2NaUNBK89pOiR8kmue7oGoCUF/gBRKgqswG0xEji0YvkSIfPV/7qmfL2uoLFCZ/YpMQ8F80KjxsaA5qA3ktt0fVj14QNtsHl4+Qkwj5dtalre2zw5eHyZTe8svlD9Fp4pBaHMuazLDDyv/Aor4JYfInlfIR6oTtn6ty09eX0KjA2OhFi4hE4/jClt6ASDm3Dfv7bnFJJEBQLxfwFcQCFmAsI0EyUrAFmLON07hsm4= + on: + tags: true + branch: master + repo: bubba/lsp-test + - provider: github + api_key: + secure: JKjHWJ/ikW15Y/ZfnlREUeTj2Nw+QHzuc7yC3Bw+AOYQo8gKLCpZiN2iqPaw9xJifGoadutLaKKl2SSup7sZ8CGNW5brttqtGEgxJZci+rjR/b/5RHlyOM10RUg4rwKE0oRo8qXpbRuw6x8cWsREjworMBewZCyF6ToUuTzzMaHqvE/mxwIxoW3b30Xt+TytD6rRlbk/MNiRSZpJeA1TyNiPmpGTqSBc8LBhh8H3IOaZDL3bxlENTEuTJFW67vCQSsoH4/9JKeJ/M3WiwBVza4CTTMfQAxijYOqVGqYcoFtqMXDv4q+IhnBVSYpVo24Ii7zS2I4uQsWDNf5mdtUmfF5MJh9kKRnlp8464VWcLeRWJNsJMz09+rFiUQnl8ovPiu6bwv6GCwsBLzrYdrMx4w/F8FMuB05DsORPWqAcGjSw94seIJcTRTEZg8MbFswNSNptMIf0/PPYDAzoxpAmmS8kigJBL0ymw/QrPgyVKz1hiN2u/OOxmkjM0mrSB2fUGKghyHg0MGIIS8bx6H/pFuX7/WmuQHcUbk5Z6S64YXrb2Vqb3l6Ua0Tz7uwRWrWI8YyTb7KMyhAeYChK5zEWlMBIAv7T602qFJWerU+Eor4lLJmd7CunUah3voPJ4JL8LhhOcVlrWpke+1S+JB6LPOTjQZTjxN3qeR9uGMdl/Zk= + draft: true + on: + tags: true + branch: master + repo: bubba/lsp-test diff --git a/ChangeLog.md b/ChangeLog.md index 9397bfd..aa9d2af 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Revision history for lsp-test +## 0.6.0.0 -- 2019-07-04 + +* Update to haskell-lsp-0.15.0.0 (@lorenzo) + +## 0.5.4.0 -- 2019-06-13 + +* Fix `getDefinitions` for SingleLoc (@cocreature) +* Add `getCodeLenses` (@cocreature) + +## 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) + ## 0.5.2.0 -- 2019-04-28 * Add `satisfy` parser combinator diff --git a/lsp-test.cabal b/lsp-test.cabal index aca12b0..1c8350a 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.5.2.3 +version: 0.6.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -36,10 +36,11 @@ library , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.13.0 && < 0.14 + , haskell-lsp == 0.15.* , aeson , aeson-pretty , ansi-terminal + , async , bytestring , conduit , conduit-parse @@ -78,7 +79,7 @@ test-suite tests build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp >= 0.13.0 && < 0.14 + , haskell-lsp == 0.15.* , lsp-test , data-default , aeson 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 diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs index 9467a32..883bfc9 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -6,14 +6,30 @@ module Language.Haskell.LSP.Test.Compat where import Data.Maybe +import System.IO #if MIN_VERSION_process(1,6,3) -import System.Process hiding (getPid) +-- We have to hide cleanupProcess for process-1.6.3.0 +-- cause it is in the public api for 1.6.3.0 versions +-- shipped with ghc >= 8.6 and < 8.6.4 +import System.Process hiding (getPid, cleanupProcess, withCreateProcess) +# if MIN_VERSION_process(1,6,4) +import qualified System.Process (getPid, cleanupProcess, withCreateProcess) +# else +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) + import qualified System.Process (getPid) +import qualified Control.Exception as C +# endif #else -import System.Process -import System.Process.Internals import Control.Concurrent.MVar +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) +import System.Process hiding (withCreateProcess) +import System.Process.Internals + +import qualified Control.Exception as C #endif #ifdef mingw32_HOST_OS @@ -52,3 +68,48 @@ getProcessID p = fromIntegral . fromJust <$> getProcessID' p #endif _ -> return Nothing #endif + +cleanupProcess + :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () + +withCreateProcess + :: CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a + +#if MIN_VERSION_process(1,6,4) + +cleanupProcess = System.Process.cleanupProcess + +withCreateProcess = System.Process.withCreateProcess + +#else + +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do + -- We ignore the spurious "permission denied" error in windows: + -- see https://github.com/haskell/process/issues/110 + ignorePermDenied $ terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + + return () + where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE + ignorePermDenied = ignoreIOError PermissionDenied eACCES + +ignoreIOError :: IOErrorType -> Errno -> IO () -> IO () +ignoreIOError ioErrorType errno = + C.handle $ \e -> case e of + IOError { ioe_type = iot + , ioe_errno = Just ioe } + | iot == ioErrorType && Errno ioe == errno -> return () + _ -> C.throwIO e + +withCreateProcess c action = + C.bracket (createProcess c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + +#endif diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index 337dee3..af91928 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -32,7 +32,7 @@ getNextMessage :: Handle -> IO B.ByteString getNextMessage h = do headers <- getHeaders h case read . init <$> lookup "Content-Length" headers of - Nothing -> error "Couldn't read Content-Length header" + Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString @@ -123,7 +123,7 @@ matchResponseMsgType req = case req of 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 @@ decodeFromServerMsg reqMap bytes = 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 @@ decodeFromServerMsg reqMap bytes = 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/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index b1e0635..dd31ea3 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as B -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' data SessionException = Timeout + | NoContentLengthHeader | UnexpectedMessage String FromServerMessage | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics @@ -24,6 +25,7 @@ instance Exception SessionException instance Show SessionException where show Timeout = "Timed out waiting to receive a message from the server." + show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs index 1a3805f..16813e2 100644 --- a/src/Language/Haskell/LSP/Test/Messages.hs +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -59,6 +59,7 @@ handleServerMessage request response notification msg = case msg of (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 @@ handleServerMessage request response notification msg = case msg of (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 @@ handleServerMessage request response notification msg = case msg of (NotProgressDone m) -> notification m (NotTelemetry m) -> notification m (NotCancelRequestFromServer m) -> notification m + (NotCustomServer m) -> notification m handleClientMessage :: forall a. @@ -145,4 +148,5 @@ handleClientMessage request response notification msg = case msg of (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/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index b2d54a3..ac55e9e 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -23,6 +23,7 @@ import Control.Monad import System.FilePath import System.IO import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Messages @@ -43,8 +44,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - withServer serverExe False $ \serverIn serverOut pid -> do + withServer serverExe False $ \serverIn serverOut serverProc -> do + pid <- getProcessID serverProc events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events @@ -59,12 +61,12 @@ replaySession serverExe sessionDir = do mainThread <- myThreadId sessionThread <- liftIO $ forkIO $ - runSessionWithHandles serverIn - serverOut + runSessionWithHandles serverIn serverOut serverProc (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) def fullCaps sessionDir + (return ()) -- No finalizer cleanup (sendMessages clientMsgs reqSema rspSema) takeMVar passSema killThread sessionThread diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs index bd5bdb9..e66ed0a 100644 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -1,27 +1,22 @@ 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 -import System.Process +import System.Process hiding (withCreateProcess) -withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a +withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a withServer serverExe logStdErr f = do -- TODO Probably should just change runServer to accept -- 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 - + 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 - errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn - - pid <- getProcessID serverProc - - finally (f serverIn serverOut pid) $ do - killThread errSinkThread - terminateProcess serverProc + hSetBinaryMode serverErr True + let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn + withAsync errSinkThread $ \_ -> do + f serverIn serverOut serverProc diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a3ba35b..8e1afa8 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -60,11 +60,14 @@ import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding (error) import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions import System.Console.ANSI import System.Directory import System.IO +import System.Process (ProcessHandle()) +import System.Timeout -- | A session representing one instance of launching and connecting to a server. -- @@ -128,7 +131,7 @@ data SessionState = SessionState { curReqId :: LspId , vfs :: VFS - , curDiagnostics :: Map.Map Uri [Diagnostic] + , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] , curTimeoutId :: Int , overridingTimeout :: Bool -- ^ The last received message from the server. @@ -186,17 +189,23 @@ runSession context state session = runReaderT (runStateT conduit state) context -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out + -> ProcessHandle -- ^ Server process -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> ClientCapabilities -> FilePath -- ^ Root directory + -> Session () -- ^ To exit the Server properly -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do +runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir 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 @@ -206,11 +215,19 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps initState = SessionState (IdInt 0) mempty mempty 0 False Nothing - launchServerHandler = forkIO $ catch (serverHandler serverOut context) - (throwTo mainThreadId :: SessionException -> IO ()) - (result, _) <- bracket launchServerHandler killThread $ - const $ runSession context initState session - + runSession' = runSession context initState + + errorHandler = throwTo mainThreadId :: SessionException -> IO() + serverListenerLauncher = + forkIO $ catch (serverHandler serverOut context) errorHandler + server = (Just serverIn, Just serverOut, Nothing, serverProc) + serverAndListenerFinalizer tid = + finally (timeout (messageTimeout config * 1000000) + (runSession' exitServer)) + (cleanupProcess server >> killThread tid) + + (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer + (const $ runSession' session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -223,7 +240,7 @@ updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify (\s -> - let newDiags = Map.insert doc diags (curDiagnostics s) + let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags }) updateState (ReqApplyWorkspaceEdit r) = do @@ -242,7 +259,7 @@ updateState (ReqApplyWorkspaceEdit r) = do newVFS <- liftIO $ changeFromServerVFS (vfs s) r return $ s { vfs = newVFS } - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams + let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session @@ -257,7 +274,7 @@ updateState (ReqApplyWorkspaceEdit r) = do modify $ \s -> let oldVFS = vfs s update (VirtualFile oldV t mf) = VirtualFile (fromMaybe oldV v) t mf - newVFS = Map.adjust update uri oldVFS + newVFS = Map.adjust update (toNormalizedUri uri) oldVFS in s { vfs = newVFS } where checkIfNeedsOpened uri = do @@ -265,7 +282,7 @@ updateState (ReqApplyWorkspaceEdit r) = do ctx <- ask -- if its not open, open it - unless (uri `Map.member` oldVFS) $ do + unless (toNormalizedUri uri `Map.member` oldVFS) $ do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents diff --git a/stack.yaml b/stack.yaml index 26a1ba2..18275ba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,8 @@ -resolver: lts-13.21 +resolver: lts-13.26 packages: - . extra-deps: - - haskell-lsp-0.13.0.0 - - haskell-lsp-types-0.13.0.0 - rope-utf16-splay-0.3.1.0 + - haskell-lsp-0.15.0.0 + - haskell-lsp-types-0.15.0.0 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..ed04335 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: rope-utf16-splay-0.3.1.0@sha256:15a53c57f8413d193054bb5f045929edae3b2669def4c6af63197b30dc1d5003,2029 + pantry-tree: + size: 667 + sha256: 876b05bbbd1394bb862a7e2d460f6fe30f509c4c9a530530cb9fe7ec19a89c30 + original: + hackage: rope-utf16-splay-0.3.1.0 +- completed: + hackage: haskell-lsp-0.15.0.0@sha256:26791d3ed01ca5be1fab16a450fec751616acac8aa87c5a3a3921aea0d2bbfc2,5260 + pantry-tree: + size: 1725 + sha256: a08c3c4f25717c54f3c0adaefb3cd054c6a0a16f4b53d01617d6fc5a2e2798b0 + original: + hackage: haskell-lsp-0.15.0.0 +- completed: + hackage: haskell-lsp-types-0.15.0.0@sha256:75698e3af3c9c0f8494121a2bdd47bb4ccc423afb58fecfa43e9ffbcd8721b3c,2880 + pantry-tree: + size: 2369 + sha256: 04b8321fc9e60796cfecc0487f35c32208908f1ce7b7e2d75bc8347a1d91bcee + original: + hackage: haskell-lsp-types-0.15.0.0 +snapshots: +- completed: + size: 499889 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/26.yaml + sha256: ecb02ee16829df8d7219e7d7fe6c310819820bf335b0b9534bce84d3ea896684 + original: lts-13.26 diff --git a/test/Test.hs b/test/Test.hs index 377bb6d..75e1628 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -62,8 +62,12 @@ main = hspec $ do 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 () @@ -100,7 +104,7 @@ main = hspec $ do it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do loggingNotification - liftIO $ threadDelay 10 + liftIO $ threadDelay $ 10 * 1000000 _ <- openDoc "Desktop/simple.hs" "haskell" return () @@ -259,12 +263,12 @@ main = hspec $ do 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