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
169 -- | Asks the server to shutdown and exit politely
170 exitServer :: Session ()
171 exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
173 -- | Listens to the server output until the shutdown ack,
174 -- makes sure it matches the record and signals any semaphores
175 listenServer :: Handle -> SessionContext -> IO ()
176 listenServer serverOut context = do
177 msgBytes <- getNextMessage serverOut
179 reqMap <- readMVar $ requestMap context
181 let msg = decodeFromServerMsg reqMap msgBytes
182 writeChan (messageChan context) (ServerMessage msg)
185 (RspShutdown _) -> return ()
186 _ -> listenServer serverOut context
188 -- | The current text contents of a document.
189 documentContents :: TextDocumentIdentifier -> Session T.Text
190 documentContents doc = do
192 let file = vfs Map.! toNormalizedUri (doc ^. uri)
193 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
195 -- | Parses an ApplyEditRequest, checks that it is for the passed document
196 -- and returns the new content
197 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
198 getDocumentEdit doc = do
199 req <- message :: Session ApplyWorkspaceEditRequest
201 unless (checkDocumentChanges req || checkChanges req) $
202 liftIO $ throw (IncorrectApplyEditRequest (show req))
206 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
207 checkDocumentChanges req =
208 let changes = req ^. params . edit . documentChanges
209 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
211 Just docs -> (doc ^. uri) `elem` docs
213 checkChanges :: ApplyWorkspaceEditRequest -> Bool
215 let mMap = req ^. params . edit . changes
216 in maybe False (HashMap.member (doc ^. uri)) mMap
218 -- | Sends a request to the server and waits for its response.
219 -- Will skip any messages in between the request and the response
221 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
223 -- Note: will skip any messages in between the request and the response.
224 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
225 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
227 -- | The same as 'sendRequest', but discard the response.
228 request_ :: ToJSON params => ClientMethod -> params -> Session ()
229 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
231 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
234 => ClientMethod -- ^ The request method.
235 -> params -- ^ The request parameters.
236 -> Session LspId -- ^ The id of the request that was sent.
237 sendRequest method params = do
238 id <- curReqId <$> get
239 modify $ \c -> c { curReqId = nextId id }
241 let req = RequestMessage' "2.0" id method params
243 -- Update the request map
244 reqMap <- requestMap <$> ask
245 liftIO $ modifyMVar_ reqMap $
246 \r -> return $ updateRequestMap r id method
252 where nextId (IdInt i) = IdInt (i + 1)
253 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
255 -- | A custom type for request message that doesn't
256 -- need a response type, allows us to infer the request
257 -- message type without using proxies.
258 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
260 instance ToJSON a => ToJSON (RequestMessage' a) where
261 toJSON (RequestMessage' rpc id method params) =
262 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
265 -- | Sends a notification to the server.
266 sendNotification :: ToJSON a
267 => ClientMethod -- ^ The notification method.
268 -> a -- ^ The notification parameters.
271 -- Open a virtual file if we send a did open text document notification
272 sendNotification TextDocumentDidOpen params = do
273 let params' = fromJust $ decode $ encode params
274 n :: DidOpenTextDocumentNotification
275 n = NotificationMessage "2.0" TextDocumentDidOpen params'
276 oldVFS <- vfs <$> get
277 newVFS <- liftIO $ openVFS oldVFS n
278 modify (\s -> s { vfs = newVFS })
281 -- Close a virtual file if we send a close text document notification
282 sendNotification TextDocumentDidClose params = do
283 let params' = fromJust $ decode $ encode params
284 n :: DidCloseTextDocumentNotification
285 n = NotificationMessage "2.0" TextDocumentDidClose params'
286 oldVFS <- vfs <$> get
287 newVFS <- liftIO $ closeVFS oldVFS n
288 modify (\s -> s { vfs = newVFS })
291 sendNotification TextDocumentDidChange params = do
292 let params' = fromJust $ decode $ encode params
293 n :: DidChangeTextDocumentNotification
294 n = NotificationMessage "2.0" TextDocumentDidChange params'
295 oldVFS <- vfs <$> get
296 newVFS <- liftIO $ changeFromClientVFS oldVFS n
297 modify (\s -> s { vfs = newVFS })
300 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
302 -- | Sends a response to the server.
303 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
304 sendResponse = sendMessage
306 -- | Returns the initialize response that was received from the server.
307 -- The initialize requests and responses are not included the session,
308 -- so if you need to test it use this.
309 initializeResponse :: Session InitializeResponse
310 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
312 -- | Opens a text document and sends a notification to the client.
313 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
314 openDoc file languageId = do
316 let fp = rootDir context </> file
317 contents <- liftIO $ T.readFile fp
318 openDoc' file languageId contents
320 -- | This is a variant of `openDoc` that takes the file content as an argument.
321 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
322 openDoc' file languageId contents = do
324 let fp = rootDir context </> file
325 uri = filePathToUri fp
326 item = TextDocumentItem uri (T.pack languageId) 0 contents
327 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
328 pure $ TextDocumentIdentifier uri
330 -- | Closes a text document and sends a notification to the client.
331 closeDoc :: TextDocumentIdentifier -> Session ()
333 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
334 sendNotification TextDocumentDidClose params
336 -- | Changes a text document and sends a notification to the client
337 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
338 changeDoc docId changes = do
339 verDoc <- getVersionedDoc docId
340 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
341 sendNotification TextDocumentDidChange params
343 -- | Gets the Uri for the file corrected to the session directory.
344 getDocUri :: FilePath -> Session Uri
347 let fp = rootDir context </> file
348 return $ filePathToUri fp
350 -- | Waits for diagnostics to be published and returns them.
351 waitForDiagnostics :: Session [Diagnostic]
352 waitForDiagnostics = do
353 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
354 let (List diags) = diagsNot ^. params . LSP.diagnostics
357 -- | The same as 'waitForDiagnostics', but will only match a specific
358 -- 'Language.Haskell.LSP.Types._source'.
359 waitForDiagnosticsSource :: String -> Session [Diagnostic]
360 waitForDiagnosticsSource src = do
361 diags <- waitForDiagnostics
362 let res = filter matches diags
364 then waitForDiagnosticsSource src
367 matches :: Diagnostic -> Bool
368 matches d = d ^. source == Just (T.pack src)
370 -- | Expects a 'PublishDiagnosticsNotification' and throws an
371 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
373 noDiagnostics :: Session ()
375 diagsNot <- message :: Session PublishDiagnosticsNotification
376 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
378 -- | Returns the symbols in a document.
379 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
380 getDocumentSymbols doc = do
381 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
382 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
384 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
385 Just (DSSymbolInformation (List xs)) -> return (Right xs)
386 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
388 -- | Returns the code actions in the specified range.
389 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
390 getCodeActions doc range = do
391 ctx <- getCodeActionContext doc
392 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
394 case rsp ^. result of
395 Just (List xs) -> return xs
396 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
398 -- | Returns all the code actions in a document by
399 -- querying the code actions at each of the current
400 -- diagnostics' positions.
401 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
402 getAllCodeActions doc = do
403 ctx <- getCodeActionContext doc
405 foldM (go ctx) [] =<< getCurrentDiagnostics doc
408 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
410 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
413 Just e -> throw (UnexpectedResponseError rspLid e)
415 let Just (List cmdOrCAs) = mRes
416 in return (acc ++ cmdOrCAs)
418 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
419 getCodeActionContext doc = do
420 curDiags <- getCurrentDiagnostics doc
421 return $ CodeActionContext (List curDiags) Nothing
423 -- | Returns the current diagnostics that have been sent to the client.
424 -- Note that this does not wait for more to come in.
425 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
426 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
428 -- | Executes a command.
429 executeCommand :: Command -> Session ()
430 executeCommand cmd = do
431 let args = decode $ encode $ fromJust $ cmd ^. arguments
432 execParams = ExecuteCommandParams (cmd ^. command) args
433 request_ WorkspaceExecuteCommand execParams
435 -- | Executes a code action.
436 -- Matching with the specification, if a code action
437 -- contains both an edit and a command, the edit will
439 executeCodeAction :: CodeAction -> Session ()
440 executeCodeAction action = do
441 maybe (return ()) handleEdit $ action ^. edit
442 maybe (return ()) executeCommand $ action ^. command
444 where handleEdit :: WorkspaceEdit -> Session ()
446 -- Its ok to pass in dummy parameters here as they aren't used
447 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
448 in updateState (ReqApplyWorkspaceEdit req)
450 -- | Adds the current version to the document, as tracked by the session.
451 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
452 getVersionedDoc (TextDocumentIdentifier uri) = do
455 case fs Map.!? toNormalizedUri uri of
456 Just (VirtualFile v _ _) -> Just v
458 return (VersionedTextDocumentIdentifier uri ver)
460 -- | Applys an edit to the document and returns the updated document version.
461 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
462 applyEdit doc edit = do
464 verDoc <- getVersionedDoc doc
466 caps <- asks sessionCapabilities
468 let supportsDocChanges = fromMaybe False $ do
469 let mWorkspace = C._workspace caps
470 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
471 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
474 let wEdit = if supportsDocChanges
476 let docEdit = TextDocumentEdit verDoc (List [edit])
477 in WorkspaceEdit Nothing (Just (List [docEdit]))
479 let changes = HashMap.singleton (doc ^. uri) (List [edit])
480 in WorkspaceEdit (Just changes) Nothing
482 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
483 updateState (ReqApplyWorkspaceEdit req)
485 -- version may have changed
488 -- | Returns the completions for the position in the document.
489 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
490 getCompletions doc pos = do
491 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
493 case getResponseResult rsp of
494 Completions (List items) -> return items
495 CompletionList (CompletionListType _ (List items)) -> return items
497 -- | Returns the references for the position in the document.
498 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
499 -> Position -- ^ The position to lookup.
500 -> Bool -- ^ Whether to include declarations as references.
501 -> Session [Location] -- ^ The locations of the references.
502 getReferences doc pos inclDecl =
503 let ctx = ReferenceContext inclDecl
504 params = ReferenceParams doc pos ctx
505 in getResponseResult <$> request TextDocumentReferences params
507 -- | Returns the definition(s) for the term at the specified position.
508 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
509 -> Position -- ^ The position the term is at.
510 -> Session [Location] -- ^ The location(s) of the definitions
511 getDefinitions doc pos = do
512 let params = TextDocumentPositionParams doc pos
513 rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
514 case getResponseResult rsp of
515 SingleLoc loc -> pure [loc]
516 MultiLoc locs -> pure locs
518 -- | Returns the type definition(s) for the term at the specified position.
519 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
520 -> Position -- ^ The position the term is at.
521 -> Session [Location] -- ^ The location(s) of the definitions
522 getTypeDefinitions doc pos =
523 let params = TextDocumentPositionParams doc pos
524 in getResponseResult <$> request TextDocumentTypeDefinition params
526 -- | Renames the term at the specified position.
527 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
528 rename doc pos newName = do
529 let params = RenameParams doc pos (T.pack newName)
530 rsp <- request TextDocumentRename params :: Session RenameResponse
531 let wEdit = getResponseResult rsp
532 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
533 updateState (ReqApplyWorkspaceEdit req)
535 -- | Returns the hover information at the specified position.
536 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
538 let params = TextDocumentPositionParams doc pos
539 in getResponseResult <$> request TextDocumentHover params
541 -- | Returns the highlighted occurences of the term at the specified position
542 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
543 getHighlights doc pos =
544 let params = TextDocumentPositionParams doc pos
545 in getResponseResult <$> request TextDocumentDocumentHighlight params
547 -- | Checks the response for errors and throws an exception if needed.
548 -- Returns the result if successful.
549 getResponseResult :: ResponseMessage a -> a
550 getResponseResult rsp = fromMaybe exc (rsp ^. result)
551 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
552 (fromJust $ rsp ^. LSP.error)
554 -- | Applies formatting to the specified document.
555 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
556 formatDoc doc opts = do
557 let params = DocumentFormattingParams doc opts
558 edits <- getResponseResult <$> request TextDocumentFormatting params
559 applyTextEdits doc edits
561 -- | Applies formatting to the specified range in a document.
562 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
563 formatRange doc opts range = do
564 let params = DocumentRangeFormattingParams doc range opts
565 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
566 applyTextEdits doc edits
568 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
569 applyTextEdits doc edits =
570 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
571 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
572 in updateState (ReqApplyWorkspaceEdit req)
574 -- | Returns the code lenses for the specified document.
575 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
576 getCodeLenses tId = do
577 rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse
578 case getResponseResult rsp of