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 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
165 initRspVar <- initRsp <$> ask
166 liftIO $ putMVar initRspVar initRspMsg
167 sendNotification Initialized InitializedParams
169 case lspConfig config of
170 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
173 -- ... relay them back to the user Session so they can match on them!
174 -- As long as they are allowed.
175 forM_ inBetween checkLegalBetweenMessage
176 msgChan <- asks messageChan
177 liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)
179 -- Run the actual test
182 -- | Asks the server to shutdown and exit politely
183 exitServer :: Session ()
184 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
186 -- | Listens to the server output until the shutdown ack,
187 -- makes sure it matches the record and signals any semaphores
188 listenServer :: Handle -> SessionContext -> IO ()
189 listenServer serverOut context = do
190 msgBytes <- getNextMessage serverOut
192 reqMap <- readMVar $ requestMap context
194 let msg = decodeFromServerMsg reqMap msgBytes
195 writeChan (messageChan context) (ServerMessage msg)
198 (RspShutdown _) -> return ()
199 _ -> listenServer serverOut context
201 -- | Is this message allowed to be sent by the server between the intialize
202 -- request and response?
203 -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
204 checkLegalBetweenMessage :: FromServerMessage -> Session ()
205 checkLegalBetweenMessage (NotShowMessage _) = pure ()
206 checkLegalBetweenMessage (NotLogMessage _) = pure ()
207 checkLegalBetweenMessage (NotTelemetry _) = pure ()
208 checkLegalBetweenMessage (ReqShowMessage _) = pure ()
209 checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
211 -- | Check environment variables to override the config
212 envOverrideConfig :: SessionConfig -> IO SessionConfig
213 envOverrideConfig cfg = do
214 logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
215 logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
216 return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
217 where checkEnv :: String -> IO (Maybe Bool)
218 checkEnv s = fmap convertVal <$> lookupEnv s
219 convertVal "0" = False
222 -- | The current text contents of a document.
223 documentContents :: TextDocumentIdentifier -> Session T.Text
224 documentContents doc = do
226 let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
227 return (virtualFileText file)
229 -- | Parses an ApplyEditRequest, checks that it is for the passed document
230 -- and returns the new content
231 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
232 getDocumentEdit doc = do
233 req <- message :: Session ApplyWorkspaceEditRequest
235 unless (checkDocumentChanges req || checkChanges req) $
236 liftIO $ throw (IncorrectApplyEditRequest (show req))
240 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
241 checkDocumentChanges req =
242 let changes = req ^. params . edit . documentChanges
243 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
245 Just docs -> (doc ^. uri) `elem` docs
247 checkChanges :: ApplyWorkspaceEditRequest -> Bool
249 let mMap = req ^. params . edit . changes
250 in maybe False (HashMap.member (doc ^. uri)) mMap
252 -- | Sends a request to the server and waits for its response.
253 -- Will skip any messages in between the request and the response
255 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
257 -- Note: will skip any messages in between the request and the response.
258 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
259 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
261 -- | The same as 'sendRequest', but discard the response.
262 request_ :: ToJSON params => ClientMethod -> params -> Session ()
263 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
265 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
268 => ClientMethod -- ^ The request method.
269 -> params -- ^ The request parameters.
270 -> Session LspId -- ^ The id of the request that was sent.
271 sendRequest method params = do
272 id <- curReqId <$> get
273 modify $ \c -> c { curReqId = nextId id }
275 let req = RequestMessage' "2.0" id method params
277 -- Update the request map
278 reqMap <- requestMap <$> ask
279 liftIO $ modifyMVar_ reqMap $
280 \r -> return $ updateRequestMap r id method
286 where nextId (IdInt i) = IdInt (i + 1)
287 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
289 -- | A custom type for request message that doesn't
290 -- need a response type, allows us to infer the request
291 -- message type without using proxies.
292 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
294 instance ToJSON a => ToJSON (RequestMessage' a) where
295 toJSON (RequestMessage' rpc id method params) =
296 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
299 -- | Sends a notification to the server.
300 sendNotification :: ToJSON a
301 => ClientMethod -- ^ The notification method.
302 -> a -- ^ The notification parameters.
305 -- Open a virtual file if we send a did open text document notification
306 sendNotification TextDocumentDidOpen params = do
307 let params' = fromJust $ decode $ encode params
308 n :: DidOpenTextDocumentNotification
309 n = NotificationMessage "2.0" TextDocumentDidOpen params'
310 oldVFS <- vfs <$> get
311 let (newVFS,_) = openVFS oldVFS n
312 modify (\s -> s { vfs = newVFS })
315 -- Close a virtual file if we send a close text document notification
316 sendNotification TextDocumentDidClose params = do
317 let params' = fromJust $ decode $ encode params
318 n :: DidCloseTextDocumentNotification
319 n = NotificationMessage "2.0" TextDocumentDidClose params'
320 oldVFS <- vfs <$> get
321 let (newVFS,_) = closeVFS oldVFS n
322 modify (\s -> s { vfs = newVFS })
325 sendNotification TextDocumentDidChange params = do
326 let params' = fromJust $ decode $ encode params
327 n :: DidChangeTextDocumentNotification
328 n = NotificationMessage "2.0" TextDocumentDidChange params'
329 oldVFS <- vfs <$> get
330 let (newVFS,_) = changeFromClientVFS oldVFS n
331 modify (\s -> s { vfs = newVFS })
334 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
336 -- | Sends a response to the server.
337 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
338 sendResponse = sendMessage
340 -- | Returns the initialize response that was received from the server.
341 -- The initialize requests and responses are not included the session,
342 -- so if you need to test it use this.
343 initializeResponse :: Session InitializeResponse
344 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
346 -- | Opens a text document and sends a notification to the client.
347 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
348 openDoc file languageId = do
350 let fp = rootDir context </> file
351 contents <- liftIO $ T.readFile fp
352 openDoc' file languageId contents
354 -- | This is a variant of `openDoc` that takes the file content as an argument.
355 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
356 openDoc' file languageId contents = do
358 let fp = rootDir context </> file
359 uri = filePathToUri fp
360 item = TextDocumentItem uri (T.pack languageId) 0 contents
361 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
362 pure $ TextDocumentIdentifier uri
364 -- | Closes a text document and sends a notification to the client.
365 closeDoc :: TextDocumentIdentifier -> Session ()
367 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
368 sendNotification TextDocumentDidClose params
370 -- | Changes a text document and sends a notification to the client
371 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
372 changeDoc docId changes = do
373 verDoc <- getVersionedDoc docId
374 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
375 sendNotification TextDocumentDidChange params
377 -- | Gets the Uri for the file corrected to the session directory.
378 getDocUri :: FilePath -> Session Uri
381 let fp = rootDir context </> file
382 return $ filePathToUri fp
384 -- | Waits for diagnostics to be published and returns them.
385 waitForDiagnostics :: Session [Diagnostic]
386 waitForDiagnostics = do
387 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
388 let (List diags) = diagsNot ^. params . LSP.diagnostics
391 -- | The same as 'waitForDiagnostics', but will only match a specific
392 -- 'Language.Haskell.LSP.Types._source'.
393 waitForDiagnosticsSource :: String -> Session [Diagnostic]
394 waitForDiagnosticsSource src = do
395 diags <- waitForDiagnostics
396 let res = filter matches diags
398 then waitForDiagnosticsSource src
401 matches :: Diagnostic -> Bool
402 matches d = d ^. source == Just (T.pack src)
404 -- | Expects a 'PublishDiagnosticsNotification' and throws an
405 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
407 noDiagnostics :: Session ()
409 diagsNot <- message :: Session PublishDiagnosticsNotification
410 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
412 -- | Returns the symbols in a document.
413 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
414 getDocumentSymbols doc = do
415 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
416 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
418 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
419 Just (DSSymbolInformation (List xs)) -> return (Right xs)
420 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
422 -- | Returns the code actions in the specified range.
423 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
424 getCodeActions doc range = do
425 ctx <- getCodeActionContext doc
426 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
428 case rsp ^. result of
429 Just (List xs) -> return xs
430 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
432 -- | Returns all the code actions in a document by
433 -- querying the code actions at each of the current
434 -- diagnostics' positions.
435 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
436 getAllCodeActions doc = do
437 ctx <- getCodeActionContext doc
439 foldM (go ctx) [] =<< getCurrentDiagnostics doc
442 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
444 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
447 Just e -> throw (UnexpectedResponseError rspLid e)
449 let Just (List cmdOrCAs) = mRes
450 in return (acc ++ cmdOrCAs)
452 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
453 getCodeActionContext doc = do
454 curDiags <- getCurrentDiagnostics doc
455 return $ CodeActionContext (List curDiags) Nothing
457 -- | Returns the current diagnostics that have been sent to the client.
458 -- Note that this does not wait for more to come in.
459 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
460 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
462 -- | Executes a command.
463 executeCommand :: Command -> Session ()
464 executeCommand cmd = do
465 let args = decode $ encode $ fromJust $ cmd ^. arguments
466 execParams = ExecuteCommandParams (cmd ^. command) args Nothing
467 request_ WorkspaceExecuteCommand execParams
469 -- | Executes a code action.
470 -- Matching with the specification, if a code action
471 -- contains both an edit and a command, the edit will
473 executeCodeAction :: CodeAction -> Session ()
474 executeCodeAction action = do
475 maybe (return ()) handleEdit $ action ^. edit
476 maybe (return ()) executeCommand $ action ^. command
478 where handleEdit :: WorkspaceEdit -> Session ()
480 -- Its ok to pass in dummy parameters here as they aren't used
481 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
482 in updateState (ReqApplyWorkspaceEdit req)
484 -- | Adds the current version to the document, as tracked by the session.
485 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
486 getVersionedDoc (TextDocumentIdentifier uri) = do
487 fs <- vfsMap . vfs <$> get
489 case fs Map.!? toNormalizedUri uri of
490 Just vf -> Just (virtualFileVersion vf)
492 return (VersionedTextDocumentIdentifier uri ver)
494 -- | Applys an edit to the document and returns the updated document version.
495 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
496 applyEdit doc edit = do
498 verDoc <- getVersionedDoc doc
500 caps <- asks sessionCapabilities
502 let supportsDocChanges = fromMaybe False $ do
503 let mWorkspace = C._workspace caps
504 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
505 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
508 let wEdit = if supportsDocChanges
510 let docEdit = TextDocumentEdit verDoc (List [edit])
511 in WorkspaceEdit Nothing (Just (List [docEdit]))
513 let changes = HashMap.singleton (doc ^. uri) (List [edit])
514 in WorkspaceEdit (Just changes) Nothing
516 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
517 updateState (ReqApplyWorkspaceEdit req)
519 -- version may have changed
522 -- | Returns the completions for the position in the document.
523 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
524 getCompletions doc pos = do
525 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
527 case getResponseResult rsp of
528 Completions (List items) -> return items
529 CompletionList (CompletionListType _ (List items)) -> return items
531 -- | Returns the references for the position in the document.
532 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
533 -> Position -- ^ The position to lookup.
534 -> Bool -- ^ Whether to include declarations as references.
535 -> Session [Location] -- ^ The locations of the references.
536 getReferences doc pos inclDecl =
537 let ctx = ReferenceContext inclDecl
538 params = ReferenceParams doc pos ctx Nothing
539 in getResponseResult <$> request TextDocumentReferences params
541 -- | Returns the definition(s) for the term at the specified position.
542 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
543 -> Position -- ^ The position the term is at.
544 -> Session [Location] -- ^ The location(s) of the definitions
545 getDefinitions doc pos = do
546 let params = TextDocumentPositionParams doc pos Nothing
547 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
548 case getResponseResult rsp of
549 SingleLoc loc -> pure [loc]
550 MultiLoc locs -> pure locs
552 -- | Returns the type definition(s) for the term at the specified position.
553 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
554 -> Position -- ^ The position the term is at.
555 -> Session [Location] -- ^ The location(s) of the definitions
556 getTypeDefinitions doc pos =
557 let params = TextDocumentPositionParams doc pos Nothing
558 in getResponseResult <$> request TextDocumentTypeDefinition params
560 -- | Renames the term at the specified position.
561 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
562 rename doc pos newName = do
563 let params = RenameParams doc pos (T.pack newName) Nothing
564 rsp <- request TextDocumentRename params :: Session RenameResponse
565 let wEdit = getResponseResult rsp
566 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
567 updateState (ReqApplyWorkspaceEdit req)
569 -- | Returns the hover information at the specified position.
570 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
572 let params = TextDocumentPositionParams doc pos Nothing
573 in getResponseResult <$> request TextDocumentHover params
575 -- | Returns the highlighted occurences of the term at the specified position
576 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
577 getHighlights doc pos =
578 let params = TextDocumentPositionParams doc pos Nothing
579 in getResponseResult <$> request TextDocumentDocumentHighlight params
581 -- | Checks the response for errors and throws an exception if needed.
582 -- Returns the result if successful.
583 getResponseResult :: ResponseMessage a -> a
584 getResponseResult rsp = fromMaybe exc (rsp ^. result)
585 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
586 (fromJust $ rsp ^. LSP.error)
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