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
12 -- A framework for testing
13 -- <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>
16 module Language.Haskell.LSP.Test
20 , runSessionWithHandles
21 , runSessionWithConfig
25 , SessionException(..)
45 , publishDiagnosticsNotification
61 , waitForDiagnosticsSource
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 hiding (id, capabilities, message)
101 import qualified Language.Haskell.LSP.Types as LSP
102 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
103 import Language.Haskell.LSP.Messages
104 import Language.Haskell.LSP.VFS
105 import Language.Haskell.LSP.Test.Capabilities
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 Yi.Rope as Rope
117 -- | Starts a new session.
118 runSession :: String -- ^ The command to run the server.
119 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
120 -> FilePath -- ^ The filepath to the root directory for the session.
121 -> Session a -- ^ The session to run.
123 runSession = runSessionWithConfig def
125 -- | Starts a new sesion with a client with the specified capabilities.
126 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
127 -> String -- ^ The command to run the server.
128 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
129 -> FilePath -- ^ The filepath to the root directory for the session.
130 -> Session a -- ^ The session to run.
132 runSessionWithConfig config serverExe caps rootDir session = do
133 pid <- getCurrentProcessID
134 absRootDir <- canonicalizePath rootDir
136 let initializeParams = InitializeParams (Just pid)
137 (Just $ T.pack absRootDir)
138 (Just $ filePathToUri absRootDir)
142 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
143 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
145 -- Wrap the session around initialize and shutdown calls
146 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
148 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
150 initRspVar <- initRsp <$> ask
151 liftIO $ putMVar initRspVar initRspMsg
153 sendNotification Initialized InitializedParams
155 -- Run the actual test
158 sendNotification Exit ExitParams
162 -- | Listens to the server output, makes sure it matches the record and
163 -- signals any semaphores
164 listenServer :: Handle -> SessionContext -> IO ()
165 listenServer serverOut context = do
166 msgBytes <- getNextMessage serverOut
168 reqMap <- readMVar $ requestMap context
170 let msg = decodeFromServerMsg reqMap msgBytes
171 writeChan (messageChan context) (ServerMessage msg)
173 listenServer serverOut context
175 -- | The current text contents of a document.
176 documentContents :: TextDocumentIdentifier -> Session T.Text
177 documentContents doc = do
179 let file = vfs Map.! (doc ^. uri)
180 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
182 -- | Parses an ApplyEditRequest, checks that it is for the passed document
183 -- and returns the new content
184 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
185 getDocumentEdit doc = do
186 req <- message :: Session ApplyWorkspaceEditRequest
188 unless (checkDocumentChanges req || checkChanges req) $
189 liftIO $ throw (IncorrectApplyEditRequest (show req))
193 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
194 checkDocumentChanges req =
195 let changes = req ^. params . edit . documentChanges
196 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
198 Just docs -> (doc ^. uri) `elem` docs
200 checkChanges :: ApplyWorkspaceEditRequest -> Bool
202 let mMap = req ^. params . edit . changes
203 in maybe False (HashMap.member (doc ^. uri)) mMap
205 -- | Sends a request to the server and waits for its response.
207 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
209 -- Note: will skip any messages in between the request and the response.
210 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
211 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
213 -- | Send a request to the server and wait for its response,
215 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
216 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
218 -- | Sends a request to the server without waiting on the response.
221 => ClientMethod -- ^ The request method.
222 -> params -- ^ The request parameters.
223 -> Session LspId -- ^ The id of the request that was sent.
224 sendRequest' method params = do
225 id <- curReqId <$> get
226 modify $ \c -> c { curReqId = nextId id }
228 let req = RequestMessage' "2.0" id method params
230 -- Update the request map
231 reqMap <- requestMap <$> ask
232 liftIO $ modifyMVar_ reqMap $
233 \r -> return $ updateRequestMap r id method
239 where nextId (IdInt i) = IdInt (i + 1)
240 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
242 -- | A custom type for request message that doesn't
243 -- need a response type, allows us to infer the request
244 -- message type without using proxies.
245 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
247 instance ToJSON a => ToJSON (RequestMessage' a) where
248 toJSON (RequestMessage' rpc id method params) =
249 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
252 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
253 sendRequestMessage req = do
254 -- Update the request map
255 reqMap <- requestMap <$> ask
256 liftIO $ modifyMVar_ reqMap $
257 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
261 -- | Sends a notification to the server.
262 sendNotification :: ToJSON a
263 => ClientMethod -- ^ The notification method.
264 -> a -- ^ The notification parameters.
267 -- | Open a virtual file if we send a did open text document notification
268 sendNotification TextDocumentDidOpen params = do
269 let params' = fromJust $ decode $ encode params
270 n :: DidOpenTextDocumentNotification
271 n = NotificationMessage "2.0" TextDocumentDidOpen params'
272 oldVFS <- vfs <$> get
273 newVFS <- liftIO $ openVFS oldVFS n
274 modify (\s -> s { vfs = newVFS })
277 -- | Close a virtual file if we send a close text document notification
278 sendNotification TextDocumentDidClose params = do
279 let params' = fromJust $ decode $ encode params
280 n :: DidCloseTextDocumentNotification
281 n = NotificationMessage "2.0" TextDocumentDidClose params'
282 oldVFS <- vfs <$> get
283 newVFS <- liftIO $ closeVFS oldVFS n
284 modify (\s -> s { vfs = newVFS })
287 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
289 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
290 sendNotification' = sendMessage
292 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
293 sendResponse = sendMessage
295 -- | Returns the initialize response that was received from the server.
296 -- The initialize requests and responses are not included the session,
297 -- so if you need to test it use this.
298 initializeResponse :: Session InitializeResponse
299 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
301 -- | Opens a text document and sends a notification to the client.
302 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
303 openDoc file languageId = do
304 item <- getDocItem file languageId
305 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
306 TextDocumentIdentifier <$> getDocUri file
308 -- | Reads in a text document as the first version.
309 getDocItem :: FilePath -- ^ The path to the text document to read in.
310 -> String -- ^ The language ID, e.g "haskell" for .hs files.
311 -> Session TextDocumentItem
312 getDocItem file languageId = do
314 let fp = rootDir context </> file
315 contents <- liftIO $ T.readFile fp
316 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
318 -- | Closes a text document and sends a notification to the client.
319 closeDoc :: TextDocumentIdentifier -> Session ()
321 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
322 sendNotification TextDocumentDidClose params
324 oldVfs <- vfs <$> get
325 let notif = NotificationMessage "" TextDocumentDidClose params
326 newVfs <- liftIO $ closeVFS oldVfs notif
327 modify $ \s -> s { vfs = newVfs }
329 -- | Gets the Uri for the file corrected to the session directory.
330 getDocUri :: FilePath -> Session Uri
333 let fp = rootDir context </> file
334 return $ filePathToUri fp
336 -- | Waits for diagnostics to be published and returns them.
337 waitForDiagnostics :: Session [Diagnostic]
338 waitForDiagnostics = do
339 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
340 let (List diags) = diagsNot ^. params . LSP.diagnostics
343 waitForDiagnosticsSource :: String -> Session [Diagnostic]
344 waitForDiagnosticsSource src = do
345 diags <- waitForDiagnostics
346 let res = filter matches diags
348 then waitForDiagnosticsSource src
351 matches :: Diagnostic -> Bool
352 matches d = d ^. source == Just (T.pack src)
354 -- | Expects a 'PublishDiagnosticsNotification' and throws an
355 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
357 noDiagnostics :: Session ()
359 diagsNot <- message :: Session PublishDiagnosticsNotification
360 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
362 -- | Returns the symbols in a document.
363 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
364 getDocumentSymbols doc = do
365 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
366 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
367 let (Just (List symbols)) = mRes
370 -- | Returns all the code actions in a document by
371 -- querying the code actions at each of the current
372 -- diagnostics' positions.
373 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
374 getAllCodeActions doc = do
375 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
376 let ctx = CodeActionContext (List curDiags) Nothing
378 foldM (go ctx) [] curDiags
381 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
383 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
386 Just e -> throw (UnexpectedResponseError rspLid e)
388 let Just (List cmdOrCAs) = mRes
389 in return (acc ++ cmdOrCAs)
391 -- | Executes a command.
392 executeCommand :: Command -> Session ()
393 executeCommand cmd = do
394 let args = decode $ encode $ fromJust $ cmd ^. arguments
395 execParams = ExecuteCommandParams (cmd ^. command) args
396 sendRequest_ WorkspaceExecuteCommand execParams
398 -- | Executes a code action.
399 -- Matching with the specification, if a code action
400 -- contains both an edit and a command, the edit will
402 executeCodeAction :: CodeAction -> Session ()
403 executeCodeAction action = do
404 maybe (return ()) handleEdit $ action ^. edit
405 maybe (return ()) executeCommand $ action ^. command
407 where handleEdit :: WorkspaceEdit -> Session ()
409 -- Its ok to pass in dummy parameters here as they aren't used
410 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
411 in updateState (ReqApplyWorkspaceEdit req)
413 -- | Adds the current version to the document, as tracked by the session.
414 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
415 getVersionedDoc (TextDocumentIdentifier uri) = do
418 case fs Map.!? uri of
419 Just (VirtualFile v _) -> Just v
421 return (VersionedTextDocumentIdentifier uri ver)
423 -- | Applys an edit to the document and returns the updated document version.
424 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
425 applyEdit doc edit = do
427 verDoc <- getVersionedDoc doc
429 caps <- asks sessionCapabilities
431 let supportsDocChanges = fromMaybe False $ do
432 let LSP.ClientCapabilities mWorkspace _ _ = caps
433 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
434 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
437 let wEdit = if supportsDocChanges
439 let docEdit = TextDocumentEdit verDoc (List [edit])
440 in WorkspaceEdit Nothing (Just (List [docEdit]))
442 let changes = HashMap.singleton (doc ^. uri) (List [edit])
443 in WorkspaceEdit (Just changes) Nothing
445 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
446 updateState (ReqApplyWorkspaceEdit req)
448 -- version may have changed
451 -- | Returns the completions for the position in the document.
452 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
453 getCompletions doc pos = do
454 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
456 case getResponseResult rsp of
457 Completions (List items) -> return items
458 CompletionList (CompletionListType _ (List items)) -> return items
460 -- | Returns the references for the position in the document.
461 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
462 -> Position -- ^ The position to lookup.
463 -> Bool -- ^ Whether to include declarations as references.
464 -> Session [Location] -- ^ The locations of the references.
465 getReferences doc pos inclDecl =
466 let ctx = ReferenceContext inclDecl
467 params = ReferenceParams doc pos ctx
468 in getResponseResult <$> sendRequest TextDocumentReferences params
470 -- | Returns the definition(s) for the term at the specified position.
471 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
472 -> Position -- ^ The position the term is at.
473 -> Session [Location] -- ^ The location(s) of the definitions
474 getDefinitions doc pos =
475 let params = TextDocumentPositionParams doc pos
476 in getResponseResult <$> sendRequest TextDocumentDefinition params
478 -- ^ Renames the term at the specified position.
479 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
480 rename doc pos newName = do
481 let params = RenameParams doc pos (T.pack newName)
482 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
483 let wEdit = getResponseResult rsp
484 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
485 updateState (ReqApplyWorkspaceEdit req)
487 -- | Returns the hover information at the specified position.
488 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
490 let params = TextDocumentPositionParams doc pos
491 in getResponseResult <$> sendRequest TextDocumentHover params
493 -- | Returns the highlighted occurences of the term at the specified position
494 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
495 getHighlights doc pos =
496 let params = TextDocumentPositionParams doc pos
497 in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params
499 -- | Checks the response for errors and throws an exception if needed.
500 -- Returns the result if successful.
501 getResponseResult :: ResponseMessage a -> a
502 getResponseResult rsp = fromMaybe exc (rsp ^. result)
503 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
504 (fromJust $ rsp ^. LSP.error)
506 -- | Applies formatting to the specified document.
507 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
508 formatDoc doc opts = do
509 let params = DocumentFormattingParams doc opts
510 edits <- getResponseResult <$> sendRequest TextDocumentFormatting params
511 applyTextEdits doc edits
513 -- | Applies formatting to the specified range in a document.
514 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
515 formatRange doc opts range = do
516 let params = DocumentRangeFormattingParams doc range opts
517 edits <- getResponseResult <$> sendRequest TextDocumentRangeFormatting params
518 applyTextEdits doc edits
520 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
521 applyTextEdits doc edits =
522 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
523 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
524 in updateState (ReqApplyWorkspaceEdit req)