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
84 import Control.Applicative.Combinators
85 import Control.Concurrent
87 import Control.Monad.IO.Class
88 import Control.Exception
89 import Control.Lens hiding ((.=), List)
90 import qualified Data.Text as T
91 import qualified Data.Text.IO as T
94 import qualified Data.HashMap.Strict as HashMap
96 import qualified Data.Map as Map
98 import Language.Haskell.LSP.Types
99 import Language.Haskell.LSP.Types.Lens hiding
100 (id, capabilities, message, executeCommand, applyEdit, rename)
101 import qualified Language.Haskell.LSP.Types.Lens as LSP
102 import qualified Language.Haskell.LSP.Types.Capabilities as C
103 import Language.Haskell.LSP.Messages
104 import Language.Haskell.LSP.VFS
105 import Language.Haskell.LSP.Test.Compat
106 import Language.Haskell.LSP.Test.Decoding
107 import Language.Haskell.LSP.Test.Exceptions
108 import Language.Haskell.LSP.Test.Parsing
109 import Language.Haskell.LSP.Test.Session
110 import Language.Haskell.LSP.Test.Server
112 import System.Directory
113 import System.FilePath
114 import qualified Data.Rope.UTF16 as Rope
116 -- | Starts a new session.
118 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
119 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
120 -- > diags <- waitForDiagnostics
121 -- > let pos = Position 12 5
122 -- > params = TextDocumentPositionParams doc
123 -- > hover <- request TextDocumentHover params
124 runSession :: String -- ^ The command to run the server.
125 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
126 -> FilePath -- ^ The filepath to the root directory for the session.
127 -> Session a -- ^ The session to run.
129 runSession = runSessionWithConfig def
131 -- | Starts a new sesion with a custom configuration.
132 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
133 -> String -- ^ The command to run the server.
134 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
135 -> FilePath -- ^ The filepath to the root directory for the session.
136 -> Session a -- ^ The session to run.
138 runSessionWithConfig config serverExe caps rootDir session = do
139 -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.
140 exitOk <- newIORef False
141 pid <- getCurrentProcessID
142 absRootDir <- canonicalizePath rootDir
144 let initializeParams = InitializeParams (Just pid)
145 (Just $ T.pack absRootDir)
146 (Just $ filePathToUri absRootDir)
151 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
152 runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do
154 -- Wrap the session around initialize and shutdown calls
155 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
157 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
159 initRspVar <- initRsp <$> ask
160 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 liftIO $ atomicWriteIORef exitOk True
172 sendNotification Exit ExitParams
176 catchWhenTrue :: IORef Bool -> IO () -> IO ()
177 catchWhenTrue exitOk a =
179 x <- readIORef exitOk
180 unless x $ throw (e :: SomeException))
182 -- | Listens to the server output, makes sure it matches the record and
183 -- signals any semaphores
184 -- Note that on Windows, we cannot kill a thread stuck in getNextMessage.
185 -- So we have to wait for the exit notification to kill the process first
186 -- and then getNextMessage will fail.
187 listenServer :: Handle -> SessionContext -> IO ()
188 listenServer serverOut context = do
189 msgBytes <- getNextMessage serverOut
191 reqMap <- readMVar $ requestMap context
193 let msg = decodeFromServerMsg reqMap msgBytes
194 writeChan (messageChan context) (ServerMessage msg)
196 listenServer serverOut context
198 -- | The current text contents of a document.
199 documentContents :: TextDocumentIdentifier -> Session T.Text
200 documentContents doc = do
202 let file = vfs Map.! (doc ^. uri)
203 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
205 -- | Parses an ApplyEditRequest, checks that it is for the passed document
206 -- and returns the new content
207 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
208 getDocumentEdit doc = do
209 req <- message :: Session ApplyWorkspaceEditRequest
211 unless (checkDocumentChanges req || checkChanges req) $
212 liftIO $ throw (IncorrectApplyEditRequest (show req))
216 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
217 checkDocumentChanges req =
218 let changes = req ^. params . edit . documentChanges
219 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
221 Just docs -> (doc ^. uri) `elem` docs
223 checkChanges :: ApplyWorkspaceEditRequest -> Bool
225 let mMap = req ^. params . edit . changes
226 in maybe False (HashMap.member (doc ^. uri)) mMap
228 -- | Sends a request to the server and waits for its response.
229 -- Will skip any messages in between the request and the response
231 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
233 -- Note: will skip any messages in between the request and the response.
234 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
235 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
237 -- | The same as 'sendRequest', but discard the response.
238 request_ :: ToJSON params => ClientMethod -> params -> Session ()
239 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
241 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
244 => ClientMethod -- ^ The request method.
245 -> params -- ^ The request parameters.
246 -> Session LspId -- ^ The id of the request that was sent.
247 sendRequest method params = do
248 id <- curReqId <$> get
249 modify $ \c -> c { curReqId = nextId id }
251 let req = RequestMessage' "2.0" id method params
253 -- Update the request map
254 reqMap <- requestMap <$> ask
255 liftIO $ modifyMVar_ reqMap $
256 \r -> return $ updateRequestMap r id method
262 where nextId (IdInt i) = IdInt (i + 1)
263 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
265 -- | A custom type for request message that doesn't
266 -- need a response type, allows us to infer the request
267 -- message type without using proxies.
268 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
270 instance ToJSON a => ToJSON (RequestMessage' a) where
271 toJSON (RequestMessage' rpc id method params) =
272 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
275 -- | Sends a notification to the server.
276 sendNotification :: ToJSON a
277 => ClientMethod -- ^ The notification method.
278 -> a -- ^ The notification parameters.
281 -- Open a virtual file if we send a did open text document notification
282 sendNotification TextDocumentDidOpen params = do
283 let params' = fromJust $ decode $ encode params
284 n :: DidOpenTextDocumentNotification
285 n = NotificationMessage "2.0" TextDocumentDidOpen params'
286 oldVFS <- vfs <$> get
287 newVFS <- liftIO $ openVFS oldVFS n
288 modify (\s -> s { vfs = newVFS })
291 -- Close a virtual file if we send a close text document notification
292 sendNotification TextDocumentDidClose params = do
293 let params' = fromJust $ decode $ encode params
294 n :: DidCloseTextDocumentNotification
295 n = NotificationMessage "2.0" TextDocumentDidClose params'
296 oldVFS <- vfs <$> get
297 newVFS <- liftIO $ closeVFS oldVFS n
298 modify (\s -> s { vfs = newVFS })
301 sendNotification TextDocumentDidChange params = do
302 let params' = fromJust $ decode $ encode params
303 n :: DidChangeTextDocumentNotification
304 n = NotificationMessage "2.0" TextDocumentDidChange params'
305 oldVFS <- vfs <$> get
306 newVFS <- liftIO $ changeFromClientVFS oldVFS n
307 modify (\s -> s { vfs = newVFS })
310 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
312 -- | Sends a response to the server.
313 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
314 sendResponse = sendMessage
316 -- | Returns the initialize response that was received from the server.
317 -- The initialize requests and responses are not included the session,
318 -- so if you need to test it use this.
319 initializeResponse :: Session InitializeResponse
320 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
322 -- | Opens a text document and sends a notification to the client.
323 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
324 openDoc file languageId = do
326 let fp = rootDir context </> file
327 contents <- liftIO $ T.readFile fp
328 openDoc' file languageId contents
330 -- | This is a variant of `openDoc` that takes the file content as an argument.
331 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
332 openDoc' file languageId contents = do
334 let fp = rootDir context </> file
335 uri = filePathToUri fp
336 item = TextDocumentItem uri (T.pack languageId) 0 contents
337 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
338 pure $ TextDocumentIdentifier uri
340 -- | Closes a text document and sends a notification to the client.
341 closeDoc :: TextDocumentIdentifier -> Session ()
343 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
344 sendNotification TextDocumentDidClose params
346 -- | Changes a text document and sends a notification to the client
347 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
348 changeDoc docId changes = do
349 verDoc <- getVersionedDoc docId
350 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
351 sendNotification TextDocumentDidChange params
353 -- | Gets the Uri for the file corrected to the session directory.
354 getDocUri :: FilePath -> Session Uri
357 let fp = rootDir context </> file
358 return $ filePathToUri fp
360 -- | Waits for diagnostics to be published and returns them.
361 waitForDiagnostics :: Session [Diagnostic]
362 waitForDiagnostics = do
363 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
364 let (List diags) = diagsNot ^. params . LSP.diagnostics
367 -- | The same as 'waitForDiagnostics', but will only match a specific
368 -- 'Language.Haskell.LSP.Types._source'.
369 waitForDiagnosticsSource :: String -> Session [Diagnostic]
370 waitForDiagnosticsSource src = do
371 diags <- waitForDiagnostics
372 let res = filter matches diags
374 then waitForDiagnosticsSource src
377 matches :: Diagnostic -> Bool
378 matches d = d ^. source == Just (T.pack src)
380 -- | Expects a 'PublishDiagnosticsNotification' and throws an
381 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
383 noDiagnostics :: Session ()
385 diagsNot <- message :: Session PublishDiagnosticsNotification
386 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
388 -- | Returns the symbols in a document.
389 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
390 getDocumentSymbols doc = do
391 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
392 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
394 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
395 Just (DSSymbolInformation (List xs)) -> return (Right xs)
396 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
398 -- | Returns the code actions in the specified range.
399 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
400 getCodeActions doc range = do
401 ctx <- getCodeActionContext doc
402 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
404 case rsp ^. result of
405 Just (List xs) -> return xs
406 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
408 -- | Returns all the code actions in a document by
409 -- querying the code actions at each of the current
410 -- diagnostics' positions.
411 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
412 getAllCodeActions doc = do
413 ctx <- getCodeActionContext doc
415 foldM (go ctx) [] =<< getCurrentDiagnostics doc
418 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
420 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
423 Just e -> throw (UnexpectedResponseError rspLid e)
425 let Just (List cmdOrCAs) = mRes
426 in return (acc ++ cmdOrCAs)
428 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
429 getCodeActionContext doc = do
430 curDiags <- getCurrentDiagnostics doc
431 return $ CodeActionContext (List curDiags) Nothing
433 -- | Returns the current diagnostics that have been sent to the client.
434 -- Note that this does not wait for more to come in.
435 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
436 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
438 -- | Executes a command.
439 executeCommand :: Command -> Session ()
440 executeCommand cmd = do
441 let args = decode $ encode $ fromJust $ cmd ^. arguments
442 execParams = ExecuteCommandParams (cmd ^. command) args
443 request_ WorkspaceExecuteCommand execParams
445 -- | Executes a code action.
446 -- Matching with the specification, if a code action
447 -- contains both an edit and a command, the edit will
449 executeCodeAction :: CodeAction -> Session ()
450 executeCodeAction action = do
451 maybe (return ()) handleEdit $ action ^. edit
452 maybe (return ()) executeCommand $ action ^. command
454 where handleEdit :: WorkspaceEdit -> Session ()
456 -- Its ok to pass in dummy parameters here as they aren't used
457 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
458 in updateState (ReqApplyWorkspaceEdit req)
460 -- | Adds the current version to the document, as tracked by the session.
461 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
462 getVersionedDoc (TextDocumentIdentifier uri) = do
465 case fs Map.!? uri of
466 Just (VirtualFile v _ _) -> Just v
468 return (VersionedTextDocumentIdentifier uri ver)
470 -- | Applys an edit to the document and returns the updated document version.
471 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
472 applyEdit doc edit = do
474 verDoc <- getVersionedDoc doc
476 caps <- asks sessionCapabilities
478 let supportsDocChanges = fromMaybe False $ do
479 let mWorkspace = C._workspace caps
480 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
481 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
484 let wEdit = if supportsDocChanges
486 let docEdit = TextDocumentEdit verDoc (List [edit])
487 in WorkspaceEdit Nothing (Just (List [docEdit]))
489 let changes = HashMap.singleton (doc ^. uri) (List [edit])
490 in WorkspaceEdit (Just changes) Nothing
492 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
493 updateState (ReqApplyWorkspaceEdit req)
495 -- version may have changed
498 -- | Returns the completions for the position in the document.
499 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
500 getCompletions doc pos = do
501 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
503 case getResponseResult rsp of
504 Completions (List items) -> return items
505 CompletionList (CompletionListType _ (List items)) -> return items
507 -- | Returns the references for the position in the document.
508 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
509 -> Position -- ^ The position to lookup.
510 -> Bool -- ^ Whether to include declarations as references.
511 -> Session [Location] -- ^ The locations of the references.
512 getReferences doc pos inclDecl =
513 let ctx = ReferenceContext inclDecl
514 params = ReferenceParams doc pos ctx
515 in getResponseResult <$> request TextDocumentReferences params
517 -- | Returns the definition(s) for the term at the specified position.
518 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
519 -> Position -- ^ The position the term is at.
520 -> Session [Location] -- ^ The location(s) of the definitions
521 getDefinitions doc pos =
522 let params = TextDocumentPositionParams doc pos
523 in getResponseResult <$> request TextDocumentDefinition params
525 -- | Returns the type definition(s) for the term at the specified position.
526 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
527 -> Position -- ^ The position the term is at.
528 -> Session [Location] -- ^ The location(s) of the definitions
529 getTypeDefinitions doc pos =
530 let params = TextDocumentPositionParams doc pos
531 in getResponseResult <$> request TextDocumentTypeDefinition params
533 -- | Renames the term at the specified position.
534 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
535 rename doc pos newName = do
536 let params = RenameParams doc pos (T.pack newName)
537 rsp <- request TextDocumentRename params :: Session RenameResponse
538 let wEdit = getResponseResult rsp
539 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
540 updateState (ReqApplyWorkspaceEdit req)
542 -- | Returns the hover information at the specified position.
543 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
545 let params = TextDocumentPositionParams doc pos
546 in getResponseResult <$> request TextDocumentHover params
548 -- | Returns the highlighted occurences of the term at the specified position
549 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
550 getHighlights doc pos =
551 let params = TextDocumentPositionParams doc pos
552 in getResponseResult <$> request TextDocumentDocumentHighlight params
554 -- | Checks the response for errors and throws an exception if needed.
555 -- Returns the result if successful.
556 getResponseResult :: ResponseMessage a -> a
557 getResponseResult rsp = fromMaybe exc (rsp ^. result)
558 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
559 (fromJust $ rsp ^. LSP.error)
561 -- | Applies formatting to the specified document.
562 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
563 formatDoc doc opts = do
564 let params = DocumentFormattingParams doc opts
565 edits <- getResponseResult <$> request TextDocumentFormatting params
566 applyTextEdits doc edits
568 -- | Applies formatting to the specified range in a document.
569 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
570 formatRange doc opts range = do
571 let params = DocumentRangeFormattingParams doc range opts
572 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
573 applyTextEdits doc edits
575 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
576 applyTextEdits doc edits =
577 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
578 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
579 in updateState (ReqApplyWorkspaceEdit req)