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
117 import qualified Data.Rope.UTF16 as Rope
119 -- | Starts a new session.
121 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
122 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
123 -- > diags <- waitForDiagnostics
124 -- > let pos = Position 12 5
125 -- > params = TextDocumentPositionParams doc
126 -- > hover <- request TextDocumentHover params
127 runSession :: String -- ^ The command to run the server.
128 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
129 -> FilePath -- ^ The filepath to the root directory for the session.
130 -> Session a -- ^ The session to run.
132 runSession = runSessionWithConfig def
134 -- | Starts a new sesion with a custom configuration.
135 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
136 -> String -- ^ The command to run the server.
137 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
138 -> FilePath -- ^ The filepath to the root directory for the session.
139 -> Session a -- ^ The session to run.
141 runSessionWithConfig config' serverExe caps rootDir session = do
142 pid <- getCurrentProcessID
143 absRootDir <- canonicalizePath rootDir
145 config <- envOverrideConfig config'
147 let initializeParams = InitializeParams (Just pid)
148 (Just $ T.pack absRootDir)
149 (Just $ filePathToUri absRootDir)
154 withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
155 runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ 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
163 sendNotification Initialized InitializedParams
165 case lspConfig config of
166 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
169 -- Run the actual test
172 -- | Asks the server to shutdown and exit politely
173 exitServer :: Session ()
174 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
176 -- | Listens to the server output until the shutdown ack,
177 -- makes sure it matches the record and signals any semaphores
178 listenServer :: Handle -> SessionContext -> IO ()
179 listenServer serverOut context = do
180 msgBytes <- getNextMessage serverOut
182 reqMap <- readMVar $ requestMap context
184 let msg = decodeFromServerMsg reqMap msgBytes
185 writeChan (messageChan context) (ServerMessage msg)
188 (RspShutdown _) -> return ()
189 _ -> listenServer serverOut context
191 -- | Check environment variables to override the config
192 envOverrideConfig :: SessionConfig -> IO SessionConfig
193 envOverrideConfig cfg = do
194 logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
195 logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
196 return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
197 where checkEnv :: String -> IO (Maybe Bool)
198 checkEnv s = fmap convertVal <$> lookupEnv s
199 convertVal "0" = False
202 -- | The current text contents of a document.
203 documentContents :: TextDocumentIdentifier -> Session T.Text
204 documentContents doc = do
206 let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
207 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
209 -- | Parses an ApplyEditRequest, checks that it is for the passed document
210 -- and returns the new content
211 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
212 getDocumentEdit doc = do
213 req <- message :: Session ApplyWorkspaceEditRequest
215 unless (checkDocumentChanges req || checkChanges req) $
216 liftIO $ throw (IncorrectApplyEditRequest (show req))
220 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
221 checkDocumentChanges req =
222 let changes = req ^. params . edit . documentChanges
223 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
225 Just docs -> (doc ^. uri) `elem` docs
227 checkChanges :: ApplyWorkspaceEditRequest -> Bool
229 let mMap = req ^. params . edit . changes
230 in maybe False (HashMap.member (doc ^. uri)) mMap
232 -- | Sends a request to the server and waits for its response.
233 -- Will skip any messages in between the request and the response
235 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
237 -- Note: will skip any messages in between the request and the response.
238 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
239 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
241 -- | The same as 'sendRequest', but discard the response.
242 request_ :: ToJSON params => ClientMethod -> params -> Session ()
243 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
245 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
248 => ClientMethod -- ^ The request method.
249 -> params -- ^ The request parameters.
250 -> Session LspId -- ^ The id of the request that was sent.
251 sendRequest method params = do
252 id <- curReqId <$> get
253 modify $ \c -> c { curReqId = nextId id }
255 let req = RequestMessage' "2.0" id method params
257 -- Update the request map
258 reqMap <- requestMap <$> ask
259 liftIO $ modifyMVar_ reqMap $
260 \r -> return $ updateRequestMap r id method
266 where nextId (IdInt i) = IdInt (i + 1)
267 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
269 -- | A custom type for request message that doesn't
270 -- need a response type, allows us to infer the request
271 -- message type without using proxies.
272 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
274 instance ToJSON a => ToJSON (RequestMessage' a) where
275 toJSON (RequestMessage' rpc id method params) =
276 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
279 -- | Sends a notification to the server.
280 sendNotification :: ToJSON a
281 => ClientMethod -- ^ The notification method.
282 -> a -- ^ The notification parameters.
285 -- Open a virtual file if we send a did open text document notification
286 sendNotification TextDocumentDidOpen params = do
287 let params' = fromJust $ decode $ encode params
288 n :: DidOpenTextDocumentNotification
289 n = NotificationMessage "2.0" TextDocumentDidOpen params'
290 oldVFS <- vfs <$> get
291 let (newVFS,_) = openVFS oldVFS n
292 modify (\s -> s { vfs = newVFS })
295 -- Close a virtual file if we send a close text document notification
296 sendNotification TextDocumentDidClose params = do
297 let params' = fromJust $ decode $ encode params
298 n :: DidCloseTextDocumentNotification
299 n = NotificationMessage "2.0" TextDocumentDidClose params'
300 oldVFS <- vfs <$> get
301 let (newVFS,_) = closeVFS oldVFS n
302 modify (\s -> s { vfs = newVFS })
305 sendNotification TextDocumentDidChange params = do
306 let params' = fromJust $ decode $ encode params
307 n :: DidChangeTextDocumentNotification
308 n = NotificationMessage "2.0" TextDocumentDidChange params'
309 oldVFS <- vfs <$> get
310 let (newVFS,_) = changeFromClientVFS oldVFS n
311 modify (\s -> s { vfs = newVFS })
314 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
316 -- | Sends a response to the server.
317 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
318 sendResponse = sendMessage
320 -- | Returns the initialize response that was received from the server.
321 -- The initialize requests and responses are not included the session,
322 -- so if you need to test it use this.
323 initializeResponse :: Session InitializeResponse
324 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
326 -- | Opens a text document and sends a notification to the client.
327 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
328 openDoc file languageId = do
330 let fp = rootDir context </> file
331 contents <- liftIO $ T.readFile fp
332 openDoc' file languageId contents
334 -- | This is a variant of `openDoc` that takes the file content as an argument.
335 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
336 openDoc' file languageId contents = do
338 let fp = rootDir context </> file
339 uri = filePathToUri fp
340 item = TextDocumentItem uri (T.pack languageId) 0 contents
341 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
342 pure $ TextDocumentIdentifier uri
344 -- | Closes a text document and sends a notification to the client.
345 closeDoc :: TextDocumentIdentifier -> Session ()
347 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
348 sendNotification TextDocumentDidClose params
350 -- | Changes a text document and sends a notification to the client
351 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
352 changeDoc docId changes = do
353 verDoc <- getVersionedDoc docId
354 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
355 sendNotification TextDocumentDidChange params
357 -- | Gets the Uri for the file corrected to the session directory.
358 getDocUri :: FilePath -> Session Uri
361 let fp = rootDir context </> file
362 return $ filePathToUri fp
364 -- | Waits for diagnostics to be published and returns them.
365 waitForDiagnostics :: Session [Diagnostic]
366 waitForDiagnostics = do
367 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
368 let (List diags) = diagsNot ^. params . LSP.diagnostics
371 -- | The same as 'waitForDiagnostics', but will only match a specific
372 -- 'Language.Haskell.LSP.Types._source'.
373 waitForDiagnosticsSource :: String -> Session [Diagnostic]
374 waitForDiagnosticsSource src = do
375 diags <- waitForDiagnostics
376 let res = filter matches diags
378 then waitForDiagnosticsSource src
381 matches :: Diagnostic -> Bool
382 matches d = d ^. source == Just (T.pack src)
384 -- | Expects a 'PublishDiagnosticsNotification' and throws an
385 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
387 noDiagnostics :: Session ()
389 diagsNot <- message :: Session PublishDiagnosticsNotification
390 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
392 -- | Returns the symbols in a document.
393 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
394 getDocumentSymbols doc = do
395 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
396 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
398 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
399 Just (DSSymbolInformation (List xs)) -> return (Right xs)
400 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
402 -- | Returns the code actions in the specified range.
403 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
404 getCodeActions doc range = do
405 ctx <- getCodeActionContext doc
406 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
408 case rsp ^. result of
409 Just (List xs) -> return xs
410 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
412 -- | Returns all the code actions in a document by
413 -- querying the code actions at each of the current
414 -- diagnostics' positions.
415 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
416 getAllCodeActions doc = do
417 ctx <- getCodeActionContext doc
419 foldM (go ctx) [] =<< getCurrentDiagnostics doc
422 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
424 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
427 Just e -> throw (UnexpectedResponseError rspLid e)
429 let Just (List cmdOrCAs) = mRes
430 in return (acc ++ cmdOrCAs)
432 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
433 getCodeActionContext doc = do
434 curDiags <- getCurrentDiagnostics doc
435 return $ CodeActionContext (List curDiags) Nothing
437 -- | Returns the current diagnostics that have been sent to the client.
438 -- Note that this does not wait for more to come in.
439 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
440 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
442 -- | Executes a command.
443 executeCommand :: Command -> Session ()
444 executeCommand cmd = do
445 let args = decode $ encode $ fromJust $ cmd ^. arguments
446 execParams = ExecuteCommandParams (cmd ^. command) args Nothing
447 request_ WorkspaceExecuteCommand execParams
449 -- | Executes a code action.
450 -- Matching with the specification, if a code action
451 -- contains both an edit and a command, the edit will
453 executeCodeAction :: CodeAction -> Session ()
454 executeCodeAction action = do
455 maybe (return ()) handleEdit $ action ^. edit
456 maybe (return ()) executeCommand $ action ^. command
458 where handleEdit :: WorkspaceEdit -> Session ()
460 -- Its ok to pass in dummy parameters here as they aren't used
461 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
462 in updateState (ReqApplyWorkspaceEdit req)
464 -- | Adds the current version to the document, as tracked by the session.
465 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
466 getVersionedDoc (TextDocumentIdentifier uri) = do
467 fs <- vfsMap . vfs <$> get
469 case fs Map.!? toNormalizedUri uri of
470 Just vf -> Just (virtualFileVersion vf)
472 return (VersionedTextDocumentIdentifier uri ver)
474 -- | Applys an edit to the document and returns the updated document version.
475 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
476 applyEdit doc edit = do
478 verDoc <- getVersionedDoc doc
480 caps <- asks sessionCapabilities
482 let supportsDocChanges = fromMaybe False $ do
483 let mWorkspace = C._workspace caps
484 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
485 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
488 let wEdit = if supportsDocChanges
490 let docEdit = TextDocumentEdit verDoc (List [edit])
491 in WorkspaceEdit Nothing (Just (List [docEdit]))
493 let changes = HashMap.singleton (doc ^. uri) (List [edit])
494 in WorkspaceEdit (Just changes) Nothing
496 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
497 updateState (ReqApplyWorkspaceEdit req)
499 -- version may have changed
502 -- | Returns the completions for the position in the document.
503 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
504 getCompletions doc pos = do
505 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
507 case getResponseResult rsp of
508 Completions (List items) -> return items
509 CompletionList (CompletionListType _ (List items)) -> return items
511 -- | Returns the references for the position in the document.
512 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
513 -> Position -- ^ The position to lookup.
514 -> Bool -- ^ Whether to include declarations as references.
515 -> Session [Location] -- ^ The locations of the references.
516 getReferences doc pos inclDecl =
517 let ctx = ReferenceContext inclDecl
518 params = ReferenceParams doc pos ctx Nothing
519 in getResponseResult <$> request TextDocumentReferences params
521 -- | Returns the definition(s) for the term at the specified position.
522 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
523 -> Position -- ^ The position the term is at.
524 -> Session [Location] -- ^ The location(s) of the definitions
525 getDefinitions doc pos = do
526 let params = TextDocumentPositionParams doc pos Nothing
527 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
528 case getResponseResult rsp of
529 SingleLoc loc -> pure [loc]
530 MultiLoc locs -> pure locs
532 -- | Returns the type definition(s) for the term at the specified position.
533 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
534 -> Position -- ^ The position the term is at.
535 -> Session [Location] -- ^ The location(s) of the definitions
536 getTypeDefinitions doc pos =
537 let params = TextDocumentPositionParams doc pos Nothing
538 in getResponseResult <$> request TextDocumentTypeDefinition params
540 -- | Renames the term at the specified position.
541 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
542 rename doc pos newName = do
543 let params = RenameParams doc pos (T.pack newName) Nothing
544 rsp <- request TextDocumentRename params :: Session RenameResponse
545 let wEdit = getResponseResult rsp
546 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
547 updateState (ReqApplyWorkspaceEdit req)
549 -- | Returns the hover information at the specified position.
550 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
552 let params = TextDocumentPositionParams doc pos Nothing
553 in getResponseResult <$> request TextDocumentHover params
555 -- | Returns the highlighted occurences of the term at the specified position
556 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
557 getHighlights doc pos =
558 let params = TextDocumentPositionParams doc pos Nothing
559 in getResponseResult <$> request TextDocumentDocumentHighlight params
561 -- | Checks the response for errors and throws an exception if needed.
562 -- Returns the result if successful.
563 getResponseResult :: ResponseMessage a -> a
564 getResponseResult rsp = fromMaybe exc (rsp ^. result)
565 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
566 (fromJust $ rsp ^. LSP.error)
568 -- | Applies formatting to the specified document.
569 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
570 formatDoc doc opts = do
571 let params = DocumentFormattingParams doc opts Nothing
572 edits <- getResponseResult <$> request TextDocumentFormatting params
573 applyTextEdits doc edits
575 -- | Applies formatting to the specified range in a document.
576 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
577 formatRange doc opts range = do
578 let params = DocumentRangeFormattingParams doc range opts Nothing
579 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
580 applyTextEdits doc edits
582 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
583 applyTextEdits doc edits =
584 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
585 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
586 in updateState (ReqApplyWorkspaceEdit req)
588 -- | Returns the code lenses for the specified document.
589 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
590 getCodeLenses tId = do
591 rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
592 case getResponseResult rsp of