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.
53 , waitForDiagnosticsSource
55 , getCurrentDiagnostics
81 import Control.Applicative.Combinators
82 import Control.Concurrent
84 import Control.Monad.IO.Class
85 import Control.Exception
86 import Control.Lens hiding ((.=), List)
87 import qualified Data.Text as T
88 import qualified Data.Text.IO as T
91 import qualified Data.HashMap.Strict as HashMap
92 import qualified Data.Map as Map
94 import Language.Haskell.LSP.Types
95 import Language.Haskell.LSP.Types.Lens hiding
96 (id, capabilities, message, executeCommand, applyEdit, rename)
97 import qualified Language.Haskell.LSP.Types.Lens as LSP
98 import qualified Language.Haskell.LSP.Types.Capabilities as C
99 import Language.Haskell.LSP.Messages
100 import Language.Haskell.LSP.VFS
101 import Language.Haskell.LSP.Test.Compat
102 import Language.Haskell.LSP.Test.Decoding
103 import Language.Haskell.LSP.Test.Exceptions
104 import Language.Haskell.LSP.Test.Parsing
105 import Language.Haskell.LSP.Test.Session
106 import Language.Haskell.LSP.Test.Server
108 import System.Directory
109 import System.FilePath
110 import qualified Yi.Rope as Rope
112 -- | Starts a new session.
114 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
115 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
116 -- > diags <- waitForDiagnostics
117 -- > let pos = Position 12 5
118 -- > params = TextDocumentPositionParams doc
119 -- > hover <- request TextDocumentHover params
120 runSession :: String -- ^ The command to run the server.
121 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
122 -> FilePath -- ^ The filepath to the root directory for the session.
123 -> Session a -- ^ The session to run.
125 runSession = runSessionWithConfig def
127 -- | Starts a new sesion with a custom configuration.
128 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
129 -> String -- ^ The command to run the server.
130 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
131 -> FilePath -- ^ The filepath to the root directory for the session.
132 -> Session a -- ^ The session to run.
134 runSessionWithConfig config serverExe caps rootDir session = do
135 pid <- getCurrentProcessID
136 absRootDir <- canonicalizePath rootDir
138 let initializeParams = InitializeParams (Just pid)
139 (Just $ T.pack absRootDir)
140 (Just $ filePathToUri absRootDir)
145 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
146 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
148 -- Wrap the session around initialize and shutdown calls
149 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
151 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
153 initRspVar <- initRsp <$> ask
154 liftIO $ putMVar initRspVar initRspMsg
156 sendNotification Initialized InitializedParams
158 case lspConfig config of
159 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
162 -- Run the actual test
165 sendNotification Exit ExitParams
169 -- | Listens to the server output, makes sure it matches the record and
170 -- signals any semaphores
171 listenServer :: Handle -> SessionContext -> IO ()
172 listenServer serverOut context = do
173 msgBytes <- getNextMessage serverOut
175 reqMap <- readMVar $ requestMap context
177 let msg = decodeFromServerMsg reqMap msgBytes
178 writeChan (messageChan context) (ServerMessage msg)
180 listenServer serverOut context
182 -- | The current text contents of a document.
183 documentContents :: TextDocumentIdentifier -> Session T.Text
184 documentContents doc = do
186 let file = vfs Map.! (doc ^. uri)
187 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
189 -- | Parses an ApplyEditRequest, checks that it is for the passed document
190 -- and returns the new content
191 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
192 getDocumentEdit doc = do
193 req <- message :: Session ApplyWorkspaceEditRequest
195 unless (checkDocumentChanges req || checkChanges req) $
196 liftIO $ throw (IncorrectApplyEditRequest (show req))
200 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
201 checkDocumentChanges req =
202 let changes = req ^. params . edit . documentChanges
203 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
205 Just docs -> (doc ^. uri) `elem` docs
207 checkChanges :: ApplyWorkspaceEditRequest -> Bool
209 let mMap = req ^. params . edit . changes
210 in maybe False (HashMap.member (doc ^. uri)) mMap
212 -- | Sends a request to the server and waits for its response.
213 -- Will skip any messages in between the request and the response
215 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
217 -- Note: will skip any messages in between the request and the response.
218 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
219 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
221 -- | The same as 'sendRequest', but discard the response.
222 request_ :: ToJSON params => ClientMethod -> params -> Session ()
223 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
225 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
228 => ClientMethod -- ^ The request method.
229 -> params -- ^ The request parameters.
230 -> Session LspId -- ^ The id of the request that was sent.
231 sendRequest method params = do
232 id <- curReqId <$> get
233 modify $ \c -> c { curReqId = nextId id }
235 let req = RequestMessage' "2.0" id method params
237 -- Update the request map
238 reqMap <- requestMap <$> ask
239 liftIO $ modifyMVar_ reqMap $
240 \r -> return $ updateRequestMap r id method
246 where nextId (IdInt i) = IdInt (i + 1)
247 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
249 -- | A custom type for request message that doesn't
250 -- need a response type, allows us to infer the request
251 -- message type without using proxies.
252 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
254 instance ToJSON a => ToJSON (RequestMessage' a) where
255 toJSON (RequestMessage' rpc id method params) =
256 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
259 -- | Sends a notification to the server.
260 sendNotification :: ToJSON a
261 => ClientMethod -- ^ The notification method.
262 -> a -- ^ The notification parameters.
265 -- Open a virtual file if we send a did open text document notification
266 sendNotification TextDocumentDidOpen params = do
267 let params' = fromJust $ decode $ encode params
268 n :: DidOpenTextDocumentNotification
269 n = NotificationMessage "2.0" TextDocumentDidOpen params'
270 oldVFS <- vfs <$> get
271 newVFS <- liftIO $ openVFS oldVFS n
272 modify (\s -> s { vfs = newVFS })
275 -- Close a virtual file if we send a close text document notification
276 sendNotification TextDocumentDidClose params = do
277 let params' = fromJust $ decode $ encode params
278 n :: DidCloseTextDocumentNotification
279 n = NotificationMessage "2.0" TextDocumentDidClose params'
280 oldVFS <- vfs <$> get
281 newVFS <- liftIO $ closeVFS oldVFS n
282 modify (\s -> s { vfs = newVFS })
285 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
287 -- | Sends a response to the server.
288 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
289 sendResponse = sendMessage
291 -- | Returns the initialize response that was received from the server.
292 -- The initialize requests and responses are not included the session,
293 -- so if you need to test it use this.
294 initializeResponse :: Session InitializeResponse
295 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
297 -- | Opens a text document and sends a notification to the client.
298 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
299 openDoc file languageId = do
300 item <- getDocItem file languageId
301 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
302 TextDocumentIdentifier <$> getDocUri file
304 -- | Reads in a text document as the first version.
305 getDocItem :: FilePath -- ^ The path to the text document to read in.
306 -> String -- ^ The language ID, e.g "haskell" for .hs files.
307 -> Session TextDocumentItem
308 getDocItem file languageId = do
310 let fp = rootDir context </> file
311 contents <- liftIO $ T.readFile fp
312 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
314 -- | Closes a text document and sends a notification to the client.
315 closeDoc :: TextDocumentIdentifier -> Session ()
317 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
318 sendNotification TextDocumentDidClose params
320 oldVfs <- vfs <$> get
321 let notif = NotificationMessage "" TextDocumentDidClose params
322 newVfs <- liftIO $ closeVFS oldVfs notif
323 modify $ \s -> s { vfs = newVfs }
325 -- | Gets the Uri for the file corrected to the session directory.
326 getDocUri :: FilePath -> Session Uri
329 let fp = rootDir context </> file
330 return $ filePathToUri fp
332 -- | Waits for diagnostics to be published and returns them.
333 waitForDiagnostics :: Session [Diagnostic]
334 waitForDiagnostics = do
335 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
336 let (List diags) = diagsNot ^. params . LSP.diagnostics
339 -- | The same as 'waitForDiagnostics', but will only match a specific
340 -- 'Language.Haskell.LSP.Types._source'.
341 waitForDiagnosticsSource :: String -> Session [Diagnostic]
342 waitForDiagnosticsSource src = do
343 diags <- waitForDiagnostics
344 let res = filter matches diags
346 then waitForDiagnosticsSource src
349 matches :: Diagnostic -> Bool
350 matches d = d ^. source == Just (T.pack src)
352 -- | Expects a 'PublishDiagnosticsNotification' and throws an
353 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
355 noDiagnostics :: Session ()
357 diagsNot <- message :: Session PublishDiagnosticsNotification
358 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
360 -- | Returns the symbols in a document.
361 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
362 getDocumentSymbols doc = do
363 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
364 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
366 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
367 Just (DSSymbolInformation (List xs)) -> return (Right xs)
368 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
370 -- | Returns the code actions in the specified range.
371 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
372 getCodeActions doc range = do
373 ctx <- getCodeActionContext doc
374 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
376 case rsp ^. result of
377 Just (List xs) -> return xs
378 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
380 -- | Returns all the code actions in a document by
381 -- querying the code actions at each of the current
382 -- diagnostics' positions.
383 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
384 getAllCodeActions doc = do
385 ctx <- getCodeActionContext doc
387 foldM (go ctx) [] =<< getCurrentDiagnostics doc
390 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
392 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
395 Just e -> throw (UnexpectedResponseError rspLid e)
397 let Just (List cmdOrCAs) = mRes
398 in return (acc ++ cmdOrCAs)
400 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
401 getCodeActionContext doc = do
402 curDiags <- getCurrentDiagnostics doc
403 return $ CodeActionContext (List curDiags) Nothing
405 -- | Returns the current diagnostics that have been sent to the client.
406 -- Note that this does not wait for more to come in.
407 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
408 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
410 -- | Executes a command.
411 executeCommand :: Command -> Session ()
412 executeCommand cmd = do
413 let args = decode $ encode $ fromJust $ cmd ^. arguments
414 execParams = ExecuteCommandParams (cmd ^. command) args
415 request_ WorkspaceExecuteCommand execParams
417 -- | Executes a code action.
418 -- Matching with the specification, if a code action
419 -- contains both an edit and a command, the edit will
421 executeCodeAction :: CodeAction -> Session ()
422 executeCodeAction action = do
423 maybe (return ()) handleEdit $ action ^. edit
424 maybe (return ()) executeCommand $ action ^. command
426 where handleEdit :: WorkspaceEdit -> Session ()
428 -- Its ok to pass in dummy parameters here as they aren't used
429 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
430 in updateState (ReqApplyWorkspaceEdit req)
432 -- | Adds the current version to the document, as tracked by the session.
433 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
434 getVersionedDoc (TextDocumentIdentifier uri) = do
437 case fs Map.!? uri of
438 Just (VirtualFile v _) -> Just v
440 return (VersionedTextDocumentIdentifier uri ver)
442 -- | Applys an edit to the document and returns the updated document version.
443 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
444 applyEdit doc edit = do
446 verDoc <- getVersionedDoc doc
448 caps <- asks sessionCapabilities
450 let supportsDocChanges = fromMaybe False $ do
451 let C.ClientCapabilities mWorkspace _ _ = caps
452 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
453 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
456 let wEdit = if supportsDocChanges
458 let docEdit = TextDocumentEdit verDoc (List [edit])
459 in WorkspaceEdit Nothing (Just (List [docEdit]))
461 let changes = HashMap.singleton (doc ^. uri) (List [edit])
462 in WorkspaceEdit (Just changes) Nothing
464 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
465 updateState (ReqApplyWorkspaceEdit req)
467 -- version may have changed
470 -- | Returns the completions for the position in the document.
471 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
472 getCompletions doc pos = do
473 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
475 case getResponseResult rsp of
476 Completions (List items) -> return items
477 CompletionList (CompletionListType _ (List items)) -> return items
479 -- | Returns the references for the position in the document.
480 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
481 -> Position -- ^ The position to lookup.
482 -> Bool -- ^ Whether to include declarations as references.
483 -> Session [Location] -- ^ The locations of the references.
484 getReferences doc pos inclDecl =
485 let ctx = ReferenceContext inclDecl
486 params = ReferenceParams doc pos ctx
487 in getResponseResult <$> request TextDocumentReferences params
489 -- | Returns the definition(s) for the term at the specified position.
490 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
491 -> Position -- ^ The position the term is at.
492 -> Session [Location] -- ^ The location(s) of the definitions
493 getDefinitions doc pos =
494 let params = TextDocumentPositionParams doc pos
495 in getResponseResult <$> request TextDocumentDefinition params
497 -- | Renames the term at the specified position.
498 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
499 rename doc pos newName = do
500 let params = RenameParams doc pos (T.pack newName)
501 rsp <- request TextDocumentRename params :: Session RenameResponse
502 let wEdit = getResponseResult rsp
503 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
504 updateState (ReqApplyWorkspaceEdit req)
506 -- | Returns the hover information at the specified position.
507 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
509 let params = TextDocumentPositionParams doc pos
510 in getResponseResult <$> request TextDocumentHover params
512 -- | Returns the highlighted occurences of the term at the specified position
513 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
514 getHighlights doc pos =
515 let params = TextDocumentPositionParams doc pos
516 in getResponseResult <$> request TextDocumentDocumentHighlight params
518 -- | Checks the response for errors and throws an exception if needed.
519 -- Returns the result if successful.
520 getResponseResult :: ResponseMessage a -> a
521 getResponseResult rsp = fromMaybe exc (rsp ^. result)
522 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
523 (fromJust $ rsp ^. LSP.error)
525 -- | Applies formatting to the specified document.
526 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
527 formatDoc doc opts = do
528 let params = DocumentFormattingParams doc opts
529 edits <- getResponseResult <$> request TextDocumentFormatting params
530 applyTextEdits doc edits
532 -- | Applies formatting to the specified range in a document.
533 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
534 formatRange doc opts range = do
535 let params = DocumentRangeFormattingParams doc range opts
536 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
537 applyTextEdits doc edits
539 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
540 applyTextEdits doc edits =
541 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
542 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
543 in updateState (ReqApplyWorkspaceEdit req)