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
11 Portability : non-portable
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.
56 , waitForDiagnosticsSource
58 , getCurrentDiagnostics
87 import Control.Applicative.Combinators
88 import Control.Concurrent
90 import Control.Monad.IO.Class
91 import Control.Exception
92 import Control.Lens hiding ((.=), List)
93 import qualified Data.Text as T
94 import qualified Data.Text.IO as T
97 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
113 import System.Environment
115 import System.Directory
116 import System.FilePath
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 pid <- getCurrentProcessID
142 absRootDir <- canonicalizePath rootDir
144 config <- envOverrideConfig config'
146 let initializeParams = InitializeParams (Just pid)
147 (Just $ T.pack absRootDir)
148 (Just $ filePathToUri absRootDir)
153 withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
154 runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
155 -- Wrap the session around initialize and shutdown calls
156 -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
157 initReqId <- sendRequest Initialize initializeParams
159 -- Because messages can be sent in between the request and response,
160 -- collect them and then...
161 (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
163 case initRspMsg ^. LSP.result of
164 Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
167 initRspVar <- initRsp <$> ask
168 liftIO $ putMVar initRspVar initRspMsg
169 sendNotification Initialized InitializedParams
171 case lspConfig config of
172 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
175 -- ... relay them back to the user Session so they can match on them!
176 -- As long as they are allowed.
177 forM_ inBetween checkLegalBetweenMessage
178 msgChan <- asks messageChan
179 liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)
181 -- Run the actual test
184 -- | Asks the server to shutdown and exit politely
185 exitServer :: Session ()
186 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
188 -- | Listens to the server output until the shutdown ack,
189 -- makes sure it matches the record and signals any semaphores
190 listenServer :: Handle -> SessionContext -> IO ()
191 listenServer serverOut context = do
192 msgBytes <- getNextMessage serverOut
194 reqMap <- readMVar $ requestMap context
196 let msg = decodeFromServerMsg reqMap msgBytes
197 writeChan (messageChan context) (ServerMessage msg)
200 (RspShutdown _) -> return ()
201 _ -> listenServer serverOut context
203 -- | Is this message allowed to be sent by the server between the intialize
204 -- request and response?
205 -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
206 checkLegalBetweenMessage :: FromServerMessage -> Session ()
207 checkLegalBetweenMessage (NotShowMessage _) = pure ()
208 checkLegalBetweenMessage (NotLogMessage _) = pure ()
209 checkLegalBetweenMessage (NotTelemetry _) = pure ()
210 checkLegalBetweenMessage (ReqShowMessage _) = pure ()
211 checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
213 -- | Check environment variables to override the config
214 envOverrideConfig :: SessionConfig -> IO SessionConfig
215 envOverrideConfig cfg = do
216 logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
217 logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
218 return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
219 where checkEnv :: String -> IO (Maybe Bool)
220 checkEnv s = fmap convertVal <$> lookupEnv s
221 convertVal "0" = False
224 -- | The current text contents of a document.
225 documentContents :: TextDocumentIdentifier -> Session T.Text
226 documentContents doc = do
228 let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
229 return (virtualFileText file)
231 -- | Parses an ApplyEditRequest, checks that it is for the passed document
232 -- and returns the new content
233 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
234 getDocumentEdit doc = do
235 req <- message :: Session ApplyWorkspaceEditRequest
237 unless (checkDocumentChanges req || checkChanges req) $
238 liftIO $ throw (IncorrectApplyEditRequest (show req))
242 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
243 checkDocumentChanges req =
244 let changes = req ^. params . edit . documentChanges
245 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
247 Just docs -> (doc ^. uri) `elem` docs
249 checkChanges :: ApplyWorkspaceEditRequest -> Bool
251 let mMap = req ^. params . edit . changes
252 in maybe False (HashMap.member (doc ^. uri)) mMap
254 -- | Sends a request to the server and waits for its response.
255 -- Will skip any messages in between the request and the response
257 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
259 -- Note: will skip any messages in between the request and the response.
260 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
261 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
263 -- | The same as 'sendRequest', but discard the response.
264 request_ :: ToJSON params => ClientMethod -> params -> Session ()
265 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
267 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
270 => ClientMethod -- ^ The request method.
271 -> params -- ^ The request parameters.
272 -> Session LspId -- ^ The id of the request that was sent.
273 sendRequest method params = do
274 id <- curReqId <$> get
275 modify $ \c -> c { curReqId = nextId id }
277 let req = RequestMessage' "2.0" id method params
279 -- Update the request map
280 reqMap <- requestMap <$> ask
281 liftIO $ modifyMVar_ reqMap $
282 \r -> return $ updateRequestMap r id method
288 where nextId (IdInt i) = IdInt (i + 1)
289 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
291 -- | A custom type for request message that doesn't
292 -- need a response type, allows us to infer the request
293 -- message type without using proxies.
294 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
296 instance ToJSON a => ToJSON (RequestMessage' a) where
297 toJSON (RequestMessage' rpc id method params) =
298 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
301 -- | Sends a notification to the server.
302 sendNotification :: ToJSON a
303 => ClientMethod -- ^ The notification method.
304 -> a -- ^ The notification parameters.
307 -- Open a virtual file if we send a did open text document notification
308 sendNotification TextDocumentDidOpen params = do
309 let params' = fromJust $ decode $ encode params
310 n :: DidOpenTextDocumentNotification
311 n = NotificationMessage "2.0" TextDocumentDidOpen params'
312 oldVFS <- vfs <$> get
313 let (newVFS,_) = openVFS oldVFS n
314 modify (\s -> s { vfs = newVFS })
317 -- Close a virtual file if we send a close text document notification
318 sendNotification TextDocumentDidClose params = do
319 let params' = fromJust $ decode $ encode params
320 n :: DidCloseTextDocumentNotification
321 n = NotificationMessage "2.0" TextDocumentDidClose params'
322 oldVFS <- vfs <$> get
323 let (newVFS,_) = closeVFS oldVFS n
324 modify (\s -> s { vfs = newVFS })
327 sendNotification TextDocumentDidChange params = do
328 let params' = fromJust $ decode $ encode params
329 n :: DidChangeTextDocumentNotification
330 n = NotificationMessage "2.0" TextDocumentDidChange params'
331 oldVFS <- vfs <$> get
332 let (newVFS,_) = changeFromClientVFS oldVFS n
333 modify (\s -> s { vfs = newVFS })
336 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
338 -- | Sends a response to the server.
339 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
340 sendResponse = sendMessage
342 -- | Returns the initialize response that was received from the server.
343 -- The initialize requests and responses are not included the session,
344 -- so if you need to test it use this.
345 initializeResponse :: Session InitializeResponse
346 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
348 -- | Opens a text document and sends a notification to the client.
349 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
350 openDoc file languageId = do
352 let fp = rootDir context </> file
353 contents <- liftIO $ T.readFile fp
354 openDoc' file languageId contents
356 -- | This is a variant of `openDoc` that takes the file content as an argument.
357 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
358 openDoc' file languageId contents = do
360 let fp = rootDir context </> file
361 uri = filePathToUri fp
362 item = TextDocumentItem uri (T.pack languageId) 0 contents
363 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
364 pure $ TextDocumentIdentifier uri
366 -- | Closes a text document and sends a notification to the client.
367 closeDoc :: TextDocumentIdentifier -> Session ()
369 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
370 sendNotification TextDocumentDidClose params
372 -- | Changes a text document and sends a notification to the client
373 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
374 changeDoc docId changes = do
375 verDoc <- getVersionedDoc docId
376 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
377 sendNotification TextDocumentDidChange params
379 -- | Gets the Uri for the file corrected to the session directory.
380 getDocUri :: FilePath -> Session Uri
383 let fp = rootDir context </> file
384 return $ filePathToUri fp
386 -- | Waits for diagnostics to be published and returns them.
387 waitForDiagnostics :: Session [Diagnostic]
388 waitForDiagnostics = do
389 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
390 let (List diags) = diagsNot ^. params . LSP.diagnostics
393 -- | The same as 'waitForDiagnostics', but will only match a specific
394 -- 'Language.Haskell.LSP.Types._source'.
395 waitForDiagnosticsSource :: String -> Session [Diagnostic]
396 waitForDiagnosticsSource src = do
397 diags <- waitForDiagnostics
398 let res = filter matches diags
400 then waitForDiagnosticsSource src
403 matches :: Diagnostic -> Bool
404 matches d = d ^. source == Just (T.pack src)
406 -- | Expects a 'PublishDiagnosticsNotification' and throws an
407 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
409 noDiagnostics :: Session ()
411 diagsNot <- message :: Session PublishDiagnosticsNotification
412 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
414 -- | Returns the symbols in a document.
415 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
416 getDocumentSymbols doc = do
417 ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
419 Right (DSDocumentSymbols (List xs)) -> return (Left xs)
420 Right (DSSymbolInformation (List xs)) -> return (Right xs)
421 Left err -> throw (UnexpectedResponseError rspLid err)
423 -- | Returns the code actions in the specified range.
424 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
425 getCodeActions doc range = do
426 ctx <- getCodeActionContext doc
427 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
429 case rsp ^. result of
430 Right (List xs) -> return xs
431 Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)
433 -- | Returns all the code actions in a document by
434 -- querying the code actions at each of the current
435 -- diagnostics' positions.
436 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
437 getAllCodeActions doc = do
438 ctx <- getCodeActionContext doc
440 foldM (go ctx) [] =<< getCurrentDiagnostics doc
443 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
445 ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
448 Left e -> throw (UnexpectedResponseError rspLid e)
449 Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
451 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
452 getCodeActionContext doc = do
453 curDiags <- getCurrentDiagnostics doc
454 return $ CodeActionContext (List curDiags) Nothing
456 -- | Returns the current diagnostics that have been sent to the client.
457 -- Note that this does not wait for more to come in.
458 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
459 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
461 -- | Executes a command.
462 executeCommand :: Command -> Session ()
463 executeCommand cmd = do
464 let args = decode $ encode $ fromJust $ cmd ^. arguments
465 execParams = ExecuteCommandParams (cmd ^. command) args Nothing
466 request_ WorkspaceExecuteCommand execParams
468 -- | Executes a code action.
469 -- Matching with the specification, if a code action
470 -- contains both an edit and a command, the edit will
472 executeCodeAction :: CodeAction -> Session ()
473 executeCodeAction action = do
474 maybe (return ()) handleEdit $ action ^. edit
475 maybe (return ()) executeCommand $ action ^. command
477 where handleEdit :: WorkspaceEdit -> Session ()
479 -- Its ok to pass in dummy parameters here as they aren't used
480 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
481 in updateState (ReqApplyWorkspaceEdit req)
483 -- | Adds the current version to the document, as tracked by the session.
484 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
485 getVersionedDoc (TextDocumentIdentifier uri) = do
486 fs <- vfsMap . vfs <$> get
488 case fs Map.!? toNormalizedUri uri of
489 Just vf -> Just (virtualFileVersion vf)
491 return (VersionedTextDocumentIdentifier uri ver)
493 -- | Applys an edit to the document and returns the updated document version.
494 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
495 applyEdit doc edit = do
497 verDoc <- getVersionedDoc doc
499 caps <- asks sessionCapabilities
501 let supportsDocChanges = fromMaybe False $ do
502 let mWorkspace = C._workspace caps
503 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
504 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
507 let wEdit = if supportsDocChanges
509 let docEdit = TextDocumentEdit verDoc (List [edit])
510 in WorkspaceEdit Nothing (Just (List [docEdit]))
512 let changes = HashMap.singleton (doc ^. uri) (List [edit])
513 in WorkspaceEdit (Just changes) Nothing
515 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
516 updateState (ReqApplyWorkspaceEdit req)
518 -- version may have changed
521 -- | Returns the completions for the position in the document.
522 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
523 getCompletions doc pos = do
524 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
526 case getResponseResult rsp of
527 Completions (List items) -> return items
528 CompletionList (CompletionListType _ (List items)) -> return items
530 -- | Returns the references for the position in the document.
531 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
532 -> Position -- ^ The position to lookup.
533 -> Bool -- ^ Whether to include declarations as references.
534 -> Session [Location] -- ^ The locations of the references.
535 getReferences doc pos inclDecl =
536 let ctx = ReferenceContext inclDecl
537 params = ReferenceParams doc pos ctx Nothing
538 in getResponseResult <$> request TextDocumentReferences params
540 -- | Returns the definition(s) for the term at the specified position.
541 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
542 -> Position -- ^ The position the term is at.
543 -> Session [Location] -- ^ The location(s) of the definitions
544 getDefinitions doc pos = do
545 let params = TextDocumentPositionParams doc pos Nothing
546 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
547 case getResponseResult rsp of
548 SingleLoc loc -> pure [loc]
549 MultiLoc locs -> pure locs
551 -- | Returns the type definition(s) for the term at the specified position.
552 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
553 -> Position -- ^ The position the term is at.
554 -> Session [Location] -- ^ The location(s) of the definitions
555 getTypeDefinitions doc pos =
556 let params = TextDocumentPositionParams doc pos Nothing
557 in getResponseResult <$> request TextDocumentTypeDefinition params
559 -- | Renames the term at the specified position.
560 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
561 rename doc pos newName = do
562 let params = RenameParams doc pos (T.pack newName) Nothing
563 rsp <- request TextDocumentRename params :: Session RenameResponse
564 let wEdit = getResponseResult rsp
565 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
566 updateState (ReqApplyWorkspaceEdit req)
568 -- | Returns the hover information at the specified position.
569 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
571 let params = TextDocumentPositionParams doc pos Nothing
572 in getResponseResult <$> request TextDocumentHover params
574 -- | Returns the highlighted occurences of the term at the specified position
575 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
576 getHighlights doc pos =
577 let params = TextDocumentPositionParams doc pos Nothing
578 in getResponseResult <$> request TextDocumentDocumentHighlight params
580 -- | Checks the response for errors and throws an exception if needed.
581 -- Returns the result if successful.
582 getResponseResult :: ResponseMessage a -> a
583 getResponseResult rsp =
584 case rsp ^. result of
586 Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err
588 -- | Applies formatting to the specified document.
589 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
590 formatDoc doc opts = do
591 let params = DocumentFormattingParams doc opts Nothing
592 edits <- getResponseResult <$> request TextDocumentFormatting params
593 applyTextEdits doc edits
595 -- | Applies formatting to the specified range in a document.
596 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
597 formatRange doc opts range = do
598 let params = DocumentRangeFormattingParams doc range opts Nothing
599 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
600 applyTextEdits doc edits
602 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
603 applyTextEdits doc edits =
604 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
605 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
606 in updateState (ReqApplyWorkspaceEdit req)
608 -- | Returns the code lenses for the specified document.
609 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
610 getCodeLenses tId = do
611 rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
612 case getResponseResult rsp of