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(..)
44 , publishDiagnosticsNotification
60 , waitForDiagnosticsSource
86 import Control.Applicative.Combinators
87 import Control.Concurrent
89 import Control.Monad.IO.Class
90 import Control.Exception
91 import Control.Lens hiding ((.=), List)
92 import qualified Data.Text as T
93 import qualified Data.Text.IO as T
96 import qualified Data.HashMap.Strict as HashMap
97 import qualified Data.Map as Map
99 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
100 import qualified Language.Haskell.LSP.Types as LSP
101 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
102 import Language.Haskell.LSP.Messages
103 import Language.Haskell.LSP.VFS
104 import Language.Haskell.LSP.Test.Capabilities
105 import Language.Haskell.LSP.Test.Compat
106 import Language.Haskell.LSP.Test.Decoding
107 import Language.Haskell.LSP.Test.Exceptions
108 import Language.Haskell.LSP.Test.Parsing
109 import Language.Haskell.LSP.Test.Session
110 import Language.Haskell.LSP.Test.Server
112 import System.Directory
113 import System.FilePath
114 import qualified Yi.Rope as Rope
116 -- | Starts a new session.
117 runSession :: String -- ^ The command to run the server.
118 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
119 -> FilePath -- ^ The filepath to the root directory for the session.
120 -> Session a -- ^ The session to run.
122 runSession = runSessionWithConfig def
124 -- | Starts a new sesion with a client with the specified capabilities.
125 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
126 -> String -- ^ The command to run the server.
127 -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
128 -> FilePath -- ^ The filepath to the root directory for the session.
129 -> Session a -- ^ The session to run.
131 runSessionWithConfig config serverExe caps rootDir session = do
132 pid <- getCurrentProcessID
133 absRootDir <- canonicalizePath rootDir
135 let initializeParams = InitializeParams (Just pid)
136 (Just $ T.pack absRootDir)
137 (Just $ filePathToUri absRootDir)
141 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
142 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
144 -- Wrap the session around initialize and shutdown calls
145 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
147 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
149 initRspVar <- initRsp <$> ask
150 liftIO $ putMVar initRspVar initRspMsg
152 sendNotification Initialized InitializedParams
154 -- Run the actual test
157 sendNotification Exit ExitParams
161 -- | Listens to the server output, makes sure it matches the record and
162 -- signals any semaphores
163 listenServer :: Handle -> SessionContext -> IO ()
164 listenServer serverOut context = do
165 msgBytes <- getNextMessage serverOut
167 reqMap <- readMVar $ requestMap context
169 let msg = decodeFromServerMsg reqMap msgBytes
170 writeChan (messageChan context) (ServerMessage msg)
172 listenServer serverOut context
174 -- | The current text contents of a document.
175 documentContents :: TextDocumentIdentifier -> Session T.Text
176 documentContents doc = do
178 let file = vfs Map.! (doc ^. uri)
179 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
181 -- | Parses an ApplyEditRequest, checks that it is for the passed document
182 -- and returns the new content
183 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
184 getDocumentEdit doc = do
185 req <- message :: Session ApplyWorkspaceEditRequest
187 unless (checkDocumentChanges req || checkChanges req) $
188 liftIO $ throw (IncorrectApplyEditRequest (show req))
192 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
193 checkDocumentChanges req =
194 let changes = req ^. params . edit . documentChanges
195 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
197 Just docs -> (doc ^. uri) `elem` docs
199 checkChanges :: ApplyWorkspaceEditRequest -> Bool
201 let mMap = req ^. params . edit . changes
202 in maybe False (HashMap.member (doc ^. uri)) mMap
204 -- | Sends a request to the server and waits for its response.
205 -- Will skip any messages in between the request and the response
207 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
209 -- Note: will skip any messages in between the request and the response.
210 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
211 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
213 -- | The same as 'sendRequest', but discard the response.
214 request_ :: ToJSON params => ClientMethod -> params -> Session ()
215 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
217 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
220 => ClientMethod -- ^ The request method.
221 -> params -- ^ The request parameters.
222 -> Session LspId -- ^ The id of the request that was sent.
223 sendRequest method params = do
224 id <- curReqId <$> get
225 modify $ \c -> c { curReqId = nextId id }
227 let req = RequestMessage' "2.0" id method params
229 -- Update the request map
230 reqMap <- requestMap <$> ask
231 liftIO $ modifyMVar_ reqMap $
232 \r -> return $ updateRequestMap r id method
238 where nextId (IdInt i) = IdInt (i + 1)
239 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
241 -- | A custom type for request message that doesn't
242 -- need a response type, allows us to infer the request
243 -- message type without using proxies.
244 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
246 instance ToJSON a => ToJSON (RequestMessage' a) where
247 toJSON (RequestMessage' rpc id method params) =
248 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
251 -- | Sends a notification to the server.
252 sendNotification :: ToJSON a
253 => ClientMethod -- ^ The notification method.
254 -> a -- ^ The notification parameters.
257 -- | Open a virtual file if we send a did open text document notification
258 sendNotification TextDocumentDidOpen params = do
259 let params' = fromJust $ decode $ encode params
260 n :: DidOpenTextDocumentNotification
261 n = NotificationMessage "2.0" TextDocumentDidOpen params'
262 oldVFS <- vfs <$> get
263 newVFS <- liftIO $ openVFS oldVFS n
264 modify (\s -> s { vfs = newVFS })
267 -- | Close a virtual file if we send a close text document notification
268 sendNotification TextDocumentDidClose params = do
269 let params' = fromJust $ decode $ encode params
270 n :: DidCloseTextDocumentNotification
271 n = NotificationMessage "2.0" TextDocumentDidClose params'
272 oldVFS <- vfs <$> get
273 newVFS <- liftIO $ closeVFS oldVFS n
274 modify (\s -> s { vfs = newVFS })
277 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
279 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
280 sendResponse = sendMessage
282 -- | Returns the initialize response that was received from the server.
283 -- The initialize requests and responses are not included the session,
284 -- so if you need to test it use this.
285 initializeResponse :: Session InitializeResponse
286 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
288 -- | Opens a text document and sends a notification to the client.
289 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
290 openDoc file languageId = do
291 item <- getDocItem file languageId
292 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
293 TextDocumentIdentifier <$> getDocUri file
295 -- | Reads in a text document as the first version.
296 getDocItem :: FilePath -- ^ The path to the text document to read in.
297 -> String -- ^ The language ID, e.g "haskell" for .hs files.
298 -> Session TextDocumentItem
299 getDocItem file languageId = do
301 let fp = rootDir context </> file
302 contents <- liftIO $ T.readFile fp
303 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
305 -- | Closes a text document and sends a notification to the client.
306 closeDoc :: TextDocumentIdentifier -> Session ()
308 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
309 sendNotification TextDocumentDidClose params
311 oldVfs <- vfs <$> get
312 let notif = NotificationMessage "" TextDocumentDidClose params
313 newVfs <- liftIO $ closeVFS oldVfs notif
314 modify $ \s -> s { vfs = newVfs }
316 -- | Gets the Uri for the file corrected to the session directory.
317 getDocUri :: FilePath -> Session Uri
320 let fp = rootDir context </> file
321 return $ filePathToUri fp
323 -- | Waits for diagnostics to be published and returns them.
324 waitForDiagnostics :: Session [Diagnostic]
325 waitForDiagnostics = do
326 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
327 let (List diags) = diagsNot ^. params . LSP.diagnostics
330 waitForDiagnosticsSource :: String -> Session [Diagnostic]
331 waitForDiagnosticsSource src = do
332 diags <- waitForDiagnostics
333 let res = filter matches diags
335 then waitForDiagnosticsSource src
338 matches :: Diagnostic -> Bool
339 matches d = d ^. source == Just (T.pack src)
341 -- | Expects a 'PublishDiagnosticsNotification' and throws an
342 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
344 noDiagnostics :: Session ()
346 diagsNot <- message :: Session PublishDiagnosticsNotification
347 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
349 -- | Returns the symbols in a document.
350 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
351 getDocumentSymbols doc = do
352 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc)
353 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
354 let (Just (List symbols)) = mRes
357 -- | Returns all the code actions in a document by
358 -- querying the code actions at each of the current
359 -- diagnostics' positions.
360 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
361 getAllCodeActions doc = do
362 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
363 let ctx = CodeActionContext (List curDiags) Nothing
365 foldM (go ctx) [] curDiags
368 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
370 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
373 Just e -> throw (UnexpectedResponseError rspLid e)
375 let Just (List cmdOrCAs) = mRes
376 in return (acc ++ cmdOrCAs)
378 -- | Executes a command.
379 executeCommand :: Command -> Session ()
380 executeCommand cmd = do
381 let args = decode $ encode $ fromJust $ cmd ^. arguments
382 execParams = ExecuteCommandParams (cmd ^. command) args
383 request_ WorkspaceExecuteCommand execParams
385 -- | Executes a code action.
386 -- Matching with the specification, if a code action
387 -- contains both an edit and a command, the edit will
389 executeCodeAction :: CodeAction -> Session ()
390 executeCodeAction action = do
391 maybe (return ()) handleEdit $ action ^. edit
392 maybe (return ()) executeCommand $ action ^. command
394 where handleEdit :: WorkspaceEdit -> Session ()
396 -- Its ok to pass in dummy parameters here as they aren't used
397 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
398 in updateState (ReqApplyWorkspaceEdit req)
400 -- | Adds the current version to the document, as tracked by the session.
401 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
402 getVersionedDoc (TextDocumentIdentifier uri) = do
405 case fs Map.!? uri of
406 Just (VirtualFile v _) -> Just v
408 return (VersionedTextDocumentIdentifier uri ver)
410 -- | Applys an edit to the document and returns the updated document version.
411 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
412 applyEdit doc edit = do
414 verDoc <- getVersionedDoc doc
416 caps <- asks sessionCapabilities
418 let supportsDocChanges = fromMaybe False $ do
419 let LSP.ClientCapabilities mWorkspace _ _ = caps
420 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
421 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
424 let wEdit = if supportsDocChanges
426 let docEdit = TextDocumentEdit verDoc (List [edit])
427 in WorkspaceEdit Nothing (Just (List [docEdit]))
429 let changes = HashMap.singleton (doc ^. uri) (List [edit])
430 in WorkspaceEdit (Just changes) Nothing
432 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
433 updateState (ReqApplyWorkspaceEdit req)
435 -- version may have changed
438 -- | Returns the completions for the position in the document.
439 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
440 getCompletions doc pos = do
441 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
443 case getResponseResult rsp of
444 Completions (List items) -> return items
445 CompletionList (CompletionListType _ (List items)) -> return items
447 -- | Returns the references for the position in the document.
448 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
449 -> Position -- ^ The position to lookup.
450 -> Bool -- ^ Whether to include declarations as references.
451 -> Session [Location] -- ^ The locations of the references.
452 getReferences doc pos inclDecl =
453 let ctx = ReferenceContext inclDecl
454 params = ReferenceParams doc pos ctx
455 in getResponseResult <$> request TextDocumentReferences params
457 -- | Returns the definition(s) for the term at the specified position.
458 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
459 -> Position -- ^ The position the term is at.
460 -> Session [Location] -- ^ The location(s) of the definitions
461 getDefinitions doc pos =
462 let params = TextDocumentPositionParams doc pos
463 in getResponseResult <$> request TextDocumentDefinition params
465 -- ^ Renames the term at the specified position.
466 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
467 rename doc pos newName = do
468 let params = RenameParams doc pos (T.pack newName)
469 rsp <- request TextDocumentRename params :: Session RenameResponse
470 let wEdit = getResponseResult rsp
471 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
472 updateState (ReqApplyWorkspaceEdit req)
474 -- | Returns the hover information at the specified position.
475 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
477 let params = TextDocumentPositionParams doc pos
478 in getResponseResult <$> request TextDocumentHover params
480 -- | Returns the highlighted occurences of the term at the specified position
481 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
482 getHighlights doc pos =
483 let params = TextDocumentPositionParams doc pos
484 in getResponseResult <$> request TextDocumentDocumentHighlight params
486 -- | Checks the response for errors and throws an exception if needed.
487 -- Returns the result if successful.
488 getResponseResult :: ResponseMessage a -> a
489 getResponseResult rsp = fromMaybe exc (rsp ^. result)
490 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
491 (fromJust $ rsp ^. LSP.error)
493 -- | Applies formatting to the specified document.
494 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
495 formatDoc doc opts = do
496 let params = DocumentFormattingParams doc opts
497 edits <- getResponseResult <$> request TextDocumentFormatting params
498 applyTextEdits doc edits
500 -- | Applies formatting to the specified range in a document.
501 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
502 formatRange doc opts range = do
503 let params = DocumentRangeFormattingParams doc range opts
504 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
505 applyTextEdits doc edits
507 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
508 applyTextEdits doc edits =
509 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
510 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
511 in updateState (ReqApplyWorkspaceEdit req)