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
24 , SessionException(..)
42 , publishDiagnosticsNotification
58 , waitForDiagnosticsSource
84 import Control.Applicative.Combinators
85 import Control.Concurrent
87 import Control.Monad.IO.Class
88 import Control.Exception
89 import Control.Lens hiding ((.=), List)
90 import qualified Data.Text as T
91 import qualified Data.Text.IO as T
94 import qualified Data.HashMap.Strict as HashMap
95 import qualified Data.Map as Map
97 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
98 import qualified Language.Haskell.LSP.Types as LSP
99 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
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 Yi.Rope as Rope
113 -- | Starts a new session.
114 runSession :: String -- ^ The command to run the server.
115 -> FilePath -- ^ The filepath to the root directory for the session.
116 -> Session a -- ^ The session to run.
118 runSession = runSessionWithConfig def
120 -- | Starts a new sesion with a client with the specified capabilities.
121 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
122 -> String -- ^ The command to run the server.
123 -> FilePath -- ^ The filepath to the root directory for the session.
124 -> Session a -- ^ The session to run.
126 runSessionWithConfig config serverExe rootDir session = do
127 pid <- getCurrentProcessID
128 absRootDir <- canonicalizePath rootDir
130 let initializeParams = InitializeParams (Just pid)
131 (Just $ T.pack absRootDir)
132 (Just $ filePathToUri absRootDir)
134 (capabilities config)
136 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
137 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
139 -- Wrap the session around initialize and shutdown calls
140 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
142 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
144 initRspVar <- initRsp <$> ask
145 liftIO $ putMVar initRspVar initRspMsg
147 sendNotification Initialized InitializedParams
149 -- Run the actual test
152 sendNotification Exit ExitParams
156 -- | Listens to the server output, makes sure it matches the record and
157 -- signals any semaphores
158 listenServer :: Handle -> SessionContext -> IO ()
159 listenServer serverOut context = do
160 msgBytes <- getNextMessage serverOut
162 reqMap <- readMVar $ requestMap context
164 let msg = decodeFromServerMsg reqMap msgBytes
165 writeChan (messageChan context) (ServerMessage msg)
167 listenServer serverOut context
169 -- | The current text contents of a document.
170 documentContents :: TextDocumentIdentifier -> Session T.Text
171 documentContents doc = do
173 let file = vfs Map.! (doc ^. uri)
174 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
176 -- | Parses an ApplyEditRequest, checks that it is for the passed document
177 -- and returns the new content
178 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
179 getDocumentEdit doc = do
180 req <- message :: Session ApplyWorkspaceEditRequest
182 unless (checkDocumentChanges req || checkChanges req) $
183 liftIO $ throw (IncorrectApplyEditRequest (show req))
187 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
188 checkDocumentChanges req =
189 let changes = req ^. params . edit . documentChanges
190 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
192 Just docs -> (doc ^. uri) `elem` docs
194 checkChanges :: ApplyWorkspaceEditRequest -> Bool
196 let mMap = req ^. params . edit . changes
197 in maybe False (HashMap.member (doc ^. uri)) mMap
199 -- | Sends a request to the server and waits for its response.
201 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
203 -- Note: will skip any messages in between the request and the response.
204 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
205 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
207 -- | Send a request to the server and wait for its response,
209 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
210 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
212 -- | Sends a request to the server without waiting on the response.
215 => ClientMethod -- ^ The request method.
216 -> params -- ^ The request parameters.
217 -> Session LspId -- ^ The id of the request that was sent.
218 sendRequest' method params = do
219 id <- curReqId <$> get
220 modify $ \c -> c { curReqId = nextId id }
222 let req = RequestMessage' "2.0" id method params
224 -- Update the request map
225 reqMap <- requestMap <$> ask
226 liftIO $ modifyMVar_ reqMap $
227 \r -> return $ updateRequestMap r id method
233 where nextId (IdInt i) = IdInt (i + 1)
234 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
236 -- | A custom type for request message that doesn't
237 -- need a response type, allows us to infer the request
238 -- message type without using proxies.
239 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
241 instance ToJSON a => ToJSON (RequestMessage' a) where
242 toJSON (RequestMessage' rpc id method params) =
243 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
246 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
247 sendRequestMessage req = do
248 -- Update the request map
249 reqMap <- requestMap <$> ask
250 liftIO $ modifyMVar_ reqMap $
251 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
255 -- | Sends a notification to the server.
256 sendNotification :: ToJSON a
257 => ClientMethod -- ^ The notification method.
258 -> a -- ^ The notification parameters.
261 -- | Open a virtual file if we send a did open text document notification
262 sendNotification TextDocumentDidOpen params = do
263 let params' = fromJust $ decode $ encode params
264 n :: DidOpenTextDocumentNotification
265 n = NotificationMessage "2.0" TextDocumentDidOpen params'
266 oldVFS <- vfs <$> get
267 newVFS <- liftIO $ openVFS oldVFS n
268 modify (\s -> s { vfs = newVFS })
271 -- | Close a virtual file if we send a close text document notification
272 sendNotification TextDocumentDidClose params = do
273 let params' = fromJust $ decode $ encode params
274 n :: DidCloseTextDocumentNotification
275 n = NotificationMessage "2.0" TextDocumentDidClose params'
276 oldVFS <- vfs <$> get
277 newVFS <- liftIO $ closeVFS oldVFS n
278 modify (\s -> s { vfs = newVFS })
281 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
283 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
284 sendNotification' = sendMessage
286 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
287 sendResponse = sendMessage
289 -- | Returns the initialize response that was received from the server.
290 -- The initialize requests and responses are not included the session,
291 -- so if you need to test it use this.
292 initializeResponse :: Session InitializeResponse
293 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
295 -- | Opens a text document and sends a notification to the client.
296 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
297 openDoc file languageId = do
298 item <- getDocItem file languageId
299 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
300 TextDocumentIdentifier <$> getDocUri file
302 -- | Reads in a text document as the first version.
303 getDocItem :: FilePath -- ^ The path to the text document to read in.
304 -> String -- ^ The language ID, e.g "haskell" for .hs files.
305 -> Session TextDocumentItem
306 getDocItem file languageId = do
308 let fp = rootDir context </> file
309 contents <- liftIO $ T.readFile fp
310 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
312 -- | Closes a text document and sends a notification to the client.
313 closeDoc :: TextDocumentIdentifier -> Session ()
315 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
316 sendNotification TextDocumentDidClose params
318 oldVfs <- vfs <$> get
319 let notif = NotificationMessage "" TextDocumentDidClose params
320 newVfs <- liftIO $ closeVFS oldVfs notif
321 modify $ \s -> s { vfs = newVfs }
323 -- | Gets the Uri for the file corrected to the session directory.
324 getDocUri :: FilePath -> Session Uri
327 let fp = rootDir context </> file
328 return $ filePathToUri fp
330 -- | Waits for diagnostics to be published and returns them.
331 waitForDiagnostics :: Session [Diagnostic]
332 waitForDiagnostics = do
333 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
334 let (List diags) = diagsNot ^. params . LSP.diagnostics
337 waitForDiagnosticsSource :: String -> Session [Diagnostic]
338 waitForDiagnosticsSource src = do
339 diags <- waitForDiagnostics
340 let res = filter matches diags
342 then waitForDiagnosticsSource src
345 matches :: Diagnostic -> Bool
346 matches d = d ^. source == Just (T.pack src)
348 -- | Expects a 'PublishDiagnosticsNotification' and throws an
349 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
351 noDiagnostics :: Session ()
353 diagsNot <- message :: Session PublishDiagnosticsNotification
354 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
356 -- | Returns the symbols in a document.
357 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
358 getDocumentSymbols doc = do
359 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
360 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
361 let (Just (List symbols)) = mRes
364 -- | Returns all the code actions in a document by
365 -- querying the code actions at each of the current
366 -- diagnostics' positions.
367 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
368 getAllCodeActions doc = do
369 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
370 let ctx = CodeActionContext (List curDiags) Nothing
372 foldM (go ctx) [] curDiags
375 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
377 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
380 Just e -> throw (UnexpectedResponseError rspLid e)
382 let Just (List cmdOrCAs) = mRes
383 in return (acc ++ cmdOrCAs)
385 -- | Executes a command.
386 executeCommand :: Command -> Session ()
387 executeCommand cmd = do
388 let args = decode $ encode $ fromJust $ cmd ^. arguments
389 execParams = ExecuteCommandParams (cmd ^. command) args
390 sendRequest_ WorkspaceExecuteCommand execParams
392 -- | Executes a code action.
393 -- Matching with the specification, if a code action
394 -- contains both an edit and a command, the edit will
396 executeCodeAction :: CodeAction -> Session ()
397 executeCodeAction action = do
398 maybe (return ()) handleEdit $ action ^. edit
399 maybe (return ()) executeCommand $ action ^. command
401 where handleEdit :: WorkspaceEdit -> Session ()
403 -- Its ok to pass in dummy parameters here as they aren't used
404 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
405 in updateState (ReqApplyWorkspaceEdit req)
407 -- | Adds the current version to the document, as tracked by the session.
408 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
409 getVersionedDoc (TextDocumentIdentifier uri) = do
412 case fs Map.!? uri of
413 Just (VirtualFile v _) -> Just v
415 return (VersionedTextDocumentIdentifier uri ver)
417 -- | Applys an edit to the document and returns the updated document version.
418 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
419 applyEdit doc edit = do
421 verDoc <- getVersionedDoc doc
423 caps <- asks (capabilities . config)
425 let supportsDocChanges = fromMaybe False $ do
426 let LSP.ClientCapabilities mWorkspace _ _ = caps
427 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
428 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
431 let wEdit = if supportsDocChanges
433 let docEdit = TextDocumentEdit verDoc (List [edit])
434 in WorkspaceEdit Nothing (Just (List [docEdit]))
436 let changes = HashMap.singleton (doc ^. uri) (List [edit])
437 in WorkspaceEdit (Just changes) Nothing
439 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
440 updateState (ReqApplyWorkspaceEdit req)
442 -- version may have changed
445 -- | Returns the completions for the position in the document.
446 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
447 getCompletions doc pos = do
448 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
450 case getResponseResult rsp of
451 Completions (List items) -> return items
452 CompletionList (CompletionListType _ (List items)) -> return items
454 -- | Returns the references for the position in the document.
455 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
456 -> Position -- ^ The position to lookup.
457 -> Bool -- ^ Whether to include declarations as references.
458 -> Session [Location] -- ^ The locations of the references.
459 getReferences doc pos inclDecl =
460 let ctx = ReferenceContext inclDecl
461 params = ReferenceParams doc pos ctx
462 in getResponseResult <$> sendRequest TextDocumentReferences params
464 -- | Returns the definition(s) for the term at the specified position.
465 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
466 -> Position -- ^ The position the term is at.
467 -> Session [Location] -- ^ The location(s) of the definitions
468 getDefinitions doc pos =
469 let params = TextDocumentPositionParams doc pos
470 in getResponseResult <$> sendRequest TextDocumentDefinition params
472 -- ^ Renames the term at the specified position.
473 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
474 rename doc pos newName = do
475 let params = RenameParams doc pos (T.pack newName)
476 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
477 let wEdit = getResponseResult rsp
478 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
479 updateState (ReqApplyWorkspaceEdit req)
481 -- | Returns the hover information at the specified position.
482 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
484 let params = TextDocumentPositionParams doc pos
485 in getResponseResult <$> sendRequest TextDocumentHover params
487 -- | Returns the highlighted occurences of the term at the specified position
488 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
489 getHighlights doc pos =
490 let params = TextDocumentPositionParams doc pos
491 in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params
493 -- | Checks the response for errors and throws an exception if needed.
494 -- Returns the result if successful.
495 getResponseResult :: ResponseMessage a -> a
496 getResponseResult rsp = fromMaybe exc (rsp ^. result)
497 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
498 (fromJust $ rsp ^. LSP.error)
500 -- | Applies formatting to the specified document.
501 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
502 formatDoc doc opts = do
503 let params = DocumentFormattingParams doc opts
504 edits <- getResponseResult <$> sendRequest TextDocumentFormatting params
505 applyTextEdits doc edits
507 -- | Applies formatting to the specified range in a document.
508 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
509 formatRange doc opts range = do
510 let params = DocumentRangeFormattingParams doc range opts
511 edits <- getResponseResult <$> sendRequest TextDocumentRangeFormatting params
512 applyTextEdits doc edits
514 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
515 applyTextEdits doc edits =
516 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
517 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
518 in updateState (ReqApplyWorkspaceEdit req)