1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE ExistentialQuantification #-}
7 Module : Language.Haskell.LSP.Test
8 Description : A functional testing framework for LSP servers.
9 Maintainer : luke_lau@icloud.com
10 Stability : experimental
13 Provides the framework to start functionally testing
14 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
15 You should import "Language.Haskell.LSP.Types" alongside this.
17 module Language.Haskell.LSP.Test
23 , runSessionWithConfig
28 , module Language.Haskell.LSP.Test.Exceptions
37 , module Language.Haskell.LSP.Test.Parsing
39 -- | Quick helper functions for common tasks.
55 , waitForDiagnosticsSource
57 , getCurrentDiagnostics
86 import Control.Applicative.Combinators
87 import Control.Concurrent
89 import Control.Monad.IO.Class
90 import Control.Exception
91 import Control.Lens hiding ((.=), List)
92 import qualified Data.Text as T
93 import qualified Data.Text.IO as T
96 import qualified Data.HashMap.Strict as HashMap
98 import qualified Data.Map as Map
100 import Language.Haskell.LSP.Types
101 import Language.Haskell.LSP.Types.Lens hiding
102 (id, capabilities, message, executeCommand, applyEdit, rename)
103 import qualified Language.Haskell.LSP.Types.Lens as LSP
104 import qualified Language.Haskell.LSP.Types.Capabilities as C
105 import Language.Haskell.LSP.Messages
106 import Language.Haskell.LSP.VFS
107 import Language.Haskell.LSP.Test.Compat
108 import Language.Haskell.LSP.Test.Decoding
109 import Language.Haskell.LSP.Test.Exceptions
110 import Language.Haskell.LSP.Test.Parsing
111 import Language.Haskell.LSP.Test.Session
112 import Language.Haskell.LSP.Test.Server
114 import System.Directory
115 import System.FilePath
116 import qualified Data.Rope.UTF16 as Rope
118 -- | Starts a new session.
120 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
121 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
122 -- > diags <- waitForDiagnostics
123 -- > let pos = Position 12 5
124 -- > params = TextDocumentPositionParams doc
125 -- > hover <- request TextDocumentHover params
126 runSession :: String -- ^ The command to run the server.
127 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
128 -> FilePath -- ^ The filepath to the root directory for the session.
129 -> Session a -- ^ The session to run.
131 runSession = runSessionWithConfig def
133 -- | Starts a new sesion with a custom configuration.
134 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
135 -> String -- ^ The command to run the server.
136 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
137 -> FilePath -- ^ The filepath to the root directory for the session.
138 -> Session a -- ^ The session to run.
140 runSessionWithConfig config serverExe caps rootDir session = do
141 -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.
142 exitOk <- newIORef False
143 pid <- getCurrentProcessID
144 absRootDir <- canonicalizePath rootDir
146 let initializeParams = InitializeParams (Just pid)
147 (Just $ T.pack absRootDir)
148 (Just $ filePathToUri absRootDir)
153 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
154 runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do
156 -- Wrap the session around initialize and shutdown calls
157 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
159 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
161 initRspVar <- initRsp <$> ask
162 liftIO $ putMVar initRspVar initRspMsg
164 sendNotification Initialized InitializedParams
166 case lspConfig config of
167 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
170 -- Run the actual test
173 liftIO $ atomicWriteIORef exitOk True
174 sendNotification Exit ExitParams
178 catchWhenTrue :: IORef Bool -> IO () -> IO ()
179 catchWhenTrue exitOk a =
181 x <- readIORef exitOk
182 unless x $ throw (e :: SomeException))
184 -- | Listens to the server output, makes sure it matches the record and
185 -- signals any semaphores
186 -- Note that on Windows, we cannot kill a thread stuck in getNextMessage.
187 -- So we have to wait for the exit notification to kill the process first
188 -- and then getNextMessage will fail.
189 listenServer :: Handle -> SessionContext -> IO ()
190 listenServer serverOut context = do
191 msgBytes <- getNextMessage serverOut
193 reqMap <- readMVar $ requestMap context
195 let msg = decodeFromServerMsg reqMap msgBytes
196 writeChan (messageChan context) (ServerMessage msg)
198 listenServer serverOut context
200 -- | The current text contents of a document.
201 documentContents :: TextDocumentIdentifier -> Session T.Text
202 documentContents doc = do
204 let file = vfs Map.! (doc ^. uri)
205 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
207 -- | Parses an ApplyEditRequest, checks that it is for the passed document
208 -- and returns the new content
209 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
210 getDocumentEdit doc = do
211 req <- message :: Session ApplyWorkspaceEditRequest
213 unless (checkDocumentChanges req || checkChanges req) $
214 liftIO $ throw (IncorrectApplyEditRequest (show req))
218 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
219 checkDocumentChanges req =
220 let changes = req ^. params . edit . documentChanges
221 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
223 Just docs -> (doc ^. uri) `elem` docs
225 checkChanges :: ApplyWorkspaceEditRequest -> Bool
227 let mMap = req ^. params . edit . changes
228 in maybe False (HashMap.member (doc ^. uri)) mMap
230 -- | Sends a request to the server and waits for its response.
231 -- Will skip any messages in between the request and the response
233 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
235 -- Note: will skip any messages in between the request and the response.
236 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
237 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
239 -- | The same as 'sendRequest', but discard the response.
240 request_ :: ToJSON params => ClientMethod -> params -> Session ()
241 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
243 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
246 => ClientMethod -- ^ The request method.
247 -> params -- ^ The request parameters.
248 -> Session LspId -- ^ The id of the request that was sent.
249 sendRequest method params = do
250 id <- curReqId <$> get
251 modify $ \c -> c { curReqId = nextId id }
253 let req = RequestMessage' "2.0" id method params
255 -- Update the request map
256 reqMap <- requestMap <$> ask
257 liftIO $ modifyMVar_ reqMap $
258 \r -> return $ updateRequestMap r id method
264 where nextId (IdInt i) = IdInt (i + 1)
265 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
267 -- | A custom type for request message that doesn't
268 -- need a response type, allows us to infer the request
269 -- message type without using proxies.
270 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
272 instance ToJSON a => ToJSON (RequestMessage' a) where
273 toJSON (RequestMessage' rpc id method params) =
274 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
277 -- | Sends a notification to the server.
278 sendNotification :: ToJSON a
279 => ClientMethod -- ^ The notification method.
280 -> a -- ^ The notification parameters.
283 -- Open a virtual file if we send a did open text document notification
284 sendNotification TextDocumentDidOpen params = do
285 let params' = fromJust $ decode $ encode params
286 n :: DidOpenTextDocumentNotification
287 n = NotificationMessage "2.0" TextDocumentDidOpen params'
288 oldVFS <- vfs <$> get
289 newVFS <- liftIO $ openVFS oldVFS n
290 modify (\s -> s { vfs = newVFS })
293 -- Close a virtual file if we send a close text document notification
294 sendNotification TextDocumentDidClose params = do
295 let params' = fromJust $ decode $ encode params
296 n :: DidCloseTextDocumentNotification
297 n = NotificationMessage "2.0" TextDocumentDidClose params'
298 oldVFS <- vfs <$> get
299 newVFS <- liftIO $ closeVFS oldVFS n
300 modify (\s -> s { vfs = newVFS })
303 sendNotification TextDocumentDidChange params = do
304 let params' = fromJust $ decode $ encode params
305 n :: DidChangeTextDocumentNotification
306 n = NotificationMessage "2.0" TextDocumentDidChange params'
307 oldVFS <- vfs <$> get
308 newVFS <- liftIO $ changeFromClientVFS oldVFS n
309 modify (\s -> s { vfs = newVFS })
312 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
314 -- | Sends a response to the server.
315 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
316 sendResponse = sendMessage
318 -- | Returns the initialize response that was received from the server.
319 -- The initialize requests and responses are not included the session,
320 -- so if you need to test it use this.
321 initializeResponse :: Session InitializeResponse
322 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
324 -- | Opens a text document and sends a notification to the client.
325 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
326 openDoc file languageId = do
328 let fp = rootDir context </> file
329 contents <- liftIO $ T.readFile fp
330 openDoc' file languageId contents
332 -- | This is a variant of `openDoc` that takes the file content as an argument.
333 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
334 openDoc' file languageId contents = do
336 let fp = rootDir context </> file
337 uri = filePathToUri fp
338 item = TextDocumentItem uri (T.pack languageId) 0 contents
339 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
340 pure $ TextDocumentIdentifier uri
342 -- | Closes a text document and sends a notification to the client.
343 closeDoc :: TextDocumentIdentifier -> Session ()
345 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
346 sendNotification TextDocumentDidClose params
348 -- | Changes a text document and sends a notification to the client
349 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
350 changeDoc docId changes = do
351 verDoc <- getVersionedDoc docId
352 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
353 sendNotification TextDocumentDidChange params
355 -- | Gets the Uri for the file corrected to the session directory.
356 getDocUri :: FilePath -> Session Uri
359 let fp = rootDir context </> file
360 return $ filePathToUri fp
362 -- | Waits for diagnostics to be published and returns them.
363 waitForDiagnostics :: Session [Diagnostic]
364 waitForDiagnostics = do
365 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
366 let (List diags) = diagsNot ^. params . LSP.diagnostics
369 -- | The same as 'waitForDiagnostics', but will only match a specific
370 -- 'Language.Haskell.LSP.Types._source'.
371 waitForDiagnosticsSource :: String -> Session [Diagnostic]
372 waitForDiagnosticsSource src = do
373 diags <- waitForDiagnostics
374 let res = filter matches diags
376 then waitForDiagnosticsSource src
379 matches :: Diagnostic -> Bool
380 matches d = d ^. source == Just (T.pack src)
382 -- | Expects a 'PublishDiagnosticsNotification' and throws an
383 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
385 noDiagnostics :: Session ()
387 diagsNot <- message :: Session PublishDiagnosticsNotification
388 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
390 -- | Returns the symbols in a document.
391 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
392 getDocumentSymbols doc = do
393 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
394 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
396 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
397 Just (DSSymbolInformation (List xs)) -> return (Right xs)
398 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
400 -- | Returns the code actions in the specified range.
401 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
402 getCodeActions doc range = do
403 ctx <- getCodeActionContext doc
404 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
406 case rsp ^. result of
407 Just (List xs) -> return xs
408 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
410 -- | Returns all the code actions in a document by
411 -- querying the code actions at each of the current
412 -- diagnostics' positions.
413 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
414 getAllCodeActions doc = do
415 ctx <- getCodeActionContext doc
417 foldM (go ctx) [] =<< getCurrentDiagnostics doc
420 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
422 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
425 Just e -> throw (UnexpectedResponseError rspLid e)
427 let Just (List cmdOrCAs) = mRes
428 in return (acc ++ cmdOrCAs)
430 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
431 getCodeActionContext doc = do
432 curDiags <- getCurrentDiagnostics doc
433 return $ CodeActionContext (List curDiags) Nothing
435 -- | Returns the current diagnostics that have been sent to the client.
436 -- Note that this does not wait for more to come in.
437 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
438 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
440 -- | Executes a command.
441 executeCommand :: Command -> Session ()
442 executeCommand cmd = do
443 let args = decode $ encode $ fromJust $ cmd ^. arguments
444 execParams = ExecuteCommandParams (cmd ^. command) args
445 request_ WorkspaceExecuteCommand execParams
447 -- | Executes a code action.
448 -- Matching with the specification, if a code action
449 -- contains both an edit and a command, the edit will
451 executeCodeAction :: CodeAction -> Session ()
452 executeCodeAction action = do
453 maybe (return ()) handleEdit $ action ^. edit
454 maybe (return ()) executeCommand $ action ^. command
456 where handleEdit :: WorkspaceEdit -> Session ()
458 -- Its ok to pass in dummy parameters here as they aren't used
459 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
460 in updateState (ReqApplyWorkspaceEdit req)
462 -- | Adds the current version to the document, as tracked by the session.
463 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
464 getVersionedDoc (TextDocumentIdentifier uri) = do
467 case fs Map.!? uri of
468 Just (VirtualFile v _ _) -> Just v
470 return (VersionedTextDocumentIdentifier uri ver)
472 -- | Applys an edit to the document and returns the updated document version.
473 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
474 applyEdit doc edit = do
476 verDoc <- getVersionedDoc doc
478 caps <- asks sessionCapabilities
480 let supportsDocChanges = fromMaybe False $ do
481 let mWorkspace = C._workspace caps
482 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
483 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
486 let wEdit = if supportsDocChanges
488 let docEdit = TextDocumentEdit verDoc (List [edit])
489 in WorkspaceEdit Nothing (Just (List [docEdit]))
491 let changes = HashMap.singleton (doc ^. uri) (List [edit])
492 in WorkspaceEdit (Just changes) Nothing
494 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
495 updateState (ReqApplyWorkspaceEdit req)
497 -- version may have changed
500 -- | Returns the completions for the position in the document.
501 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
502 getCompletions doc pos = do
503 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
505 case getResponseResult rsp of
506 Completions (List items) -> return items
507 CompletionList (CompletionListType _ (List items)) -> return items
509 -- | Returns the references for the position in the document.
510 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
511 -> Position -- ^ The position to lookup.
512 -> Bool -- ^ Whether to include declarations as references.
513 -> Session [Location] -- ^ The locations of the references.
514 getReferences doc pos inclDecl =
515 let ctx = ReferenceContext inclDecl
516 params = ReferenceParams doc pos ctx
517 in getResponseResult <$> request TextDocumentReferences params
519 -- | Returns the definition(s) for the term at the specified position.
520 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
521 -> Position -- ^ The position the term is at.
522 -> Session [Location] -- ^ The location(s) of the definitions
523 getDefinitions doc pos = do
524 let params = TextDocumentPositionParams doc pos
525 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
526 case getResponseResult rsp of
527 SingleLoc loc -> pure [loc]
528 MultiLoc locs -> pure locs
530 -- | Returns the type definition(s) for the term at the specified position.
531 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
532 -> Position -- ^ The position the term is at.
533 -> Session [Location] -- ^ The location(s) of the definitions
534 getTypeDefinitions doc pos =
535 let params = TextDocumentPositionParams doc pos
536 in getResponseResult <$> request TextDocumentTypeDefinition params
538 -- | Renames the term at the specified position.
539 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
540 rename doc pos newName = do
541 let params = RenameParams doc pos (T.pack newName)
542 rsp <- request TextDocumentRename params :: Session RenameResponse
543 let wEdit = getResponseResult rsp
544 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
545 updateState (ReqApplyWorkspaceEdit req)
547 -- | Returns the hover information at the specified position.
548 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
550 let params = TextDocumentPositionParams doc pos
551 in getResponseResult <$> request TextDocumentHover params
553 -- | Returns the highlighted occurences of the term at the specified position
554 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
555 getHighlights doc pos =
556 let params = TextDocumentPositionParams doc pos
557 in getResponseResult <$> request TextDocumentDocumentHighlight params
559 -- | Checks the response for errors and throws an exception if needed.
560 -- Returns the result if successful.
561 getResponseResult :: ResponseMessage a -> a
562 getResponseResult rsp = fromMaybe exc (rsp ^. result)
563 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
564 (fromJust $ rsp ^. LSP.error)
566 -- | Applies formatting to the specified document.
567 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
568 formatDoc doc opts = do
569 let params = DocumentFormattingParams doc opts
570 edits <- getResponseResult <$> request TextDocumentFormatting params
571 applyTextEdits doc edits
573 -- | Applies formatting to the specified range in a document.
574 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
575 formatRange doc opts range = do
576 let params = DocumentRangeFormattingParams doc range opts
577 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
578 applyTextEdits doc edits
580 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
581 applyTextEdits doc edits =
582 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
583 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
584 in updateState (ReqApplyWorkspaceEdit req)
586 -- | Returns the code lenses for the specified document.
587 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
588 getCodeLenses tId = do
589 rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse
590 case getResponseResult rsp of