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
26 , module Language.Haskell.LSP.Types.Capabilities
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 hiding (id, capabilities, message)
95 import qualified Language.Haskell.LSP.Types as LSP
96 import Language.Haskell.LSP.Types.Capabilities
97 import Language.Haskell.LSP.Messages
98 import Language.Haskell.LSP.VFS
99 import Language.Haskell.LSP.Test.Compat
100 import Language.Haskell.LSP.Test.Decoding
101 import Language.Haskell.LSP.Test.Exceptions
102 import Language.Haskell.LSP.Test.Parsing
103 import Language.Haskell.LSP.Test.Session
104 import Language.Haskell.LSP.Test.Server
106 import System.Directory
107 import System.FilePath
108 import qualified Yi.Rope as Rope
110 -- | Starts a new session.
112 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
113 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
114 -- > diags <- waitForDiagnostics
115 -- > let pos = Position 12 5
116 -- > params = TextDocumentPositionParams doc
117 -- > hover <- request TextDocumentHover params
118 runSession :: String -- ^ The command to run the server.
119 -> 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 custom configuration.
126 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
127 -> String -- ^ The command to run the server.
128 -> 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 <- request 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.
206 -- Will skip any messages in between the request and the response
208 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
210 -- Note: will skip any messages in between the request and the response.
211 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
212 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
214 -- | The same as 'sendRequest', but discard the response.
215 request_ :: ToJSON params => ClientMethod -> params -> Session ()
216 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
218 -- | Sends a request to the server. Unlike 'request', this doesn't wait for 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 -- | Sends a notification to the server.
253 sendNotification :: ToJSON a
254 => ClientMethod -- ^ The notification method.
255 -> a -- ^ The notification parameters.
258 -- Open a virtual file if we send a did open text document notification
259 sendNotification TextDocumentDidOpen params = do
260 let params' = fromJust $ decode $ encode params
261 n :: DidOpenTextDocumentNotification
262 n = NotificationMessage "2.0" TextDocumentDidOpen params'
263 oldVFS <- vfs <$> get
264 newVFS <- liftIO $ openVFS oldVFS n
265 modify (\s -> s { vfs = newVFS })
268 -- Close a virtual file if we send a close text document notification
269 sendNotification TextDocumentDidClose params = do
270 let params' = fromJust $ decode $ encode params
271 n :: DidCloseTextDocumentNotification
272 n = NotificationMessage "2.0" TextDocumentDidClose params'
273 oldVFS <- vfs <$> get
274 newVFS <- liftIO $ closeVFS oldVFS n
275 modify (\s -> s { vfs = newVFS })
278 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
280 -- | Sends a response to the server.
281 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
282 sendResponse = sendMessage
284 -- | Returns the initialize response that was received from the server.
285 -- The initialize requests and responses are not included the session,
286 -- so if you need to test it use this.
287 initializeResponse :: Session InitializeResponse
288 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
290 -- | Opens a text document and sends a notification to the client.
291 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
292 openDoc file languageId = do
293 item <- getDocItem file languageId
294 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
295 TextDocumentIdentifier <$> getDocUri file
297 -- | Reads in a text document as the first version.
298 getDocItem :: FilePath -- ^ The path to the text document to read in.
299 -> String -- ^ The language ID, e.g "haskell" for .hs files.
300 -> Session TextDocumentItem
301 getDocItem file languageId = do
303 let fp = rootDir context </> file
304 contents <- liftIO $ T.readFile fp
305 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
307 -- | Closes a text document and sends a notification to the client.
308 closeDoc :: TextDocumentIdentifier -> Session ()
310 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
311 sendNotification TextDocumentDidClose params
313 oldVfs <- vfs <$> get
314 let notif = NotificationMessage "" TextDocumentDidClose params
315 newVfs <- liftIO $ closeVFS oldVfs notif
316 modify $ \s -> s { vfs = newVfs }
318 -- | Gets the Uri for the file corrected to the session directory.
319 getDocUri :: FilePath -> Session Uri
322 let fp = rootDir context </> file
323 return $ filePathToUri fp
325 -- | Waits for diagnostics to be published and returns them.
326 waitForDiagnostics :: Session [Diagnostic]
327 waitForDiagnostics = do
328 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
329 let (List diags) = diagsNot ^. params . LSP.diagnostics
332 -- | The same as 'waitForDiagnostics', but will only match a specific
333 -- 'Language.Haskell.LSP.Types._source'.
334 waitForDiagnosticsSource :: String -> Session [Diagnostic]
335 waitForDiagnosticsSource src = do
336 diags <- waitForDiagnostics
337 let res = filter matches diags
339 then waitForDiagnosticsSource src
342 matches :: Diagnostic -> Bool
343 matches d = d ^. source == Just (T.pack src)
345 -- | Expects a 'PublishDiagnosticsNotification' and throws an
346 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
348 noDiagnostics :: Session ()
350 diagsNot <- message :: Session PublishDiagnosticsNotification
351 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
353 -- | Returns the symbols in a document.
354 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
355 getDocumentSymbols doc = do
356 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
357 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
359 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
360 Just (DSSymbolInformation (List xs)) -> return (Right xs)
361 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
363 -- | Returns the code actions in the specified range.
364 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
365 getCodeActions doc range = do
366 ctx <- getCodeActionContext doc
367 rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
369 case rsp ^. result of
370 Just (List xs) -> return xs
371 _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
373 -- | Returns all the code actions in a document by
374 -- querying the code actions at each of the current
375 -- diagnostics' positions.
376 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
377 getAllCodeActions doc = do
378 ctx <- getCodeActionContext doc
380 foldM (go ctx) [] =<< getCurrentDiagnostics doc
383 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
385 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
388 Just e -> throw (UnexpectedResponseError rspLid e)
390 let Just (List cmdOrCAs) = mRes
391 in return (acc ++ cmdOrCAs)
393 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
394 getCodeActionContext doc = do
395 curDiags <- getCurrentDiagnostics doc
396 return $ CodeActionContext (List curDiags) Nothing
398 -- | Returns the current diagnostics that have been sent to the client.
399 -- Note that this does not wait for more to come in.
400 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
401 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
403 -- | Executes a command.
404 executeCommand :: Command -> Session ()
405 executeCommand cmd = do
406 let args = decode $ encode $ fromJust $ cmd ^. arguments
407 execParams = ExecuteCommandParams (cmd ^. command) args
408 request_ WorkspaceExecuteCommand execParams
410 -- | Executes a code action.
411 -- Matching with the specification, if a code action
412 -- contains both an edit and a command, the edit will
414 executeCodeAction :: CodeAction -> Session ()
415 executeCodeAction action = do
416 maybe (return ()) handleEdit $ action ^. edit
417 maybe (return ()) executeCommand $ action ^. command
419 where handleEdit :: WorkspaceEdit -> Session ()
421 -- Its ok to pass in dummy parameters here as they aren't used
422 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
423 in updateState (ReqApplyWorkspaceEdit req)
425 -- | Adds the current version to the document, as tracked by the session.
426 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
427 getVersionedDoc (TextDocumentIdentifier uri) = do
430 case fs Map.!? uri of
431 Just (VirtualFile v _) -> Just v
433 return (VersionedTextDocumentIdentifier uri ver)
435 -- | Applys an edit to the document and returns the updated document version.
436 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
437 applyEdit doc edit = do
439 verDoc <- getVersionedDoc doc
441 caps <- asks sessionCapabilities
443 let supportsDocChanges = fromMaybe False $ do
444 let ClientCapabilities mWorkspace _ _ = caps
445 WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
446 WorkspaceEditClientCapabilities mDocChanges <- mEdit
449 let wEdit = if supportsDocChanges
451 let docEdit = TextDocumentEdit verDoc (List [edit])
452 in WorkspaceEdit Nothing (Just (List [docEdit]))
454 let changes = HashMap.singleton (doc ^. uri) (List [edit])
455 in WorkspaceEdit (Just changes) Nothing
457 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
458 updateState (ReqApplyWorkspaceEdit req)
460 -- version may have changed
463 -- | Returns the completions for the position in the document.
464 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
465 getCompletions doc pos = do
466 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
468 case getResponseResult rsp of
469 Completions (List items) -> return items
470 CompletionList (CompletionListType _ (List items)) -> return items
472 -- | Returns the references for the position in the document.
473 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
474 -> Position -- ^ The position to lookup.
475 -> Bool -- ^ Whether to include declarations as references.
476 -> Session [Location] -- ^ The locations of the references.
477 getReferences doc pos inclDecl =
478 let ctx = ReferenceContext inclDecl
479 params = ReferenceParams doc pos ctx
480 in getResponseResult <$> request TextDocumentReferences params
482 -- | Returns the definition(s) for the term at the specified position.
483 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
484 -> Position -- ^ The position the term is at.
485 -> Session [Location] -- ^ The location(s) of the definitions
486 getDefinitions doc pos =
487 let params = TextDocumentPositionParams doc pos
488 in getResponseResult <$> request TextDocumentDefinition params
490 -- | Renames the term at the specified position.
491 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
492 rename doc pos newName = do
493 let params = RenameParams doc pos (T.pack newName)
494 rsp <- request TextDocumentRename params :: Session RenameResponse
495 let wEdit = getResponseResult rsp
496 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
497 updateState (ReqApplyWorkspaceEdit req)
499 -- | Returns the hover information at the specified position.
500 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
502 let params = TextDocumentPositionParams doc pos
503 in getResponseResult <$> request TextDocumentHover params
505 -- | Returns the highlighted occurences of the term at the specified position
506 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
507 getHighlights doc pos =
508 let params = TextDocumentPositionParams doc pos
509 in getResponseResult <$> request TextDocumentDocumentHighlight params
511 -- | Checks the response for errors and throws an exception if needed.
512 -- Returns the result if successful.
513 getResponseResult :: ResponseMessage a -> a
514 getResponseResult rsp = fromMaybe exc (rsp ^. result)
515 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
516 (fromJust $ rsp ^. LSP.error)
518 -- | Applies formatting to the specified document.
519 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
520 formatDoc doc opts = do
521 let params = DocumentFormattingParams doc opts
522 edits <- getResponseResult <$> request TextDocumentFormatting params
523 applyTextEdits doc edits
525 -- | Applies formatting to the specified range in a document.
526 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
527 formatRange doc opts range = do
528 let params = DocumentRangeFormattingParams doc range opts
529 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
530 applyTextEdits doc edits
532 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
533 applyTextEdits doc edits =
534 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
535 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
536 in updateState (ReqApplyWorkspaceEdit req)