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.
55 , waitForDiagnosticsSource
57 , getCurrentDiagnostics
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
98 import Language.Haskell.LSP.Types.Lens hiding
99 (id, capabilities, message, executeCommand, applyEdit, rename)
100 import qualified Language.Haskell.LSP.Types.Lens as LSP
101 import qualified Language.Haskell.LSP.Types.Capabilities as C
102 import Language.Haskell.LSP.Messages
103 import Language.Haskell.LSP.VFS
104 import Language.Haskell.LSP.Test.Compat
105 import Language.Haskell.LSP.Test.Decoding
106 import Language.Haskell.LSP.Test.Exceptions
107 import Language.Haskell.LSP.Test.Parsing
108 import Language.Haskell.LSP.Test.Session
109 import Language.Haskell.LSP.Test.Server
111 import System.Directory
112 import System.FilePath
113 import qualified Data.Rope.UTF16 as Rope
115 -- | Starts a new session.
117 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
118 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
119 -- > diags <- waitForDiagnostics
120 -- > let pos = Position 12 5
121 -- > params = TextDocumentPositionParams doc
122 -- > hover <- request TextDocumentHover params
123 runSession :: String -- ^ The command to run the server.
124 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
125 -> FilePath -- ^ The filepath to the root directory for the session.
126 -> Session a -- ^ The session to run.
128 runSession = runSessionWithConfig def
130 -- | Starts a new sesion with a custom configuration.
131 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
132 -> String -- ^ The command to run the server.
133 -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
134 -> FilePath -- ^ The filepath to the root directory for the session.
135 -> Session a -- ^ The session to run.
137 runSessionWithConfig config serverExe caps rootDir session = do
138 pid <- getCurrentProcessID
139 absRootDir <- canonicalizePath rootDir
141 let initializeParams = InitializeParams (Just pid)
142 (Just $ T.pack absRootDir)
143 (Just $ filePathToUri absRootDir)
148 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
149 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
151 -- Wrap the session around initialize and shutdown calls
152 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
154 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
156 initRspVar <- initRsp <$> ask
157 liftIO $ putMVar initRspVar initRspMsg
159 sendNotification Initialized InitializedParams
161 case lspConfig config of
162 Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
165 -- Run the actual test
168 sendNotification Exit ExitParams
172 -- | Listens to the server output, makes sure it matches the record and
173 -- signals any semaphores
174 listenServer :: Handle -> SessionContext -> IO ()
175 listenServer serverOut context = do
176 msgBytes <- getNextMessage serverOut
178 reqMap <- readMVar $ requestMap context
180 let msg = decodeFromServerMsg reqMap msgBytes
181 writeChan (messageChan context) (ServerMessage msg)
183 listenServer serverOut context
185 -- | The current text contents of a document.
186 documentContents :: TextDocumentIdentifier -> Session T.Text
187 documentContents doc = do
189 let file = vfs Map.! (doc ^. uri)
190 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
192 -- | Parses an ApplyEditRequest, checks that it is for the passed document
193 -- and returns the new content
194 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
195 getDocumentEdit doc = do
196 req <- message :: Session ApplyWorkspaceEditRequest
198 unless (checkDocumentChanges req || checkChanges req) $
199 liftIO $ throw (IncorrectApplyEditRequest (show req))
203 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
204 checkDocumentChanges req =
205 let changes = req ^. params . edit . documentChanges
206 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
208 Just docs -> (doc ^. uri) `elem` docs
210 checkChanges :: ApplyWorkspaceEditRequest -> Bool
212 let mMap = req ^. params . edit . changes
213 in maybe False (HashMap.member (doc ^. uri)) mMap
215 -- | Sends a request to the server and waits for its response.
216 -- Will skip any messages in between the request and the response
218 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
220 -- Note: will skip any messages in between the request and the response.
221 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
222 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
224 -- | The same as 'sendRequest', but discard the response.
225 request_ :: ToJSON params => ClientMethod -> params -> Session ()
226 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
228 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
231 => ClientMethod -- ^ The request method.
232 -> params -- ^ The request parameters.
233 -> Session LspId -- ^ The id of the request that was sent.
234 sendRequest method params = do
235 id <- curReqId <$> get
236 modify $ \c -> c { curReqId = nextId id }
238 let req = RequestMessage' "2.0" id method params
240 -- Update the request map
241 reqMap <- requestMap <$> ask
242 liftIO $ modifyMVar_ reqMap $
243 \r -> return $ updateRequestMap r id method
249 where nextId (IdInt i) = IdInt (i + 1)
250 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
252 -- | A custom type for request message that doesn't
253 -- need a response type, allows us to infer the request
254 -- message type without using proxies.
255 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
257 instance ToJSON a => ToJSON (RequestMessage' a) where
258 toJSON (RequestMessage' rpc id method params) =
259 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
262 -- | Sends a notification to the server.
263 sendNotification :: ToJSON a
264 => ClientMethod -- ^ The notification method.
265 -> a -- ^ The notification parameters.
268 -- Open a virtual file if we send a did open text document notification
269 sendNotification TextDocumentDidOpen params = do
270 let params' = fromJust $ decode $ encode params
271 n :: DidOpenTextDocumentNotification
272 n = NotificationMessage "2.0" TextDocumentDidOpen params'
273 oldVFS <- vfs <$> get
274 newVFS <- liftIO $ openVFS oldVFS n
275 modify (\s -> s { vfs = newVFS })
278 -- Close a virtual file if we send a close text document notification
279 sendNotification TextDocumentDidClose params = do
280 let params' = fromJust $ decode $ encode params
281 n :: DidCloseTextDocumentNotification
282 n = NotificationMessage "2.0" TextDocumentDidClose params'
283 oldVFS <- vfs <$> get
284 newVFS <- liftIO $ closeVFS oldVFS n
285 modify (\s -> s { vfs = newVFS })
288 sendNotification TextDocumentDidChange params = do
289 let params' = fromJust $ decode $ encode params
290 n :: DidChangeTextDocumentNotification
291 n = NotificationMessage "2.0" TextDocumentDidChange params'
292 oldVFS <- vfs <$> get
293 newVFS <- liftIO $ changeFromClientVFS oldVFS n
294 modify (\s -> s { vfs = newVFS })
297 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
299 -- | Sends a response to the server.
300 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
301 sendResponse = sendMessage
303 -- | Returns the initialize response that was received from the server.
304 -- The initialize requests and responses are not included the session,
305 -- so if you need to test it use this.
306 initializeResponse :: Session InitializeResponse
307 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
309 -- | Opens a text document and sends a notification to the client.
310 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
311 openDoc file languageId = do
313 let fp = rootDir context </> file
314 contents <- liftIO $ T.readFile fp
315 openDoc' file languageId contents
317 -- | This is a variant of `openDoc` that takes the file content as an argument.
318 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
319 openDoc' file languageId contents = do
321 let fp = rootDir context </> file
322 uri = filePathToUri fp
323 item = TextDocumentItem uri (T.pack languageId) 0 contents
324 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
325 pure $ TextDocumentIdentifier uri
327 -- | Closes a text document and sends a notification to the client.
328 closeDoc :: TextDocumentIdentifier -> Session ()
330 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
331 sendNotification TextDocumentDidClose params
333 -- | Changes a text document and sends a notification to the client
334 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
335 changeDoc docId changes = do
336 verDoc <- getVersionedDoc docId
337 let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
338 sendNotification TextDocumentDidChange params
340 -- | Gets the Uri for the file corrected to the session directory.
341 getDocUri :: FilePath -> Session Uri
344 let fp = rootDir context </> file
345 return $ filePathToUri fp
347 -- | Waits for diagnostics to be published and returns them.
348 waitForDiagnostics :: Session [Diagnostic]
349 waitForDiagnostics = do
350 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
351 let (List diags) = diagsNot ^. params . LSP.diagnostics
354 -- | The same as 'waitForDiagnostics', but will only match a specific
355 -- 'Language.Haskell.LSP.Types._source'.
356 waitForDiagnosticsSource :: String -> Session [Diagnostic]
357 waitForDiagnosticsSource src = do
358 diags <- waitForDiagnostics
359 let res = filter matches diags
361 then waitForDiagnosticsSource src
364 matches :: Diagnostic -> Bool
365 matches d = d ^. source == Just (T.pack src)
367 -- | Expects a 'PublishDiagnosticsNotification' and throws an
368 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
370 noDiagnostics :: Session ()
372 diagsNot <- message :: Session PublishDiagnosticsNotification
373 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
375 -- | Returns the symbols in a document.
376 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
377 getDocumentSymbols doc = do
378 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
379 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
381 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
382 Just (DSSymbolInformation (List xs)) -> return (Right xs)
383 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
385 -- | Returns the code actions in the specified range.
386 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
387 getCodeActions doc range = do
388 ctx <- getCodeActionContext doc
389 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
391 case rsp ^. result of
392 Just (List xs) -> return xs
393 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
395 -- | Returns all the code actions in a document by
396 -- querying the code actions at each of the current
397 -- diagnostics' positions.
398 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
399 getAllCodeActions doc = do
400 ctx <- getCodeActionContext doc
402 foldM (go ctx) [] =<< getCurrentDiagnostics doc
405 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
407 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
410 Just e -> throw (UnexpectedResponseError rspLid e)
412 let Just (List cmdOrCAs) = mRes
413 in return (acc ++ cmdOrCAs)
415 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
416 getCodeActionContext doc = do
417 curDiags <- getCurrentDiagnostics doc
418 return $ CodeActionContext (List curDiags) Nothing
420 -- | Returns the current diagnostics that have been sent to the client.
421 -- Note that this does not wait for more to come in.
422 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
423 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
425 -- | Executes a command.
426 executeCommand :: Command -> Session ()
427 executeCommand cmd = do
428 let args = decode $ encode $ fromJust $ cmd ^. arguments
429 execParams = ExecuteCommandParams (cmd ^. command) args
430 request_ WorkspaceExecuteCommand execParams
432 -- | Executes a code action.
433 -- Matching with the specification, if a code action
434 -- contains both an edit and a command, the edit will
436 executeCodeAction :: CodeAction -> Session ()
437 executeCodeAction action = do
438 maybe (return ()) handleEdit $ action ^. edit
439 maybe (return ()) executeCommand $ action ^. command
441 where handleEdit :: WorkspaceEdit -> Session ()
443 -- Its ok to pass in dummy parameters here as they aren't used
444 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
445 in updateState (ReqApplyWorkspaceEdit req)
447 -- | Adds the current version to the document, as tracked by the session.
448 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
449 getVersionedDoc (TextDocumentIdentifier uri) = do
452 case fs Map.!? uri of
453 Just (VirtualFile v _ _) -> Just v
455 return (VersionedTextDocumentIdentifier uri ver)
457 -- | Applys an edit to the document and returns the updated document version.
458 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
459 applyEdit doc edit = do
461 verDoc <- getVersionedDoc doc
463 caps <- asks sessionCapabilities
465 let supportsDocChanges = fromMaybe False $ do
466 let mWorkspace = C._workspace caps
467 C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
468 C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
471 let wEdit = if supportsDocChanges
473 let docEdit = TextDocumentEdit verDoc (List [edit])
474 in WorkspaceEdit Nothing (Just (List [docEdit]))
476 let changes = HashMap.singleton (doc ^. uri) (List [edit])
477 in WorkspaceEdit (Just changes) Nothing
479 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
480 updateState (ReqApplyWorkspaceEdit req)
482 -- version may have changed
485 -- | Returns the completions for the position in the document.
486 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
487 getCompletions doc pos = do
488 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
490 case getResponseResult rsp of
491 Completions (List items) -> return items
492 CompletionList (CompletionListType _ (List items)) -> return items
494 -- | Returns the references for the position in the document.
495 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
496 -> Position -- ^ The position to lookup.
497 -> Bool -- ^ Whether to include declarations as references.
498 -> Session [Location] -- ^ The locations of the references.
499 getReferences doc pos inclDecl =
500 let ctx = ReferenceContext inclDecl
501 params = ReferenceParams doc pos ctx
502 in getResponseResult <$> request TextDocumentReferences params
504 -- | Returns the definition(s) for the term at the specified position.
505 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
506 -> Position -- ^ The position the term is at.
507 -> Session [Location] -- ^ The location(s) of the definitions
508 getDefinitions doc pos =
509 let params = TextDocumentPositionParams doc pos
510 in getResponseResult <$> request TextDocumentDefinition params
512 -- | Returns the type definition(s) for the term at the specified position.
513 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
514 -> Position -- ^ The position the term is at.
515 -> Session [Location] -- ^ The location(s) of the definitions
516 getTypeDefinitions doc pos =
517 let params = TextDocumentPositionParams doc pos
518 in getResponseResult <$> request TextDocumentTypeDefinition params
520 -- | Renames the term at the specified position.
521 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
522 rename doc pos newName = do
523 let params = RenameParams doc pos (T.pack newName)
524 rsp <- request TextDocumentRename params :: Session RenameResponse
525 let wEdit = getResponseResult rsp
526 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
527 updateState (ReqApplyWorkspaceEdit req)
529 -- | Returns the hover information at the specified position.
530 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
532 let params = TextDocumentPositionParams doc pos
533 in getResponseResult <$> request TextDocumentHover params
535 -- | Returns the highlighted occurences of the term at the specified position
536 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
537 getHighlights doc pos =
538 let params = TextDocumentPositionParams doc pos
539 in getResponseResult <$> request TextDocumentDocumentHighlight params
541 -- | Checks the response for errors and throws an exception if needed.
542 -- Returns the result if successful.
543 getResponseResult :: ResponseMessage a -> a
544 getResponseResult rsp = fromMaybe exc (rsp ^. result)
545 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
546 (fromJust $ rsp ^. LSP.error)
548 -- | Applies formatting to the specified document.
549 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
550 formatDoc doc opts = do
551 let params = DocumentFormattingParams doc opts
552 edits <- getResponseResult <$> request TextDocumentFormatting params
553 applyTextEdits doc edits
555 -- | Applies formatting to the specified range in a document.
556 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
557 formatRange doc opts range = do
558 let params = DocumentRangeFormattingParams doc range opts
559 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
560 applyTextEdits doc edits
562 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
563 applyTextEdits doc edits =
564 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
565 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
566 in updateState (ReqApplyWorkspaceEdit req)