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
12 -- A framework for testing
13 -- <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>
16 module Language.Haskell.LSP.Test
20 , runSessionWithHandles
21 , runSessionWithConfig
24 , SessionException(..)
42 , publishDiagnosticsNotification
57 , waitForDiagnosticsSource
83 import Control.Applicative.Combinators
84 import Control.Concurrent
86 import Control.Monad.IO.Class
87 import Control.Exception
88 import Control.Lens hiding ((.=), List)
89 import qualified Data.Text as T
90 import qualified Data.Text.IO as T
93 import qualified Data.HashMap.Strict as HashMap
94 import qualified Data.Map as Map
96 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
97 import qualified Language.Haskell.LSP.Types as LSP
98 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
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.
113 runSession :: String -- ^ The command to run the server.
114 -> FilePath -- ^ The filepath to the root directory for the session.
115 -> Session a -- ^ The session to run.
117 runSession = runSessionWithConfig def
119 -- | Starts a new sesion with a client with the specified capabilities.
120 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
121 -> String -- ^ The command to run the server.
122 -> FilePath -- ^ The filepath to the root directory for the session.
123 -> Session a -- ^ The session to run.
125 runSessionWithConfig config serverExe rootDir session = do
126 pid <- getCurrentProcessID
127 absRootDir <- canonicalizePath rootDir
129 let initializeParams = InitializeParams (Just pid)
130 (Just $ T.pack absRootDir)
131 (Just $ filePathToUri absRootDir)
133 (capabilities config)
135 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
136 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
138 -- Wrap the session around initialize and shutdown calls
139 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
141 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
143 initRspVar <- initRsp <$> ask
144 liftIO $ putMVar initRspVar initRspMsg
146 sendNotification Initialized InitializedParams
148 -- Run the actual test
151 sendNotification Exit ExitParams
155 -- | Listens to the server output, makes sure it matches the record and
156 -- signals any semaphores
157 listenServer :: Handle -> SessionContext -> IO ()
158 listenServer serverOut context = do
159 msgBytes <- getNextMessage serverOut
161 reqMap <- readMVar $ requestMap context
163 let msg = decodeFromServerMsg reqMap msgBytes
164 writeChan (messageChan context) (ServerMessage msg)
166 listenServer serverOut context
168 -- | The current text contents of a document.
169 documentContents :: TextDocumentIdentifier -> Session T.Text
170 documentContents doc = do
172 let file = vfs Map.! (doc ^. uri)
173 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
175 -- | Parses an ApplyEditRequest, checks that it is for the passed document
176 -- and returns the new content
177 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
178 getDocumentEdit doc = do
179 req <- message :: Session ApplyWorkspaceEditRequest
181 unless (checkDocumentChanges req || checkChanges req) $
182 liftIO $ throw (IncorrectApplyEditRequest (show req))
186 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
187 checkDocumentChanges req =
188 let changes = req ^. params . edit . documentChanges
189 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
191 Just docs -> (doc ^. uri) `elem` docs
193 checkChanges :: ApplyWorkspaceEditRequest -> Bool
195 let mMap = req ^. params . edit . changes
196 in maybe False (HashMap.member (doc ^. uri)) mMap
198 -- | Sends a request to the server and waits for its response.
200 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
202 -- Note: will skip any messages in between the request and the response.
203 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
204 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
206 -- | Send a request to the server and wait for its response,
208 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
209 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
211 -- | Sends a request to the server without waiting on the response.
214 => ClientMethod -- ^ The request method.
215 -> params -- ^ The request parameters.
216 -> Session LspId -- ^ The id of the request that was sent.
217 sendRequest' method params = do
218 id <- curReqId <$> get
219 modify $ \c -> c { curReqId = nextId id }
221 let req = RequestMessage' "2.0" id method params
223 -- Update the request map
224 reqMap <- requestMap <$> ask
225 liftIO $ modifyMVar_ reqMap $
226 \r -> return $ updateRequestMap r id method
232 where nextId (IdInt i) = IdInt (i + 1)
233 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
235 -- | A custom type for request message that doesn't
236 -- need a response type, allows us to infer the request
237 -- message type without using proxies.
238 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
240 instance ToJSON a => ToJSON (RequestMessage' a) where
241 toJSON (RequestMessage' rpc id method params) =
242 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
245 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
246 sendRequestMessage req = do
247 -- Update the request map
248 reqMap <- requestMap <$> ask
249 liftIO $ modifyMVar_ reqMap $
250 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
254 -- | Sends a notification to the server.
255 sendNotification :: ToJSON a
256 => ClientMethod -- ^ The notification method.
257 -> a -- ^ The notification parameters.
260 -- | Open a virtual file if we send a did open text document notification
261 sendNotification TextDocumentDidOpen params = do
262 let params' = fromJust $ decode $ encode params
263 n :: DidOpenTextDocumentNotification
264 n = NotificationMessage "2.0" TextDocumentDidOpen params'
265 oldVFS <- vfs <$> get
266 newVFS <- liftIO $ openVFS oldVFS n
267 modify (\s -> s { vfs = newVFS })
270 -- | Close a virtual file if we send a close text document notification
271 sendNotification TextDocumentDidClose params = do
272 let params' = fromJust $ decode $ encode params
273 n :: DidCloseTextDocumentNotification
274 n = NotificationMessage "2.0" TextDocumentDidClose params'
275 oldVFS <- vfs <$> get
276 newVFS <- liftIO $ closeVFS oldVFS n
277 modify (\s -> s { vfs = newVFS })
280 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
282 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
283 sendNotification' = sendMessage
285 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
286 sendResponse = sendMessage
288 -- | Returns the initialize response that was received from the server.
289 -- The initialize requests and responses are not included the session,
290 -- so if you need to test it use this.
291 initializeResponse :: Session InitializeResponse
292 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
294 -- | Opens a text document and sends a notification to the client.
295 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
296 openDoc file languageId = do
297 item <- getDocItem file languageId
298 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
299 TextDocumentIdentifier <$> getDocUri file
301 -- | Reads in a text document as the first version.
302 getDocItem :: FilePath -- ^ The path to the text document to read in.
303 -> String -- ^ The language ID, e.g "haskell" for .hs files.
304 -> Session TextDocumentItem
305 getDocItem file languageId = do
307 let fp = rootDir context </> file
308 contents <- liftIO $ T.readFile fp
309 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
311 -- | Gets the Uri for the file corrected to the session directory.
312 getDocUri :: FilePath -> Session Uri
315 let fp = rootDir context </> file
316 return $ filePathToUri fp
318 -- | Waits for diagnostics to be published and returns them.
319 waitForDiagnostics :: Session [Diagnostic]
320 waitForDiagnostics = do
321 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
322 let (List diags) = diagsNot ^. params . LSP.diagnostics
325 waitForDiagnosticsSource :: String -> Session [Diagnostic]
326 waitForDiagnosticsSource src = do
327 diags <- waitForDiagnostics
328 let res = filter matches diags
330 then waitForDiagnosticsSource src
333 matches :: Diagnostic -> Bool
334 matches d = d ^. source == Just (T.pack src)
336 -- | Expects a 'PublishDiagnosticsNotification' and throws an
337 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
339 noDiagnostics :: Session ()
341 diagsNot <- message :: Session PublishDiagnosticsNotification
342 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
344 -- | Returns the symbols in a document.
345 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
346 getDocumentSymbols doc = do
347 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
348 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
349 let (Just (List symbols)) = mRes
352 -- | Returns all the code actions in a document by
353 -- querying the code actions at each of the current
354 -- diagnostics' positions.
355 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
356 getAllCodeActions doc = do
357 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
358 let ctx = CodeActionContext (List curDiags) Nothing
360 foldM (go ctx) [] curDiags
363 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
365 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
368 Just e -> throw (UnexpectedResponseError rspLid e)
370 let Just (List cmdOrCAs) = mRes
371 in return (acc ++ cmdOrCAs)
373 -- | Executes a command.
374 executeCommand :: Command -> Session ()
375 executeCommand cmd = do
376 let args = decode $ encode $ fromJust $ cmd ^. arguments
377 execParams = ExecuteCommandParams (cmd ^. command) args
378 sendRequest_ WorkspaceExecuteCommand execParams
380 -- | Executes a code action.
381 -- Matching with the specification, if a code action
382 -- contains both an edit and a command, the edit will
384 executeCodeAction :: CodeAction -> Session ()
385 executeCodeAction action = do
386 maybe (return ()) handleEdit $ action ^. edit
387 maybe (return ()) executeCommand $ action ^. command
389 where handleEdit :: WorkspaceEdit -> Session ()
391 -- Its ok to pass in dummy parameters here as they aren't used
392 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
393 in updateState (ReqApplyWorkspaceEdit req)
395 -- | Adds the current version to the document, as tracked by the session.
396 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
397 getVersionedDoc (TextDocumentIdentifier uri) = do
400 case fs Map.!? uri of
401 Just (VirtualFile v _) -> Just v
403 return (VersionedTextDocumentIdentifier uri ver)
405 -- | Applys an edit to the document and returns the updated document version.
406 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
407 applyEdit doc edit = do
409 verDoc <- getVersionedDoc doc
411 caps <- asks (capabilities . config)
413 let supportsDocChanges = fromMaybe False $ do
414 let LSP.ClientCapabilities mWorkspace _ _ = caps
415 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
416 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
419 let wEdit = if supportsDocChanges
421 let docEdit = TextDocumentEdit verDoc (List [edit])
422 in WorkspaceEdit Nothing (Just (List [docEdit]))
424 let changes = HashMap.singleton (doc ^. uri) (List [edit])
425 in WorkspaceEdit (Just changes) Nothing
427 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
428 updateState (ReqApplyWorkspaceEdit req)
430 -- version may have changed
433 -- | Returns the completions for the position in the document.
434 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
435 getCompletions doc pos = do
436 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
438 case getResponseResult rsp of
439 Completions (List items) -> return items
440 CompletionList (CompletionListType _ (List items)) -> return items
442 -- | Returns the references for the position in the document.
443 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
444 -> Position -- ^ The position to lookup.
445 -> Bool -- ^ Whether to include declarations as references.
446 -> Session [Location] -- ^ The locations of the references.
447 getReferences doc pos inclDecl =
448 let ctx = ReferenceContext inclDecl
449 params = ReferenceParams doc pos ctx
450 in getResponseResult <$> sendRequest TextDocumentReferences params
452 -- | Returns the definition(s) for the term at the specified position.
453 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
454 -> Position -- ^ The position the term is at.
455 -> Session [Location] -- ^ The location(s) of the definitions
456 getDefinitions doc pos =
457 let params = TextDocumentPositionParams doc pos
458 in getResponseResult <$> sendRequest TextDocumentDefinition params
460 -- ^ Renames the term at the specified position.
461 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
462 rename doc pos newName = do
463 let params = RenameParams doc pos (T.pack newName)
464 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
465 let wEdit = getResponseResult rsp
466 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
467 updateState (ReqApplyWorkspaceEdit req)
469 -- | Returns the hover information at the specified position.
470 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
472 let params = TextDocumentPositionParams doc pos
473 in getResponseResult <$> sendRequest TextDocumentHover params
475 -- | Returns the highlighted occurences of the term at the specified position
476 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
477 getHighlights doc pos =
478 let params = TextDocumentPositionParams doc pos
479 in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params
481 -- | Checks the response for errors and throws an exception if needed.
482 -- Returns the result if successful.
483 getResponseResult :: ResponseMessage a -> a
484 getResponseResult rsp = fromMaybe exc (rsp ^. result)
485 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
486 (fromJust $ rsp ^. LSP.error)
488 -- | Applies formatting to the specified document.
489 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
490 formatDoc doc opts = do
491 let params = DocumentFormattingParams doc opts
492 edits <- getResponseResult <$> sendRequest TextDocumentFormatting params
493 applyTextEdits doc edits
495 -- | Applies formatting to the specified range in a document.
496 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
497 formatRange doc opts range = do
498 let params = DocumentRangeFormattingParams doc range opts
499 edits <- getResponseResult <$> sendRequest TextDocumentRangeFormatting params
500 applyTextEdits doc edits
502 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
503 applyTextEdits doc edits =
504 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
505 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
506 in updateState (ReqApplyWorkspaceEdit req)