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.
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
114 import System.Directory
115 import System.FilePath
116 import qualified Data.Rope.UTF16 as Rope
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
142 pid <- getCurrentProcessID
143 absRootDir <- canonicalizePath rootDir
145 let initializeParams = InitializeParams (Just pid)
146 (Just $ T.pack absRootDir)
147 (Just $ filePathToUri absRootDir)
152 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
153 runSessionWithHandles serverIn serverOut listenServer config caps rootDir exitServer $ 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
161 sendNotification Initialized InitializedParams
163 case lspConfig config of
164 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
167 -- Run the actual test
171 -- | Listens to the server output until the shutdown ack,
172 -- makes sure it matches the record and signals any semaphores
173 listenServer :: Handle -> SessionContext -> IO ()
174 listenServer serverOut context = do
175 msgBytes <- getNextMessage serverOut
177 reqMap <- readMVar $ requestMap context
179 let msg = decodeFromServerMsg reqMap msgBytes
180 writeChan (messageChan context) (ServerMessage msg)
183 (RspShutdown _) -> return ()
184 _ -> listenServer serverOut context
186 -- | The current text contents of a document.
187 documentContents :: TextDocumentIdentifier -> Session T.Text
188 documentContents doc = do
190 let file = vfs Map.! toNormalizedUri (doc ^. uri)
191 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
193 -- | Parses an ApplyEditRequest, checks that it is for the passed document
194 -- and returns the new content
195 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
196 getDocumentEdit doc = do
197 req <- message :: Session ApplyWorkspaceEditRequest
199 unless (checkDocumentChanges req || checkChanges req) $
200 liftIO $ throw (IncorrectApplyEditRequest (show req))
204 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
205 checkDocumentChanges req =
206 let changes = req ^. params . edit . documentChanges
207 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
209 Just docs -> (doc ^. uri) `elem` docs
211 checkChanges :: ApplyWorkspaceEditRequest -> Bool
213 let mMap = req ^. params . edit . changes
214 in maybe False (HashMap.member (doc ^. uri)) mMap
216 -- | Sends a request to the server and waits for its response.
217 -- Will skip any messages in between the request and the response
219 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
221 -- Note: will skip any messages in between the request and the response.
222 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
223 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
225 -- | The same as 'sendRequest', but discard the response.
226 request_ :: ToJSON params => ClientMethod -> params -> Session ()
227 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
229 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
232 => ClientMethod -- ^ The request method.
233 -> params -- ^ The request parameters.
234 -> Session LspId -- ^ The id of the request that was sent.
235 sendRequest method params = do
236 id <- curReqId <$> get
237 modify $ \c -> c { curReqId = nextId id }
239 let req = RequestMessage' "2.0" id method params
241 -- Update the request map
242 reqMap <- requestMap <$> ask
243 liftIO $ modifyMVar_ reqMap $
244 \r -> return $ updateRequestMap r id method
250 where nextId (IdInt i) = IdInt (i + 1)
251 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
253 -- | A custom type for request message that doesn't
254 -- need a response type, allows us to infer the request
255 -- message type without using proxies.
256 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
258 instance ToJSON a => ToJSON (RequestMessage' a) where
259 toJSON (RequestMessage' rpc id method params) =
260 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
263 -- | Sends a notification to the server.
264 sendNotification :: ToJSON a
265 => ClientMethod -- ^ The notification method.
266 -> a -- ^ The notification parameters.
269 -- Open a virtual file if we send a did open text document notification
270 sendNotification TextDocumentDidOpen params = do
271 let params' = fromJust $ decode $ encode params
272 n :: DidOpenTextDocumentNotification
273 n = NotificationMessage "2.0" TextDocumentDidOpen params'
274 oldVFS <- vfs <$> get
275 newVFS <- liftIO $ openVFS oldVFS n
276 modify (\s -> s { vfs = newVFS })
279 -- Close a virtual file if we send a close text document notification
280 sendNotification TextDocumentDidClose params = do
281 let params' = fromJust $ decode $ encode params
282 n :: DidCloseTextDocumentNotification
283 n = NotificationMessage "2.0" TextDocumentDidClose params'
284 oldVFS <- vfs <$> get
285 newVFS <- liftIO $ closeVFS oldVFS n
286 modify (\s -> s { vfs = newVFS })
289 sendNotification TextDocumentDidChange params = do
290 let params' = fromJust $ decode $ encode params
291 n :: DidChangeTextDocumentNotification
292 n = NotificationMessage "2.0" TextDocumentDidChange params'
293 oldVFS <- vfs <$> get
294 newVFS <- liftIO $ changeFromClientVFS oldVFS n
295 modify (\s -> s { vfs = newVFS })
298 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
300 -- | Sends a response to the server.
301 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
302 sendResponse = sendMessage
304 -- | Returns the initialize response that was received from the server.
305 -- The initialize requests and responses are not included the session,
306 -- so if you need to test it use this.
307 initializeResponse :: Session InitializeResponse
308 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
310 -- | Opens a text document and sends a notification to the client.
311 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
312 openDoc file languageId = do
314 let fp = rootDir context </> file
315 contents <- liftIO $ T.readFile fp
316 openDoc' file languageId contents
318 -- | This is a variant of `openDoc` that takes the file content as an argument.
319 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
320 openDoc' file languageId contents = do
322 let fp = rootDir context </> file
323 uri = filePathToUri fp
324 item = TextDocumentItem uri (T.pack languageId) 0 contents
325 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
326 pure $ TextDocumentIdentifier uri
328 -- | Closes a text document and sends a notification to the client.
329 closeDoc :: TextDocumentIdentifier -> Session ()
331 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
332 sendNotification TextDocumentDidClose params
334 -- | Changes a text document and sends a notification to the client
335 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
336 changeDoc docId changes = do
337 verDoc <- getVersionedDoc docId
338 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
339 sendNotification TextDocumentDidChange params
341 -- | Gets the Uri for the file corrected to the session directory.
342 getDocUri :: FilePath -> Session Uri
345 let fp = rootDir context </> file
346 return $ filePathToUri fp
348 -- | Waits for diagnostics to be published and returns them.
349 waitForDiagnostics :: Session [Diagnostic]
350 waitForDiagnostics = do
351 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
352 let (List diags) = diagsNot ^. params . LSP.diagnostics
355 -- | The same as 'waitForDiagnostics', but will only match a specific
356 -- 'Language.Haskell.LSP.Types._source'.
357 waitForDiagnosticsSource :: String -> Session [Diagnostic]
358 waitForDiagnosticsSource src = do
359 diags <- waitForDiagnostics
360 let res = filter matches diags
362 then waitForDiagnosticsSource src
365 matches :: Diagnostic -> Bool
366 matches d = d ^. source == Just (T.pack src)
368 -- | Expects a 'PublishDiagnosticsNotification' and throws an
369 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
371 noDiagnostics :: Session ()
373 diagsNot <- message :: Session PublishDiagnosticsNotification
374 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
376 -- | Returns the symbols in a document.
377 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
378 getDocumentSymbols doc = do
379 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
380 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
382 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
383 Just (DSSymbolInformation (List xs)) -> return (Right xs)
384 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
386 -- | Returns the code actions in the specified range.
387 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
388 getCodeActions doc range = do
389 ctx <- getCodeActionContext doc
390 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
392 case rsp ^. result of
393 Just (List xs) -> return xs
394 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
396 -- | Returns all the code actions in a document by
397 -- querying the code actions at each of the current
398 -- diagnostics' positions.
399 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
400 getAllCodeActions doc = do
401 ctx <- getCodeActionContext doc
403 foldM (go ctx) [] =<< getCurrentDiagnostics doc
406 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
408 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
411 Just e -> throw (UnexpectedResponseError rspLid e)
413 let Just (List cmdOrCAs) = mRes
414 in return (acc ++ cmdOrCAs)
416 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
417 getCodeActionContext doc = do
418 curDiags <- getCurrentDiagnostics doc
419 return $ CodeActionContext (List curDiags) Nothing
421 -- | Returns the current diagnostics that have been sent to the client.
422 -- Note that this does not wait for more to come in.
423 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
424 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
426 -- | Executes a command.
427 executeCommand :: Command -> Session ()
428 executeCommand cmd = do
429 let args = decode $ encode $ fromJust $ cmd ^. arguments
430 execParams = ExecuteCommandParams (cmd ^. command) args
431 request_ WorkspaceExecuteCommand execParams
433 -- | Executes a code action.
434 -- Matching with the specification, if a code action
435 -- contains both an edit and a command, the edit will
437 executeCodeAction :: CodeAction -> Session ()
438 executeCodeAction action = do
439 maybe (return ()) handleEdit $ action ^. edit
440 maybe (return ()) executeCommand $ action ^. command
442 where handleEdit :: WorkspaceEdit -> Session ()
444 -- Its ok to pass in dummy parameters here as they aren't used
445 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
446 in updateState (ReqApplyWorkspaceEdit req)
448 -- | Adds the current version to the document, as tracked by the session.
449 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
450 getVersionedDoc (TextDocumentIdentifier uri) = do
453 case fs Map.!? toNormalizedUri uri of
454 Just (VirtualFile v _ _) -> Just v
456 return (VersionedTextDocumentIdentifier uri ver)
458 -- | Applys an edit to the document and returns the updated document version.
459 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
460 applyEdit doc edit = do
462 verDoc <- getVersionedDoc doc
464 caps <- asks sessionCapabilities
466 let supportsDocChanges = fromMaybe False $ do
467 let mWorkspace = C._workspace caps
468 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
469 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
472 let wEdit = if supportsDocChanges
474 let docEdit = TextDocumentEdit verDoc (List [edit])
475 in WorkspaceEdit Nothing (Just (List [docEdit]))
477 let changes = HashMap.singleton (doc ^. uri) (List [edit])
478 in WorkspaceEdit (Just changes) Nothing
480 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
481 updateState (ReqApplyWorkspaceEdit req)
483 -- version may have changed
486 -- | Returns the completions for the position in the document.
487 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
488 getCompletions doc pos = do
489 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
491 case getResponseResult rsp of
492 Completions (List items) -> return items
493 CompletionList (CompletionListType _ (List items)) -> return items
495 -- | Returns the references for the position in the document.
496 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
497 -> Position -- ^ The position to lookup.
498 -> Bool -- ^ Whether to include declarations as references.
499 -> Session [Location] -- ^ The locations of the references.
500 getReferences doc pos inclDecl =
501 let ctx = ReferenceContext inclDecl
502 params = ReferenceParams doc pos ctx
503 in getResponseResult <$> request TextDocumentReferences params
505 -- | Returns the definition(s) for the term at the specified position.
506 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
507 -> Position -- ^ The position the term is at.
508 -> Session [Location] -- ^ The location(s) of the definitions
509 getDefinitions doc pos = do
510 let params = TextDocumentPositionParams doc pos
511 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
512 case getResponseResult rsp of
513 SingleLoc loc -> pure [loc]
514 MultiLoc locs -> pure locs
516 -- | Returns the type definition(s) for the term at the specified position.
517 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
518 -> Position -- ^ The position the term is at.
519 -> Session [Location] -- ^ The location(s) of the definitions
520 getTypeDefinitions doc pos =
521 let params = TextDocumentPositionParams doc pos
522 in getResponseResult <$> request TextDocumentTypeDefinition params
524 -- | Renames the term at the specified position.
525 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
526 rename doc pos newName = do
527 let params = RenameParams doc pos (T.pack newName)
528 rsp <- request TextDocumentRename params :: Session RenameResponse
529 let wEdit = getResponseResult rsp
530 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
531 updateState (ReqApplyWorkspaceEdit req)
533 -- | Returns the hover information at the specified position.
534 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
536 let params = TextDocumentPositionParams doc pos
537 in getResponseResult <$> request TextDocumentHover params
539 -- | Returns the highlighted occurences of the term at the specified position
540 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
541 getHighlights doc pos =
542 let params = TextDocumentPositionParams doc pos
543 in getResponseResult <$> request TextDocumentDocumentHighlight params
545 -- | Checks the response for errors and throws an exception if needed.
546 -- Returns the result if successful.
547 getResponseResult :: ResponseMessage a -> a
548 getResponseResult rsp = fromMaybe exc (rsp ^. result)
549 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
550 (fromJust $ rsp ^. LSP.error)
552 -- | Applies formatting to the specified document.
553 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
554 formatDoc doc opts = do
555 let params = DocumentFormattingParams doc opts
556 edits <- getResponseResult <$> request TextDocumentFormatting params
557 applyTextEdits doc edits
559 -- | Applies formatting to the specified range in a document.
560 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
561 formatRange doc opts range = do
562 let params = DocumentRangeFormattingParams doc range opts
563 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
564 applyTextEdits doc edits
566 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
567 applyTextEdits doc edits =
568 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
569 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
570 in updateState (ReqApplyWorkspaceEdit req)
572 -- | Returns the code lenses for the specified document.
573 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
574 getCodeLenses tId = do
575 rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse
576 case getResponseResult rsp of
579 -- | Exit the server after request its shutdown
580 exitServer :: Session()
581 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams