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
82 import Control.Applicative.Combinators
83 import Control.Concurrent
85 import Control.Monad.IO.Class
86 import Control.Exception
87 import Control.Lens hiding ((.=), List)
88 import qualified Data.Text as T
89 import qualified Data.Text.IO as T
92 import qualified Data.HashMap.Strict as HashMap
93 import qualified Data.Map as Map
95 import Language.Haskell.LSP.Types
96 import Language.Haskell.LSP.Types.Lens hiding
97 (id, capabilities, message, executeCommand, applyEdit, rename)
98 import qualified Language.Haskell.LSP.Types.Lens as LSP
99 import qualified Language.Haskell.LSP.Types.Capabilities as C
100 import Language.Haskell.LSP.Messages
101 import Language.Haskell.LSP.VFS
102 import Language.Haskell.LSP.Test.Compat
103 import Language.Haskell.LSP.Test.Decoding
104 import Language.Haskell.LSP.Test.Exceptions
105 import Language.Haskell.LSP.Test.Parsing
106 import Language.Haskell.LSP.Test.Session
107 import Language.Haskell.LSP.Test.Server
109 import System.Directory
110 import System.FilePath
111 import qualified Data.Rope.UTF16 as Rope
113 -- | Starts a new session.
115 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
116 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
117 -- > diags <- waitForDiagnostics
118 -- > let pos = Position 12 5
119 -- > params = TextDocumentPositionParams doc
120 -- > hover <- request TextDocumentHover params
121 runSession :: String -- ^ The command to run the server.
122 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
123 -> FilePath -- ^ The filepath to the root directory for the session.
124 -> Session a -- ^ The session to run.
126 runSession = runSessionWithConfig def
128 -- | Starts a new sesion with a custom configuration.
129 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
130 -> String -- ^ The command to run the server.
131 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
132 -> FilePath -- ^ The filepath to the root directory for the session.
133 -> Session a -- ^ The session to run.
135 runSessionWithConfig config serverExe caps rootDir session = do
136 pid <- getCurrentProcessID
137 absRootDir <- canonicalizePath rootDir
139 let initializeParams = InitializeParams (Just pid)
140 (Just $ T.pack absRootDir)
141 (Just $ filePathToUri absRootDir)
146 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
147 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
149 -- Wrap the session around initialize and shutdown calls
150 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
152 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
154 initRspVar <- initRsp <$> ask
155 liftIO $ putMVar initRspVar initRspMsg
157 sendNotification Initialized InitializedParams
159 case lspConfig config of
160 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
163 -- Run the actual test
166 sendNotification Exit ExitParams
170 -- | Listens to the server output, makes sure it matches the record and
171 -- signals any semaphores
172 listenServer :: Handle -> SessionContext -> IO ()
173 listenServer serverOut context = do
174 msgBytes <- getNextMessage serverOut
176 reqMap <- readMVar $ requestMap context
178 let msg = decodeFromServerMsg reqMap msgBytes
179 writeChan (messageChan context) (ServerMessage msg)
181 listenServer serverOut context
183 -- | The current text contents of a document.
184 documentContents :: TextDocumentIdentifier -> Session T.Text
185 documentContents doc = do
187 let file = vfs Map.! (doc ^. uri)
188 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
190 -- | Parses an ApplyEditRequest, checks that it is for the passed document
191 -- and returns the new content
192 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
193 getDocumentEdit doc = do
194 req <- message :: Session ApplyWorkspaceEditRequest
196 unless (checkDocumentChanges req || checkChanges req) $
197 liftIO $ throw (IncorrectApplyEditRequest (show req))
201 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
202 checkDocumentChanges req =
203 let changes = req ^. params . edit . documentChanges
204 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
206 Just docs -> (doc ^. uri) `elem` docs
208 checkChanges :: ApplyWorkspaceEditRequest -> Bool
210 let mMap = req ^. params . edit . changes
211 in maybe False (HashMap.member (doc ^. uri)) mMap
213 -- | Sends a request to the server and waits for its response.
214 -- Will skip any messages in between the request and the response
216 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
218 -- Note: will skip any messages in between the request and the response.
219 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
220 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
222 -- | The same as 'sendRequest', but discard the response.
223 request_ :: ToJSON params => ClientMethod -> params -> Session ()
224 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
226 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
229 => ClientMethod -- ^ The request method.
230 -> params -- ^ The request parameters.
231 -> Session LspId -- ^ The id of the request that was sent.
232 sendRequest method params = do
233 id <- curReqId <$> get
234 modify $ \c -> c { curReqId = nextId id }
236 let req = RequestMessage' "2.0" id method params
238 -- Update the request map
239 reqMap <- requestMap <$> ask
240 liftIO $ modifyMVar_ reqMap $
241 \r -> return $ updateRequestMap r id method
247 where nextId (IdInt i) = IdInt (i + 1)
248 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
250 -- | A custom type for request message that doesn't
251 -- need a response type, allows us to infer the request
252 -- message type without using proxies.
253 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
255 instance ToJSON a => ToJSON (RequestMessage' a) where
256 toJSON (RequestMessage' rpc id method params) =
257 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
260 -- | Sends a notification to the server.
261 sendNotification :: ToJSON a
262 => ClientMethod -- ^ The notification method.
263 -> a -- ^ The notification parameters.
266 -- Open a virtual file if we send a did open text document notification
267 sendNotification TextDocumentDidOpen params = do
268 let params' = fromJust $ decode $ encode params
269 n :: DidOpenTextDocumentNotification
270 n = NotificationMessage "2.0" TextDocumentDidOpen params'
271 oldVFS <- vfs <$> get
272 newVFS <- liftIO $ openVFS oldVFS n
273 modify (\s -> s { vfs = newVFS })
276 -- Close a virtual file if we send a close text document notification
277 sendNotification TextDocumentDidClose params = do
278 let params' = fromJust $ decode $ encode params
279 n :: DidCloseTextDocumentNotification
280 n = NotificationMessage "2.0" TextDocumentDidClose params'
281 oldVFS <- vfs <$> get
282 newVFS <- liftIO $ closeVFS oldVFS n
283 modify (\s -> s { vfs = newVFS })
286 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
288 -- | Sends a response to the server.
289 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
290 sendResponse = sendMessage
292 -- | Returns the initialize response that was received from the server.
293 -- The initialize requests and responses are not included the session,
294 -- so if you need to test it use this.
295 initializeResponse :: Session InitializeResponse
296 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
298 -- | Opens a text document and sends a notification to the client.
299 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
300 openDoc file languageId = do
301 item <- getDocItem file languageId
302 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
303 TextDocumentIdentifier <$> getDocUri file
305 -- | Reads in a text document as the first version.
306 getDocItem :: FilePath -- ^ The path to the text document to read in.
307 -> String -- ^ The language ID, e.g "haskell" for .hs files.
308 -> Session TextDocumentItem
309 getDocItem file languageId = do
311 let fp = rootDir context </> file
312 contents <- liftIO $ T.readFile fp
313 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
315 -- | Closes a text document and sends a notification to the client.
316 closeDoc :: TextDocumentIdentifier -> Session ()
318 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
319 sendNotification TextDocumentDidClose params
321 oldVfs <- vfs <$> get
322 let notif = NotificationMessage "" TextDocumentDidClose params
323 newVfs <- liftIO $ closeVFS oldVfs notif
324 modify $ \s -> s { vfs = newVfs }
326 -- | Gets the Uri for the file corrected to the session directory.
327 getDocUri :: FilePath -> Session Uri
330 let fp = rootDir context </> file
331 return $ filePathToUri fp
333 -- | Waits for diagnostics to be published and returns them.
334 waitForDiagnostics :: Session [Diagnostic]
335 waitForDiagnostics = do
336 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
337 let (List diags) = diagsNot ^. params . LSP.diagnostics
340 -- | The same as 'waitForDiagnostics', but will only match a specific
341 -- 'Language.Haskell.LSP.Types._source'.
342 waitForDiagnosticsSource :: String -> Session [Diagnostic]
343 waitForDiagnosticsSource src = do
344 diags <- waitForDiagnostics
345 let res = filter matches diags
347 then waitForDiagnosticsSource src
350 matches :: Diagnostic -> Bool
351 matches d = d ^. source == Just (T.pack src)
353 -- | Expects a 'PublishDiagnosticsNotification' and throws an
354 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
356 noDiagnostics :: Session ()
358 diagsNot <- message :: Session PublishDiagnosticsNotification
359 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
361 -- | Returns the symbols in a document.
362 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
363 getDocumentSymbols doc = do
364 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
365 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
367 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
368 Just (DSSymbolInformation (List xs)) -> return (Right xs)
369 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
371 -- | Returns the code actions in the specified range.
372 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
373 getCodeActions doc range = do
374 ctx <- getCodeActionContext doc
375 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
377 case rsp ^. result of
378 Just (List xs) -> return xs
379 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
381 -- | Returns all the code actions in a document by
382 -- querying the code actions at each of the current
383 -- diagnostics' positions.
384 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
385 getAllCodeActions doc = do
386 ctx <- getCodeActionContext doc
388 foldM (go ctx) [] =<< getCurrentDiagnostics doc
391 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
393 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
396 Just e -> throw (UnexpectedResponseError rspLid e)
398 let Just (List cmdOrCAs) = mRes
399 in return (acc ++ cmdOrCAs)
401 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
402 getCodeActionContext doc = do
403 curDiags <- getCurrentDiagnostics doc
404 return $ CodeActionContext (List curDiags) Nothing
406 -- | Returns the current diagnostics that have been sent to the client.
407 -- Note that this does not wait for more to come in.
408 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
409 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
411 -- | Executes a command.
412 executeCommand :: Command -> Session ()
413 executeCommand cmd = do
414 let args = decode $ encode $ fromJust $ cmd ^. arguments
415 execParams = ExecuteCommandParams (cmd ^. command) args
416 request_ WorkspaceExecuteCommand execParams
418 -- | Executes a code action.
419 -- Matching with the specification, if a code action
420 -- contains both an edit and a command, the edit will
422 executeCodeAction :: CodeAction -> Session ()
423 executeCodeAction action = do
424 maybe (return ()) handleEdit $ action ^. edit
425 maybe (return ()) executeCommand $ action ^. command
427 where handleEdit :: WorkspaceEdit -> Session ()
429 -- Its ok to pass in dummy parameters here as they aren't used
430 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
431 in updateState (ReqApplyWorkspaceEdit req)
433 -- | Adds the current version to the document, as tracked by the session.
434 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
435 getVersionedDoc (TextDocumentIdentifier uri) = do
438 case fs Map.!? uri of
439 Just (VirtualFile v _ _) -> Just v
441 return (VersionedTextDocumentIdentifier uri ver)
443 -- | Applys an edit to the document and returns the updated document version.
444 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
445 applyEdit doc edit = do
447 verDoc <- getVersionedDoc doc
449 caps <- asks sessionCapabilities
451 let supportsDocChanges = fromMaybe False $ do
452 let mWorkspace = C._workspace caps
453 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
454 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
457 let wEdit = if supportsDocChanges
459 let docEdit = TextDocumentEdit verDoc (List [edit])
460 in WorkspaceEdit Nothing (Just (List [docEdit]))
462 let changes = HashMap.singleton (doc ^. uri) (List [edit])
463 in WorkspaceEdit (Just changes) Nothing
465 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
466 updateState (ReqApplyWorkspaceEdit req)
468 -- version may have changed
471 -- | Returns the completions for the position in the document.
472 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
473 getCompletions doc pos = do
474 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
476 case getResponseResult rsp of
477 Completions (List items) -> return items
478 CompletionList (CompletionListType _ (List items)) -> return items
480 -- | Returns the references for the position in the document.
481 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
482 -> Position -- ^ The position to lookup.
483 -> Bool -- ^ Whether to include declarations as references.
484 -> Session [Location] -- ^ The locations of the references.
485 getReferences doc pos inclDecl =
486 let ctx = ReferenceContext inclDecl
487 params = ReferenceParams doc pos ctx
488 in getResponseResult <$> request TextDocumentReferences params
490 -- | Returns the definition(s) for the term at the specified position.
491 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
492 -> Position -- ^ The position the term is at.
493 -> Session [Location] -- ^ The location(s) of the definitions
494 getDefinitions doc pos =
495 let params = TextDocumentPositionParams doc pos
496 in getResponseResult <$> request TextDocumentDefinition params
498 -- | Returns the type definition(s) for the term at the specified position.
499 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
500 -> Position -- ^ The position the term is at.
501 -> Session [Location] -- ^ The location(s) of the definitions
502 getTypeDefinitions doc pos =
503 let params = TextDocumentPositionParams doc pos
504 in getResponseResult <$> request TextDocumentTypeDefinition params
506 -- | Renames the term at the specified position.
507 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
508 rename doc pos newName = do
509 let params = RenameParams doc pos (T.pack newName)
510 rsp <- request TextDocumentRename params :: Session RenameResponse
511 let wEdit = getResponseResult rsp
512 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
513 updateState (ReqApplyWorkspaceEdit req)
515 -- | Returns the hover information at the specified position.
516 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
518 let params = TextDocumentPositionParams doc pos
519 in getResponseResult <$> request TextDocumentHover params
521 -- | Returns the highlighted occurences of the term at the specified position
522 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
523 getHighlights doc pos =
524 let params = TextDocumentPositionParams doc pos
525 in getResponseResult <$> request TextDocumentDocumentHighlight params
527 -- | Checks the response for errors and throws an exception if needed.
528 -- Returns the result if successful.
529 getResponseResult :: ResponseMessage a -> a
530 getResponseResult rsp = fromMaybe exc (rsp ^. result)
531 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
532 (fromJust $ rsp ^. LSP.error)
534 -- | Applies formatting to the specified document.
535 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
536 formatDoc doc opts = do
537 let params = DocumentFormattingParams doc opts
538 edits <- getResponseResult <$> request TextDocumentFormatting params
539 applyTextEdits doc edits
541 -- | Applies formatting to the specified range in a document.
542 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
543 formatRange doc opts range = do
544 let params = DocumentRangeFormattingParams doc range opts
545 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
546 applyTextEdits doc edits
548 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
549 applyTextEdits doc edits =
550 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
551 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
552 in updateState (ReqApplyWorkspaceEdit req)