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
# 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
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
, 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
build-depends: base >= 4.10 && < 5
, hspec
, lens
- , haskell-lsp >= 0.13.0 && < 0.14
+ , haskell-lsp == 0.15.*
, lsp-test
, data-default
, aeson
, initializeResponse
-- ** Documents
, openDoc
+ , openDoc'
, closeDoc
+ , changeDoc
, documentContents
, getDocumentEdit
, getDocUri
, formatRange
-- ** Edits
, applyEdit
+ -- ** Code lenses
+ , getCodeLenses
) where
import Control.Applicative.Combinators
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
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
-
sendNotification Initialized InitializedParams
case lspConfig config of
-- 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
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
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.
-- | 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 ()
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
-- | 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 ()
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)
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.
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
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
#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
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
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
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
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
-- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'
data SessionException = Timeout
+ | NoContentLengthHeader
| UnexpectedMessage String FromServerMessage
| ReplayOutOfOrder FromServerMessage [FromServerMessage]
| UnexpectedDiagnostics
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" ++
(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
(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
(NotProgressDone m) -> notification m
(NotTelemetry m) -> notification m
(NotCancelRequestFromServer m) -> notification m
+ (NotCustomServer m) -> notification m
handleClientMessage
:: forall a.
(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
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
-- 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
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
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
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.
--
{
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.
-- 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
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)) ()
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
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
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
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
-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
--- /dev/null
+# 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
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 ()
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 ()
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
projects / lsp-test.git / commitdiff