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 -- Run the actual test
161 sendNotification Exit ExitParams
165 -- | Listens to the server output, makes sure it matches the record and
166 -- signals any semaphores
167 listenServer :: Handle -> SessionContext -> IO ()
168 listenServer serverOut context = do
169 msgBytes <- getNextMessage serverOut
171 reqMap <- readMVar $ requestMap context
173 let msg = decodeFromServerMsg reqMap msgBytes
174 writeChan (messageChan context) (ServerMessage msg)
176 listenServer serverOut context
178 -- | The current text contents of a document.
179 documentContents :: TextDocumentIdentifier -> Session T.Text
180 documentContents doc = do
182 let file = vfs Map.! (doc ^. uri)
183 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
185 -- | Parses an ApplyEditRequest, checks that it is for the passed document
186 -- and returns the new content
187 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
188 getDocumentEdit doc = do
189 req <- message :: Session ApplyWorkspaceEditRequest
191 unless (checkDocumentChanges req || checkChanges req) $
192 liftIO $ throw (IncorrectApplyEditRequest (show req))
196 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
197 checkDocumentChanges req =
198 let changes = req ^. params . edit . documentChanges
199 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
201 Just docs -> (doc ^. uri) `elem` docs
203 checkChanges :: ApplyWorkspaceEditRequest -> Bool
205 let mMap = req ^. params . edit . changes
206 in maybe False (HashMap.member (doc ^. uri)) mMap
208 -- | Sends a request to the server and waits for its response.
209 -- Will skip any messages in between the request and the response
211 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
213 -- Note: will skip any messages in between the request and the response.
214 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
215 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
217 -- | The same as 'sendRequest', but discard the response.
218 request_ :: ToJSON params => ClientMethod -> params -> Session ()
219 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
221 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
224 => ClientMethod -- ^ The request method.
225 -> params -- ^ The request parameters.
226 -> Session LspId -- ^ The id of the request that was sent.
227 sendRequest method params = do
228 id <- curReqId <$> get
229 modify $ \c -> c { curReqId = nextId id }
231 let req = RequestMessage' "2.0" id method params
233 -- Update the request map
234 reqMap <- requestMap <$> ask
235 liftIO $ modifyMVar_ reqMap $
236 \r -> return $ updateRequestMap r id method
242 where nextId (IdInt i) = IdInt (i + 1)
243 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
245 -- | A custom type for request message that doesn't
246 -- need a response type, allows us to infer the request
247 -- message type without using proxies.
248 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
250 instance ToJSON a => ToJSON (RequestMessage' a) where
251 toJSON (RequestMessage' rpc id method params) =
252 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
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 = sendMessage (NotificationMessage "2.0" method params)
283 -- | Sends a response to the server.
284 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
285 sendResponse = sendMessage
287 -- | Returns the initialize response that was received from the server.
288 -- The initialize requests and responses are not included the session,
289 -- so if you need to test it use this.
290 initializeResponse :: Session InitializeResponse
291 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
293 -- | Opens a text document and sends a notification to the client.
294 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
295 openDoc file languageId = do
296 item <- getDocItem file languageId
297 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
298 TextDocumentIdentifier <$> getDocUri file
300 -- | Reads in a text document as the first version.
301 getDocItem :: FilePath -- ^ The path to the text document to read in.
302 -> String -- ^ The language ID, e.g "haskell" for .hs files.
303 -> Session TextDocumentItem
304 getDocItem file languageId = do
306 let fp = rootDir context </> file
307 contents <- liftIO $ T.readFile fp
308 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
310 -- | Closes a text document and sends a notification to the client.
311 closeDoc :: TextDocumentIdentifier -> Session ()
313 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
314 sendNotification TextDocumentDidClose params
316 oldVfs <- vfs <$> get
317 let notif = NotificationMessage "" TextDocumentDidClose params
318 newVfs <- liftIO $ closeVFS oldVfs notif
319 modify $ \s -> s { vfs = newVfs }
321 -- | Gets the Uri for the file corrected to the session directory.
322 getDocUri :: FilePath -> Session Uri
325 let fp = rootDir context </> file
326 return $ filePathToUri fp
328 -- | Waits for diagnostics to be published and returns them.
329 waitForDiagnostics :: Session [Diagnostic]
330 waitForDiagnostics = do
331 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
332 let (List diags) = diagsNot ^. params . LSP.diagnostics
335 -- | The same as 'waitForDiagnostics', but will only match a specific
336 -- 'Language.Haskell.LSP.Types._source'.
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 (Either [DocumentSymbol] [SymbolInformation])
358 getDocumentSymbols doc = do
359 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
360 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
362 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
363 Just (DSSymbolInformation (List xs)) -> return (Right xs)
364 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
366 -- | Returns the code actions in the specified range.
367 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
368 getCodeActions doc range = do
369 ctx <- getCodeActionContext doc
370 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
372 case rsp ^. result of
373 Just (List xs) -> return xs
374 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
376 -- | Returns all the code actions in a document by
377 -- querying the code actions at each of the current
378 -- diagnostics' positions.
379 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
380 getAllCodeActions doc = do
381 ctx <- getCodeActionContext doc
383 foldM (go ctx) [] =<< getCurrentDiagnostics doc
386 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
388 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
391 Just e -> throw (UnexpectedResponseError rspLid e)
393 let Just (List cmdOrCAs) = mRes
394 in return (acc ++ cmdOrCAs)
396 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
397 getCodeActionContext doc = do
398 curDiags <- getCurrentDiagnostics doc
399 return $ CodeActionContext (List curDiags) Nothing
401 -- | Returns the current diagnostics that have been sent to the client.
402 -- Note that this does not wait for more to come in.
403 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
404 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
406 -- | Executes a command.
407 executeCommand :: Command -> Session ()
408 executeCommand cmd = do
409 let args = decode $ encode $ fromJust $ cmd ^. arguments
410 execParams = ExecuteCommandParams (cmd ^. command) args
411 request_ WorkspaceExecuteCommand execParams
413 -- | Executes a code action.
414 -- Matching with the specification, if a code action
415 -- contains both an edit and a command, the edit will
417 executeCodeAction :: CodeAction -> Session ()
418 executeCodeAction action = do
419 maybe (return ()) handleEdit $ action ^. edit
420 maybe (return ()) executeCommand $ action ^. command
422 where handleEdit :: WorkspaceEdit -> Session ()
424 -- Its ok to pass in dummy parameters here as they aren't used
425 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
426 in updateState (ReqApplyWorkspaceEdit req)
428 -- | Adds the current version to the document, as tracked by the session.
429 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
430 getVersionedDoc (TextDocumentIdentifier uri) = do
433 case fs Map.!? uri of
434 Just (VirtualFile v _) -> Just v
436 return (VersionedTextDocumentIdentifier uri ver)
438 -- | Applys an edit to the document and returns the updated document version.
439 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
440 applyEdit doc edit = do
442 verDoc <- getVersionedDoc doc
444 caps <- asks sessionCapabilities
446 let supportsDocChanges = fromMaybe False $ do
447 let C.ClientCapabilities mWorkspace _ _ = caps
448 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
449 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
452 let wEdit = if supportsDocChanges
454 let docEdit = TextDocumentEdit verDoc (List [edit])
455 in WorkspaceEdit Nothing (Just (List [docEdit]))
457 let changes = HashMap.singleton (doc ^. uri) (List [edit])
458 in WorkspaceEdit (Just changes) Nothing
460 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
461 updateState (ReqApplyWorkspaceEdit req)
463 -- version may have changed
466 -- | Returns the completions for the position in the document.
467 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
468 getCompletions doc pos = do
469 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
471 case getResponseResult rsp of
472 Completions (List items) -> return items
473 CompletionList (CompletionListType _ (List items)) -> return items
475 -- | Returns the references for the position in the document.
476 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
477 -> Position -- ^ The position to lookup.
478 -> Bool -- ^ Whether to include declarations as references.
479 -> Session [Location] -- ^ The locations of the references.
480 getReferences doc pos inclDecl =
481 let ctx = ReferenceContext inclDecl
482 params = ReferenceParams doc pos ctx
483 in getResponseResult <$> request TextDocumentReferences params
485 -- | Returns the definition(s) for the term at the specified position.
486 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
487 -> Position -- ^ The position the term is at.
488 -> Session [Location] -- ^ The location(s) of the definitions
489 getDefinitions doc pos =
490 let params = TextDocumentPositionParams doc pos
491 in getResponseResult <$> request TextDocumentDefinition params
493 -- | Renames the term at the specified position.
494 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
495 rename doc pos newName = do
496 let params = RenameParams doc pos (T.pack newName)
497 rsp <- request TextDocumentRename params :: Session RenameResponse
498 let wEdit = getResponseResult rsp
499 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
500 updateState (ReqApplyWorkspaceEdit req)
502 -- | Returns the hover information at the specified position.
503 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
505 let params = TextDocumentPositionParams doc pos
506 in getResponseResult <$> request TextDocumentHover params
508 -- | Returns the highlighted occurences of the term at the specified position
509 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
510 getHighlights doc pos =
511 let params = TextDocumentPositionParams doc pos
512 in getResponseResult <$> request TextDocumentDocumentHighlight params
514 -- | Checks the response for errors and throws an exception if needed.
515 -- Returns the result if successful.
516 getResponseResult :: ResponseMessage a -> a
517 getResponseResult rsp = fromMaybe exc (rsp ^. result)
518 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
519 (fromJust $ rsp ^. LSP.error)
521 -- | Applies formatting to the specified document.
522 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
523 formatDoc doc opts = do
524 let params = DocumentFormattingParams doc opts
525 edits <- getResponseResult <$> request TextDocumentFormatting params
526 applyTextEdits doc edits
528 -- | Applies formatting to the specified range in a document.
529 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
530 formatRange doc opts range = do
531 let params = DocumentRangeFormattingParams doc range opts
532 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
533 applyTextEdits doc edits
535 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
536 applyTextEdits doc edits =
537 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
538 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
539 in updateState (ReqApplyWorkspaceEdit req)