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 A framework for testing
14 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>
17 module Language.Haskell.LSP.Test
23 , runSessionWithConfig
26 , module Language.Haskell.LSP.Test.Capabilities
28 , SessionException(..)
46 , publishDiagnosticsNotification
62 , waitForDiagnosticsSource
88 import Control.Applicative.Combinators
89 import Control.Concurrent
91 import Control.Monad.IO.Class
92 import Control.Exception
93 import Control.Lens hiding ((.=), List)
94 import qualified Data.Text as T
95 import qualified Data.Text.IO as T
98 import qualified Data.HashMap.Strict as HashMap
99 import qualified Data.Map as Map
101 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
102 import qualified Language.Haskell.LSP.Types as LSP
103 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
104 import Language.Haskell.LSP.Messages
105 import Language.Haskell.LSP.VFS
106 import Language.Haskell.LSP.Test.Capabilities
107 import Language.Haskell.LSP.Test.Compat
108 import Language.Haskell.LSP.Test.Decoding
109 import Language.Haskell.LSP.Test.Exceptions
110 import Language.Haskell.LSP.Test.Parsing
111 import Language.Haskell.LSP.Test.Session
112 import Language.Haskell.LSP.Test.Server
114 import System.Directory
115 import System.FilePath
116 import qualified Yi.Rope as Rope
118 -- | Starts a new session.
119 runSession :: String -- ^ The command to run the server.
120 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
121 -> FilePath -- ^ The filepath to the root directory for the session.
122 -> Session a -- ^ The session to run.
124 runSession = runSessionWithConfig def
126 -- | Starts a new sesion with a client with the specified capabilities.
127 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
128 -> String -- ^ The command to run the server.
129 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
130 -> FilePath -- ^ The filepath to the root directory for the session.
131 -> Session a -- ^ The session to run.
133 runSessionWithConfig config serverExe caps rootDir session = do
134 pid <- getCurrentProcessID
135 absRootDir <- canonicalizePath rootDir
137 let initializeParams = InitializeParams (Just pid)
138 (Just $ T.pack absRootDir)
139 (Just $ filePathToUri absRootDir)
143 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
144 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
146 -- Wrap the session around initialize and shutdown calls
147 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
149 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
151 initRspVar <- initRsp <$> ask
152 liftIO $ putMVar initRspVar initRspMsg
154 sendNotification Initialized InitializedParams
156 -- Run the actual test
159 sendNotification Exit ExitParams
163 -- | Listens to the server output, makes sure it matches the record and
164 -- signals any semaphores
165 listenServer :: Handle -> SessionContext -> IO ()
166 listenServer serverOut context = do
167 msgBytes <- getNextMessage serverOut
169 reqMap <- readMVar $ requestMap context
171 let msg = decodeFromServerMsg reqMap msgBytes
172 writeChan (messageChan context) (ServerMessage msg)
174 listenServer serverOut context
176 -- | The current text contents of a document.
177 documentContents :: TextDocumentIdentifier -> Session T.Text
178 documentContents doc = do
180 let file = vfs Map.! (doc ^. uri)
181 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
183 -- | Parses an ApplyEditRequest, checks that it is for the passed document
184 -- and returns the new content
185 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
186 getDocumentEdit doc = do
187 req <- message :: Session ApplyWorkspaceEditRequest
189 unless (checkDocumentChanges req || checkChanges req) $
190 liftIO $ throw (IncorrectApplyEditRequest (show req))
194 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
195 checkDocumentChanges req =
196 let changes = req ^. params . edit . documentChanges
197 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
199 Just docs -> (doc ^. uri) `elem` docs
201 checkChanges :: ApplyWorkspaceEditRequest -> Bool
203 let mMap = req ^. params . edit . changes
204 in maybe False (HashMap.member (doc ^. uri)) mMap
206 -- | Sends a request to the server and waits for its response.
207 -- Will skip any messages in between the request and the response
209 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
211 -- Note: will skip any messages in between the request and the response.
212 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
213 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
215 -- | The same as 'sendRequest', but discard the response.
216 request_ :: ToJSON params => ClientMethod -> params -> Session ()
217 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
219 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
222 => ClientMethod -- ^ The request method.
223 -> params -- ^ The request parameters.
224 -> Session LspId -- ^ The id of the request that was sent.
225 sendRequest method params = do
226 id <- curReqId <$> get
227 modify $ \c -> c { curReqId = nextId id }
229 let req = RequestMessage' "2.0" id method params
231 -- Update the request map
232 reqMap <- requestMap <$> ask
233 liftIO $ modifyMVar_ reqMap $
234 \r -> return $ updateRequestMap r id method
240 where nextId (IdInt i) = IdInt (i + 1)
241 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
243 -- | A custom type for request message that doesn't
244 -- need a response type, allows us to infer the request
245 -- message type without using proxies.
246 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
248 instance ToJSON a => ToJSON (RequestMessage' a) where
249 toJSON (RequestMessage' rpc id method params) =
250 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
253 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
254 sendRequestMessage req = do
255 -- Update the request map
256 reqMap <- requestMap <$> ask
257 liftIO $ modifyMVar_ reqMap $
258 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
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 method params = sendNotification' (NotificationMessage "2.0" method params)
290 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
291 sendNotification' = sendMessage
293 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
294 sendResponse = sendMessage
296 -- | Returns the initialize response that was received from the server.
297 -- The initialize requests and responses are not included the session,
298 -- so if you need to test it use this.
299 initializeResponse :: Session InitializeResponse
300 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
302 -- | Opens a text document and sends a notification to the client.
303 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
304 openDoc file languageId = do
305 item <- getDocItem file languageId
306 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
307 TextDocumentIdentifier <$> getDocUri file
309 -- | Reads in a text document as the first version.
310 getDocItem :: FilePath -- ^ The path to the text document to read in.
311 -> String -- ^ The language ID, e.g "haskell" for .hs files.
312 -> Session TextDocumentItem
313 getDocItem file languageId = do
315 let fp = rootDir context </> file
316 contents <- liftIO $ T.readFile fp
317 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
319 -- | Closes a text document and sends a notification to the client.
320 closeDoc :: TextDocumentIdentifier -> Session ()
322 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
323 sendNotification TextDocumentDidClose params
325 oldVfs <- vfs <$> get
326 let notif = NotificationMessage "" TextDocumentDidClose params
327 newVfs <- liftIO $ closeVFS oldVfs notif
328 modify $ \s -> s { vfs = newVfs }
330 -- | Gets the Uri for the file corrected to the session directory.
331 getDocUri :: FilePath -> Session Uri
334 let fp = rootDir context </> file
335 return $ filePathToUri fp
337 -- | Waits for diagnostics to be published and returns them.
338 waitForDiagnostics :: Session [Diagnostic]
339 waitForDiagnostics = do
340 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
341 let (List diags) = diagsNot ^. params . LSP.diagnostics
344 waitForDiagnosticsSource :: String -> Session [Diagnostic]
345 waitForDiagnosticsSource src = do
346 diags <- waitForDiagnostics
347 let res = filter matches diags
349 then waitForDiagnosticsSource src
352 matches :: Diagnostic -> Bool
353 matches d = d ^. source == Just (T.pack src)
355 -- | Expects a 'PublishDiagnosticsNotification' and throws an
356 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
358 noDiagnostics :: Session ()
360 diagsNot <- message :: Session PublishDiagnosticsNotification
361 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
363 -- | Returns the symbols in a document.
364 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
365 getDocumentSymbols doc = do
366 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc)
367 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
368 let (Just (List symbols)) = mRes
371 -- | Returns all the code actions in a document by
372 -- querying the code actions at each of the current
373 -- diagnostics' positions.
374 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
375 getAllCodeActions doc = do
376 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
377 let ctx = CodeActionContext (List curDiags) Nothing
379 foldM (go ctx) [] curDiags
382 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
384 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
387 Just e -> throw (UnexpectedResponseError rspLid e)
389 let Just (List cmdOrCAs) = mRes
390 in return (acc ++ cmdOrCAs)
392 -- | Executes a command.
393 executeCommand :: Command -> Session ()
394 executeCommand cmd = do
395 let args = decode $ encode $ fromJust $ cmd ^. arguments
396 execParams = ExecuteCommandParams (cmd ^. command) args
397 request_ WorkspaceExecuteCommand execParams
399 -- | Executes a code action.
400 -- Matching with the specification, if a code action
401 -- contains both an edit and a command, the edit will
403 executeCodeAction :: CodeAction -> Session ()
404 executeCodeAction action = do
405 maybe (return ()) handleEdit $ action ^. edit
406 maybe (return ()) executeCommand $ action ^. command
408 where handleEdit :: WorkspaceEdit -> Session ()
410 -- Its ok to pass in dummy parameters here as they aren't used
411 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
412 in updateState (ReqApplyWorkspaceEdit req)
414 -- | Adds the current version to the document, as tracked by the session.
415 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
416 getVersionedDoc (TextDocumentIdentifier uri) = do
419 case fs Map.!? uri of
420 Just (VirtualFile v _) -> Just v
422 return (VersionedTextDocumentIdentifier uri ver)
424 -- | Applys an edit to the document and returns the updated document version.
425 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
426 applyEdit doc edit = do
428 verDoc <- getVersionedDoc doc
430 caps <- asks sessionCapabilities
432 let supportsDocChanges = fromMaybe False $ do
433 let LSP.ClientCapabilities mWorkspace _ _ = caps
434 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
435 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
438 let wEdit = if supportsDocChanges
440 let docEdit = TextDocumentEdit verDoc (List [edit])
441 in WorkspaceEdit Nothing (Just (List [docEdit]))
443 let changes = HashMap.singleton (doc ^. uri) (List [edit])
444 in WorkspaceEdit (Just changes) Nothing
446 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
447 updateState (ReqApplyWorkspaceEdit req)
449 -- version may have changed
452 -- | Returns the completions for the position in the document.
453 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
454 getCompletions doc pos = do
455 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
457 case getResponseResult rsp of
458 Completions (List items) -> return items
459 CompletionList (CompletionListType _ (List items)) -> return items
461 -- | Returns the references for the position in the document.
462 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
463 -> Position -- ^ The position to lookup.
464 -> Bool -- ^ Whether to include declarations as references.
465 -> Session [Location] -- ^ The locations of the references.
466 getReferences doc pos inclDecl =
467 let ctx = ReferenceContext inclDecl
468 params = ReferenceParams doc pos ctx
469 in getResponseResult <$> request TextDocumentReferences params
471 -- | Returns the definition(s) for the term at the specified position.
472 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
473 -> Position -- ^ The position the term is at.
474 -> Session [Location] -- ^ The location(s) of the definitions
475 getDefinitions doc pos =
476 let params = TextDocumentPositionParams doc pos
477 in getResponseResult <$> request TextDocumentDefinition params
479 -- ^ Renames the term at the specified position.
480 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
481 rename doc pos newName = do
482 let params = RenameParams doc pos (T.pack newName)
483 rsp <- request TextDocumentRename params :: Session RenameResponse
484 let wEdit = getResponseResult rsp
485 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
486 updateState (ReqApplyWorkspaceEdit req)
488 -- | Returns the hover information at the specified position.
489 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
491 let params = TextDocumentPositionParams doc pos
492 in getResponseResult <$> request TextDocumentHover params
494 -- | Returns the highlighted occurences of the term at the specified position
495 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
496 getHighlights doc pos =
497 let params = TextDocumentPositionParams doc pos
498 in getResponseResult <$> request TextDocumentDocumentHighlight params
500 -- | Checks the response for errors and throws an exception if needed.
501 -- Returns the result if successful.
502 getResponseResult :: ResponseMessage a -> a
503 getResponseResult rsp = fromMaybe exc (rsp ^. result)
504 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
505 (fromJust $ rsp ^. LSP.error)
507 -- | Applies formatting to the specified document.
508 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
509 formatDoc doc opts = do
510 let params = DocumentFormattingParams doc opts
511 edits <- getResponseResult <$> request TextDocumentFormatting params
512 applyTextEdits doc edits
514 -- | Applies formatting to the specified range in a document.
515 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
516 formatRange doc opts range = do
517 let params = DocumentRangeFormattingParams doc range opts
518 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
519 applyTextEdits doc edits
521 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
522 applyTextEdits doc edits =
523 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
524 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
525 in updateState (ReqApplyWorkspaceEdit req)