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.
55 , waitForDiagnosticsSource
57 , getCurrentDiagnostics
86 import Control.Applicative.Combinators
87 import Control.Concurrent
89 import Control.Monad.IO.Class
90 import Control.Exception
91 import Control.Lens hiding ((.=), List)
92 import qualified Data.Text as T
93 import qualified Data.Text.IO as T
96 import qualified Data.HashMap.Strict as HashMap
97 import qualified Data.Map as Map
99 import Language.Haskell.LSP.Types
100 import Language.Haskell.LSP.Types.Lens hiding
101 (id, capabilities, message, executeCommand, applyEdit, rename)
102 import qualified Language.Haskell.LSP.Types.Lens as LSP
103 import qualified Language.Haskell.LSP.Types.Capabilities as C
104 import Language.Haskell.LSP.Messages
105 import Language.Haskell.LSP.VFS
106 import Language.Haskell.LSP.Test.Compat
107 import Language.Haskell.LSP.Test.Decoding
108 import Language.Haskell.LSP.Test.Exceptions
109 import Language.Haskell.LSP.Test.Parsing
110 import Language.Haskell.LSP.Test.Session
111 import Language.Haskell.LSP.Test.Server
113 import System.Directory
114 import System.FilePath
115 import qualified Data.Rope.UTF16 as Rope
117 -- | Starts a new session.
119 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
120 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
121 -- > diags <- waitForDiagnostics
122 -- > let pos = Position 12 5
123 -- > params = TextDocumentPositionParams doc
124 -- > hover <- request TextDocumentHover params
125 runSession :: String -- ^ The command to run the server.
126 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
127 -> FilePath -- ^ The filepath to the root directory for the session.
128 -> Session a -- ^ The session to run.
130 runSession = runSessionWithConfig def
132 -- | Starts a new sesion with a custom configuration.
133 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
134 -> String -- ^ The command to run the server.
135 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
136 -> FilePath -- ^ The filepath to the root directory for the session.
137 -> Session a -- ^ The session to run.
139 runSessionWithConfig config serverExe caps rootDir session = do
140 pid <- getCurrentProcessID
141 absRootDir <- canonicalizePath rootDir
143 let initializeParams = InitializeParams (Just pid)
144 (Just $ T.pack absRootDir)
145 (Just $ filePathToUri absRootDir)
150 withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
151 runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
152 -- Wrap the session around initialize and shutdown calls
153 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
155 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
157 initRspVar <- initRsp <$> ask
158 liftIO $ putMVar initRspVar initRspMsg
159 sendNotification Initialized InitializedParams
161 case lspConfig config of
162 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
165 -- Run the actual test
168 -- | Asks the server to shutdown and exit politely
169 exitServer :: Session ()
170 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
172 -- | Listens to the server output until the shutdown ack,
173 -- makes sure it matches the record and signals any semaphores
174 listenServer :: Handle -> SessionContext -> IO ()
175 listenServer serverOut context = do
176 msgBytes <- getNextMessage serverOut
178 reqMap <- readMVar $ requestMap context
180 let msg = decodeFromServerMsg reqMap msgBytes
181 writeChan (messageChan context) (ServerMessage msg)
184 (RspShutdown _) -> return ()
185 _ -> listenServer serverOut context
187 -- | The current text contents of a document.
188 documentContents :: TextDocumentIdentifier -> Session T.Text
189 documentContents doc = do
191 let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
192 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
194 -- | Parses an ApplyEditRequest, checks that it is for the passed document
195 -- and returns the new content
196 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
197 getDocumentEdit doc = do
198 req <- message :: Session ApplyWorkspaceEditRequest
200 unless (checkDocumentChanges req || checkChanges req) $
201 liftIO $ throw (IncorrectApplyEditRequest (show req))
205 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
206 checkDocumentChanges req =
207 let changes = req ^. params . edit . documentChanges
208 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
210 Just docs -> (doc ^. uri) `elem` docs
212 checkChanges :: ApplyWorkspaceEditRequest -> Bool
214 let mMap = req ^. params . edit . changes
215 in maybe False (HashMap.member (doc ^. uri)) mMap
217 -- | Sends a request to the server and waits for its response.
218 -- Will skip any messages in between the request and the response
220 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
222 -- Note: will skip any messages in between the request and the response.
223 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
224 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
226 -- | The same as 'sendRequest', but discard the response.
227 request_ :: ToJSON params => ClientMethod -> params -> Session ()
228 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
230 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
233 => ClientMethod -- ^ The request method.
234 -> params -- ^ The request parameters.
235 -> Session LspId -- ^ The id of the request that was sent.
236 sendRequest method params = do
237 id <- curReqId <$> get
238 modify $ \c -> c { curReqId = nextId id }
240 let req = RequestMessage' "2.0" id method params
242 -- Update the request map
243 reqMap <- requestMap <$> ask
244 liftIO $ modifyMVar_ reqMap $
245 \r -> return $ updateRequestMap r id method
251 where nextId (IdInt i) = IdInt (i + 1)
252 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
254 -- | A custom type for request message that doesn't
255 -- need a response type, allows us to infer the request
256 -- message type without using proxies.
257 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
259 instance ToJSON a => ToJSON (RequestMessage' a) where
260 toJSON (RequestMessage' rpc id method params) =
261 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
264 -- | Sends a notification to the server.
265 sendNotification :: ToJSON a
266 => ClientMethod -- ^ The notification method.
267 -> a -- ^ The notification parameters.
270 -- Open a virtual file if we send a did open text document notification
271 sendNotification TextDocumentDidOpen params = do
272 let params' = fromJust $ decode $ encode params
273 n :: DidOpenTextDocumentNotification
274 n = NotificationMessage "2.0" TextDocumentDidOpen params'
275 oldVFS <- vfs <$> get
276 newVFS <- liftIO $ openVFS oldVFS n
277 modify (\s -> s { vfs = newVFS })
280 -- Close a virtual file if we send a close text document notification
281 sendNotification TextDocumentDidClose params = do
282 let params' = fromJust $ decode $ encode params
283 n :: DidCloseTextDocumentNotification
284 n = NotificationMessage "2.0" TextDocumentDidClose params'
285 oldVFS <- vfs <$> get
286 newVFS <- liftIO $ closeVFS oldVFS n
287 modify (\s -> s { vfs = newVFS })
290 sendNotification TextDocumentDidChange params = do
291 let params' = fromJust $ decode $ encode params
292 n :: DidChangeTextDocumentNotification
293 n = NotificationMessage "2.0" TextDocumentDidChange params'
294 oldVFS <- vfs <$> get
295 newVFS <- liftIO $ changeFromClientVFS oldVFS n
296 modify (\s -> s { vfs = newVFS })
299 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
301 -- | Sends a response to the server.
302 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
303 sendResponse = sendMessage
305 -- | Returns the initialize response that was received from the server.
306 -- The initialize requests and responses are not included the session,
307 -- so if you need to test it use this.
308 initializeResponse :: Session InitializeResponse
309 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
311 -- | Opens a text document and sends a notification to the client.
312 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
313 openDoc file languageId = do
315 let fp = rootDir context </> file
316 contents <- liftIO $ T.readFile fp
317 openDoc' file languageId contents
319 -- | This is a variant of `openDoc` that takes the file content as an argument.
320 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
321 openDoc' file languageId contents = do
323 let fp = rootDir context </> file
324 uri = filePathToUri fp
325 item = TextDocumentItem uri (T.pack languageId) 0 contents
326 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
327 pure $ TextDocumentIdentifier uri
329 -- | Closes a text document and sends a notification to the client.
330 closeDoc :: TextDocumentIdentifier -> Session ()
332 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
333 sendNotification TextDocumentDidClose params
335 -- | Changes a text document and sends a notification to the client
336 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
337 changeDoc docId changes = do
338 verDoc <- getVersionedDoc docId
339 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
340 sendNotification TextDocumentDidChange params
342 -- | Gets the Uri for the file corrected to the session directory.
343 getDocUri :: FilePath -> Session Uri
346 let fp = rootDir context </> file
347 return $ filePathToUri fp
349 -- | Waits for diagnostics to be published and returns them.
350 waitForDiagnostics :: Session [Diagnostic]
351 waitForDiagnostics = do
352 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
353 let (List diags) = diagsNot ^. params . LSP.diagnostics
356 -- | The same as 'waitForDiagnostics', but will only match a specific
357 -- 'Language.Haskell.LSP.Types._source'.
358 waitForDiagnosticsSource :: String -> Session [Diagnostic]
359 waitForDiagnosticsSource src = do
360 diags <- waitForDiagnostics
361 let res = filter matches diags
363 then waitForDiagnosticsSource src
366 matches :: Diagnostic -> Bool
367 matches d = d ^. source == Just (T.pack src)
369 -- | Expects a 'PublishDiagnosticsNotification' and throws an
370 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
372 noDiagnostics :: Session ()
374 diagsNot <- message :: Session PublishDiagnosticsNotification
375 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
377 -- | Returns the symbols in a document.
378 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
379 getDocumentSymbols doc = do
380 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
381 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
383 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
384 Just (DSSymbolInformation (List xs)) -> return (Right xs)
385 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
387 -- | Returns the code actions in the specified range.
388 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
389 getCodeActions doc range = do
390 ctx <- getCodeActionContext doc
391 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
393 case rsp ^. result of
394 Just (List xs) -> return xs
395 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
397 -- | Returns all the code actions in a document by
398 -- querying the code actions at each of the current
399 -- diagnostics' positions.
400 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
401 getAllCodeActions doc = do
402 ctx <- getCodeActionContext doc
404 foldM (go ctx) [] =<< getCurrentDiagnostics doc
407 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
409 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
412 Just e -> throw (UnexpectedResponseError rspLid e)
414 let Just (List cmdOrCAs) = mRes
415 in return (acc ++ cmdOrCAs)
417 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
418 getCodeActionContext doc = do
419 curDiags <- getCurrentDiagnostics doc
420 return $ CodeActionContext (List curDiags) Nothing
422 -- | Returns the current diagnostics that have been sent to the client.
423 -- Note that this does not wait for more to come in.
424 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
425 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
427 -- | Executes a command.
428 executeCommand :: Command -> Session ()
429 executeCommand cmd = do
430 let args = decode $ encode $ fromJust $ cmd ^. arguments
431 execParams = ExecuteCommandParams (cmd ^. command) args Nothing
432 request_ WorkspaceExecuteCommand execParams
434 -- | Executes a code action.
435 -- Matching with the specification, if a code action
436 -- contains both an edit and a command, the edit will
438 executeCodeAction :: CodeAction -> Session ()
439 executeCodeAction action = do
440 maybe (return ()) handleEdit $ action ^. edit
441 maybe (return ()) executeCommand $ action ^. command
443 where handleEdit :: WorkspaceEdit -> Session ()
445 -- Its ok to pass in dummy parameters here as they aren't used
446 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
447 in updateState (ReqApplyWorkspaceEdit req)
449 -- | Adds the current version to the document, as tracked by the session.
450 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
451 getVersionedDoc (TextDocumentIdentifier uri) = do
452 fs <- vfsMap . vfs <$> get
454 case fs Map.!? toNormalizedUri uri of
455 Just (VirtualFile v _) -> Just v
457 return (VersionedTextDocumentIdentifier uri ver)
459 -- | Applys an edit to the document and returns the updated document version.
460 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
461 applyEdit doc edit = do
463 verDoc <- getVersionedDoc doc
465 caps <- asks sessionCapabilities
467 let supportsDocChanges = fromMaybe False $ do
468 let mWorkspace = C._workspace caps
469 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
470 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
473 let wEdit = if supportsDocChanges
475 let docEdit = TextDocumentEdit verDoc (List [edit])
476 in WorkspaceEdit Nothing (Just (List [docEdit]))
478 let changes = HashMap.singleton (doc ^. uri) (List [edit])
479 in WorkspaceEdit (Just changes) Nothing
481 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
482 updateState (ReqApplyWorkspaceEdit req)
484 -- version may have changed
487 -- | Returns the completions for the position in the document.
488 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
489 getCompletions doc pos = do
490 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
492 case getResponseResult rsp of
493 Completions (List items) -> return items
494 CompletionList (CompletionListType _ (List items)) -> return items
496 -- | Returns the references for the position in the document.
497 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
498 -> Position -- ^ The position to lookup.
499 -> Bool -- ^ Whether to include declarations as references.
500 -> Session [Location] -- ^ The locations of the references.
501 getReferences doc pos inclDecl =
502 let ctx = ReferenceContext inclDecl
503 params = ReferenceParams doc pos ctx Nothing
504 in getResponseResult <$> request TextDocumentReferences params
506 -- | Returns the definition(s) for the term at the specified position.
507 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
508 -> Position -- ^ The position the term is at.
509 -> Session [Location] -- ^ The location(s) of the definitions
510 getDefinitions doc pos = do
511 let params = TextDocumentPositionParams doc pos Nothing
512 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
513 case getResponseResult rsp of
514 SingleLoc loc -> pure [loc]
515 MultiLoc locs -> pure locs
517 -- | Returns the type definition(s) for the term at the specified position.
518 getTypeDefinitions :: 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 getTypeDefinitions doc pos =
522 let params = TextDocumentPositionParams doc pos Nothing
523 in getResponseResult <$> request TextDocumentTypeDefinition params
525 -- | Renames the term at the specified position.
526 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
527 rename doc pos newName = do
528 let params = RenameParams doc pos (T.pack newName) Nothing
529 rsp <- request TextDocumentRename params :: Session RenameResponse
530 let wEdit = getResponseResult rsp
531 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
532 updateState (ReqApplyWorkspaceEdit req)
534 -- | Returns the hover information at the specified position.
535 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
537 let params = TextDocumentPositionParams doc pos Nothing
538 in getResponseResult <$> request TextDocumentHover params
540 -- | Returns the highlighted occurences of the term at the specified position
541 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
542 getHighlights doc pos =
543 let params = TextDocumentPositionParams doc pos Nothing
544 in getResponseResult <$> request TextDocumentDocumentHighlight params
546 -- | Checks the response for errors and throws an exception if needed.
547 -- Returns the result if successful.
548 getResponseResult :: ResponseMessage a -> a
549 getResponseResult rsp = fromMaybe exc (rsp ^. result)
550 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
551 (fromJust $ rsp ^. LSP.error)
553 -- | Applies formatting to the specified document.
554 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
555 formatDoc doc opts = do
556 let params = DocumentFormattingParams doc opts Nothing
557 edits <- getResponseResult <$> request TextDocumentFormatting params
558 applyTextEdits doc edits
560 -- | Applies formatting to the specified range in a document.
561 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
562 formatRange doc opts range = do
563 let params = DocumentRangeFormattingParams doc range opts Nothing
564 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
565 applyTextEdits doc edits
567 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
568 applyTextEdits doc edits =
569 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
570 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
571 in updateState (ReqApplyWorkspaceEdit req)
573 -- | Returns the code lenses for the specified document.
574 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
575 getCodeLenses tId = do
576 rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
577 case getResponseResult rsp of