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 <- request Initialize initializeParams :: Session InitializeResponse
158 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
160 initRspVar <- initRsp <$> ask
161 liftIO $ putMVar initRspVar initRspMsg
162 sendNotification Initialized InitializedParams
164 case lspConfig config of
165 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
168 -- Run the actual test
171 -- | Asks the server to shutdown and exit politely
172 exitServer :: Session ()
173 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
175 -- | Listens to the server output until the shutdown ack,
176 -- makes sure it matches the record and signals any semaphores
177 listenServer :: Handle -> SessionContext -> IO ()
178 listenServer serverOut context = do
179 msgBytes <- getNextMessage serverOut
181 reqMap <- readMVar $ requestMap context
183 let msg = decodeFromServerMsg reqMap msgBytes
184 writeChan (messageChan context) (ServerMessage msg)
187 (RspShutdown _) -> return ()
188 _ -> listenServer serverOut context
190 -- | Check environment variables to override the config
191 envOverrideConfig :: SessionConfig -> IO SessionConfig
192 envOverrideConfig cfg = do
193 logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
194 logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
195 return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
196 where checkEnv :: String -> IO (Maybe Bool)
197 checkEnv s = fmap convertVal <$> lookupEnv s
198 convertVal "0" = False
201 -- | The current text contents of a document.
202 documentContents :: TextDocumentIdentifier -> Session T.Text
203 documentContents doc = do
205 let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
206 return (virtualFileText file)
208 -- | Parses an ApplyEditRequest, checks that it is for the passed document
209 -- and returns the new content
210 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
211 getDocumentEdit doc = do
212 req <- message :: Session ApplyWorkspaceEditRequest
214 unless (checkDocumentChanges req || checkChanges req) $
215 liftIO $ throw (IncorrectApplyEditRequest (show req))
219 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
220 checkDocumentChanges req =
221 let changes = req ^. params . edit . documentChanges
222 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
224 Just docs -> (doc ^. uri) `elem` docs
226 checkChanges :: ApplyWorkspaceEditRequest -> Bool
228 let mMap = req ^. params . edit . changes
229 in maybe False (HashMap.member (doc ^. uri)) mMap
231 -- | Sends a request to the server and waits for its response.
232 -- Will skip any messages in between the request and the response
234 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
236 -- Note: will skip any messages in between the request and the response.
237 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
238 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
240 -- | The same as 'sendRequest', but discard the response.
241 request_ :: ToJSON params => ClientMethod -> params -> Session ()
242 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
244 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
247 => ClientMethod -- ^ The request method.
248 -> params -- ^ The request parameters.
249 -> Session LspId -- ^ The id of the request that was sent.
250 sendRequest method params = do
251 id <- curReqId <$> get
252 modify $ \c -> c { curReqId = nextId id }
254 let req = RequestMessage' "2.0" id method params
256 -- Update the request map
257 reqMap <- requestMap <$> ask
258 liftIO $ modifyMVar_ reqMap $
259 \r -> return $ updateRequestMap r id method
265 where nextId (IdInt i) = IdInt (i + 1)
266 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
268 -- | A custom type for request message that doesn't
269 -- need a response type, allows us to infer the request
270 -- message type without using proxies.
271 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
273 instance ToJSON a => ToJSON (RequestMessage' a) where
274 toJSON (RequestMessage' rpc id method params) =
275 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
278 -- | Sends a notification to the server.
279 sendNotification :: ToJSON a
280 => ClientMethod -- ^ The notification method.
281 -> a -- ^ The notification parameters.
284 -- Open a virtual file if we send a did open text document notification
285 sendNotification TextDocumentDidOpen params = do
286 let params' = fromJust $ decode $ encode params
287 n :: DidOpenTextDocumentNotification
288 n = NotificationMessage "2.0" TextDocumentDidOpen params'
289 oldVFS <- vfs <$> get
290 let (newVFS,_) = openVFS oldVFS n
291 modify (\s -> s { vfs = newVFS })
294 -- Close a virtual file if we send a close text document notification
295 sendNotification TextDocumentDidClose params = do
296 let params' = fromJust $ decode $ encode params
297 n :: DidCloseTextDocumentNotification
298 n = NotificationMessage "2.0" TextDocumentDidClose params'
299 oldVFS <- vfs <$> get
300 let (newVFS,_) = closeVFS oldVFS n
301 modify (\s -> s { vfs = newVFS })
304 sendNotification TextDocumentDidChange params = do
305 let params' = fromJust $ decode $ encode params
306 n :: DidChangeTextDocumentNotification
307 n = NotificationMessage "2.0" TextDocumentDidChange params'
308 oldVFS <- vfs <$> get
309 let (newVFS,_) = changeFromClientVFS oldVFS n
310 modify (\s -> s { vfs = newVFS })
313 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
315 -- | Sends a response to the server.
316 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
317 sendResponse = sendMessage
319 -- | Returns the initialize response that was received from the server.
320 -- The initialize requests and responses are not included the session,
321 -- so if you need to test it use this.
322 initializeResponse :: Session InitializeResponse
323 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
325 -- | Opens a text document and sends a notification to the client.
326 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
327 openDoc file languageId = do
329 let fp = rootDir context </> file
330 contents <- liftIO $ T.readFile fp
331 openDoc' file languageId contents
333 -- | This is a variant of `openDoc` that takes the file content as an argument.
334 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
335 openDoc' file languageId contents = do
337 let fp = rootDir context </> file
338 uri = filePathToUri fp
339 item = TextDocumentItem uri (T.pack languageId) 0 contents
340 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
341 pure $ TextDocumentIdentifier uri
343 -- | Closes a text document and sends a notification to the client.
344 closeDoc :: TextDocumentIdentifier -> Session ()
346 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
347 sendNotification TextDocumentDidClose params
349 -- | Changes a text document and sends a notification to the client
350 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
351 changeDoc docId changes = do
352 verDoc <- getVersionedDoc docId
353 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
354 sendNotification TextDocumentDidChange params
356 -- | Gets the Uri for the file corrected to the session directory.
357 getDocUri :: FilePath -> Session Uri
360 let fp = rootDir context </> file
361 return $ filePathToUri fp
363 -- | Waits for diagnostics to be published and returns them.
364 waitForDiagnostics :: Session [Diagnostic]
365 waitForDiagnostics = do
366 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
367 let (List diags) = diagsNot ^. params . LSP.diagnostics
370 -- | The same as 'waitForDiagnostics', but will only match a specific
371 -- 'Language.Haskell.LSP.Types._source'.
372 waitForDiagnosticsSource :: String -> Session [Diagnostic]
373 waitForDiagnosticsSource src = do
374 diags <- waitForDiagnostics
375 let res = filter matches diags
377 then waitForDiagnosticsSource src
380 matches :: Diagnostic -> Bool
381 matches d = d ^. source == Just (T.pack src)
383 -- | Expects a 'PublishDiagnosticsNotification' and throws an
384 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
386 noDiagnostics :: Session ()
388 diagsNot <- message :: Session PublishDiagnosticsNotification
389 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
391 -- | Returns the symbols in a document.
392 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
393 getDocumentSymbols doc = do
394 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
395 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
397 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
398 Just (DSSymbolInformation (List xs)) -> return (Right xs)
399 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
401 -- | Returns the code actions in the specified range.
402 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
403 getCodeActions doc range = do
404 ctx <- getCodeActionContext doc
405 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
407 case rsp ^. result of
408 Just (List xs) -> return xs
409 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
411 -- | Returns all the code actions in a document by
412 -- querying the code actions at each of the current
413 -- diagnostics' positions.
414 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
415 getAllCodeActions doc = do
416 ctx <- getCodeActionContext doc
418 foldM (go ctx) [] =<< getCurrentDiagnostics doc
421 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
423 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
426 Just e -> throw (UnexpectedResponseError rspLid e)
428 let Just (List cmdOrCAs) = mRes
429 in return (acc ++ cmdOrCAs)
431 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
432 getCodeActionContext doc = do
433 curDiags <- getCurrentDiagnostics doc
434 return $ CodeActionContext (List curDiags) Nothing
436 -- | Returns the current diagnostics that have been sent to the client.
437 -- Note that this does not wait for more to come in.
438 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
439 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
441 -- | Executes a command.
442 executeCommand :: Command -> Session ()
443 executeCommand cmd = do
444 let args = decode $ encode $ fromJust $ cmd ^. arguments
445 execParams = ExecuteCommandParams (cmd ^. command) args Nothing
446 request_ WorkspaceExecuteCommand execParams
448 -- | Executes a code action.
449 -- Matching with the specification, if a code action
450 -- contains both an edit and a command, the edit will
452 executeCodeAction :: CodeAction -> Session ()
453 executeCodeAction action = do
454 maybe (return ()) handleEdit $ action ^. edit
455 maybe (return ()) executeCommand $ action ^. command
457 where handleEdit :: WorkspaceEdit -> Session ()
459 -- Its ok to pass in dummy parameters here as they aren't used
460 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
461 in updateState (ReqApplyWorkspaceEdit req)
463 -- | Adds the current version to the document, as tracked by the session.
464 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
465 getVersionedDoc (TextDocumentIdentifier uri) = do
466 fs <- vfsMap . vfs <$> get
468 case fs Map.!? toNormalizedUri uri of
469 Just vf -> Just (virtualFileVersion vf)
471 return (VersionedTextDocumentIdentifier uri ver)
473 -- | Applys an edit to the document and returns the updated document version.
474 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
475 applyEdit doc edit = do
477 verDoc <- getVersionedDoc doc
479 caps <- asks sessionCapabilities
481 let supportsDocChanges = fromMaybe False $ do
482 let mWorkspace = C._workspace caps
483 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
484 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
487 let wEdit = if supportsDocChanges
489 let docEdit = TextDocumentEdit verDoc (List [edit])
490 in WorkspaceEdit Nothing (Just (List [docEdit]))
492 let changes = HashMap.singleton (doc ^. uri) (List [edit])
493 in WorkspaceEdit (Just changes) Nothing
495 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
496 updateState (ReqApplyWorkspaceEdit req)
498 -- version may have changed
501 -- | Returns the completions for the position in the document.
502 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
503 getCompletions doc pos = do
504 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
506 case getResponseResult rsp of
507 Completions (List items) -> return items
508 CompletionList (CompletionListType _ (List items)) -> return items
510 -- | Returns the references for the position in the document.
511 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
512 -> Position -- ^ The position to lookup.
513 -> Bool -- ^ Whether to include declarations as references.
514 -> Session [Location] -- ^ The locations of the references.
515 getReferences doc pos inclDecl =
516 let ctx = ReferenceContext inclDecl
517 params = ReferenceParams doc pos ctx Nothing
518 in getResponseResult <$> request TextDocumentReferences params
520 -- | Returns the definition(s) for the term at the specified position.
521 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
522 -> Position -- ^ The position the term is at.
523 -> Session [Location] -- ^ The location(s) of the definitions
524 getDefinitions doc pos = do
525 let params = TextDocumentPositionParams doc pos Nothing
526 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
527 case getResponseResult rsp of
528 SingleLoc loc -> pure [loc]
529 MultiLoc locs -> pure locs
531 -- | Returns the type definition(s) for the term at the specified position.
532 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
533 -> Position -- ^ The position the term is at.
534 -> Session [Location] -- ^ The location(s) of the definitions
535 getTypeDefinitions doc pos =
536 let params = TextDocumentPositionParams doc pos Nothing
537 in getResponseResult <$> request TextDocumentTypeDefinition params
539 -- | Renames the term at the specified position.
540 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
541 rename doc pos newName = do
542 let params = RenameParams doc pos (T.pack newName) Nothing
543 rsp <- request TextDocumentRename params :: Session RenameResponse
544 let wEdit = getResponseResult rsp
545 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
546 updateState (ReqApplyWorkspaceEdit req)
548 -- | Returns the hover information at the specified position.
549 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
551 let params = TextDocumentPositionParams doc pos Nothing
552 in getResponseResult <$> request TextDocumentHover params
554 -- | Returns the highlighted occurences of the term at the specified position
555 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
556 getHighlights doc pos =
557 let params = TextDocumentPositionParams doc pos Nothing
558 in getResponseResult <$> request TextDocumentDocumentHighlight params
560 -- | Checks the response for errors and throws an exception if needed.
561 -- Returns the result if successful.
562 getResponseResult :: ResponseMessage a -> a
563 getResponseResult rsp = fromMaybe exc (rsp ^. result)
564 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
565 (fromJust $ rsp ^. LSP.error)
567 -- | Applies formatting to the specified document.
568 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
569 formatDoc doc opts = do
570 let params = DocumentFormattingParams doc opts Nothing
571 edits <- getResponseResult <$> request TextDocumentFormatting params
572 applyTextEdits doc edits
574 -- | Applies formatting to the specified range in a document.
575 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
576 formatRange doc opts range = do
577 let params = DocumentRangeFormattingParams doc range opts Nothing
578 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
579 applyTextEdits doc edits
581 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
582 applyTextEdits doc edits =
583 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
584 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
585 in updateState (ReqApplyWorkspaceEdit req)
587 -- | Returns the code lenses for the specified document.
588 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
589 getCodeLenses tId = do
590 rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
591 case getResponseResult rsp of