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
80 import Control.Applicative.Combinators
81 import Control.Concurrent
83 import Control.Monad.IO.Class
84 import Control.Exception
85 import Control.Lens hiding ((.=), List)
86 import qualified Data.Text as T
87 import qualified Data.Text.IO as T
90 import qualified Data.HashMap.Strict as HashMap
91 import qualified Data.Map as Map
93 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
94 import qualified Language.Haskell.LSP.Types as LSP
95 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
96 import Language.Haskell.LSP.Messages
97 import Language.Haskell.LSP.VFS
98 import Language.Haskell.LSP.Test.Compat
99 import Language.Haskell.LSP.Test.Decoding
100 import Language.Haskell.LSP.Test.Exceptions
101 import Language.Haskell.LSP.Test.Parsing
102 import Language.Haskell.LSP.Test.Session
103 import Language.Haskell.LSP.Test.Server
105 import System.Directory
106 import System.FilePath
107 import qualified Yi.Rope as Rope
109 -- | Starts a new session.
110 runSession :: String -- ^ The command to run the server.
111 -> FilePath -- ^ The filepath to the root directory for the session.
112 -> Session a -- ^ The session to run.
114 runSession = runSessionWithConfig def
116 -- | Starts a new sesion with a client with the specified capabilities.
117 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
118 -> String -- ^ The command to run the server.
119 -> FilePath -- ^ The filepath to the root directory for the session.
120 -> Session a -- ^ The session to run.
122 runSessionWithConfig config serverExe rootDir session = do
123 pid <- getCurrentProcessID
124 absRootDir <- canonicalizePath rootDir
126 let initializeParams = InitializeParams (Just pid)
127 (Just $ T.pack absRootDir)
128 (Just $ filePathToUri absRootDir)
130 (capabilities config)
132 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
133 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
135 -- Wrap the session around initialize and shutdown calls
136 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
138 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
140 initRspVar <- initRsp <$> ask
141 liftIO $ putMVar initRspVar initRspMsg
143 sendNotification Initialized InitializedParams
145 -- Run the actual test
148 sendNotification Exit ExitParams
152 -- | Listens to the server output, makes sure it matches the record and
153 -- signals any semaphores
154 listenServer :: Handle -> SessionContext -> IO ()
155 listenServer serverOut context = do
156 msgBytes <- getNextMessage serverOut
158 reqMap <- readMVar $ requestMap context
160 let msg = decodeFromServerMsg reqMap msgBytes
161 writeChan (messageChan context) (ServerMessage msg)
163 listenServer serverOut context
165 -- | The current text contents of a document.
166 documentContents :: TextDocumentIdentifier -> Session T.Text
167 documentContents doc = do
169 let file = vfs Map.! (doc ^. uri)
170 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
172 -- | Parses an ApplyEditRequest, checks that it is for the passed document
173 -- and returns the new content
174 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
175 getDocumentEdit doc = do
176 req <- message :: Session ApplyWorkspaceEditRequest
178 unless (checkDocumentChanges req || checkChanges req) $
179 liftIO $ throw (IncorrectApplyEditRequest (show req))
183 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
184 checkDocumentChanges req =
185 let changes = req ^. params . edit . documentChanges
186 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
188 Just docs -> (doc ^. uri) `elem` docs
190 checkChanges :: ApplyWorkspaceEditRequest -> Bool
192 let mMap = req ^. params . edit . changes
193 in maybe False (HashMap.member (doc ^. uri)) mMap
195 -- | Sends a request to the server and waits for its response.
197 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
199 -- Note: will skip any messages in between the request and the response.
200 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
201 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
203 -- | Send a request to the server and wait for its response,
205 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
206 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
208 -- | Sends a request to the server without waiting on the response.
211 => ClientMethod -- ^ The request method.
212 -> params -- ^ The request parameters.
213 -> Session LspId -- ^ The id of the request that was sent.
214 sendRequest' method params = do
215 id <- curReqId <$> get
216 modify $ \c -> c { curReqId = nextId id }
218 let req = RequestMessage' "2.0" id method params
220 -- Update the request map
221 reqMap <- requestMap <$> ask
222 liftIO $ modifyMVar_ reqMap $
223 \r -> return $ updateRequestMap r id method
229 where nextId (IdInt i) = IdInt (i + 1)
230 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
232 -- | A custom type for request message that doesn't
233 -- need a response type, allows us to infer the request
234 -- message type without using proxies.
235 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
237 instance ToJSON a => ToJSON (RequestMessage' a) where
238 toJSON (RequestMessage' rpc id method params) =
239 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
242 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
243 sendRequestMessage req = do
244 -- Update the request map
245 reqMap <- requestMap <$> ask
246 liftIO $ modifyMVar_ reqMap $
247 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
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 = sendNotification' (NotificationMessage "2.0" method params)
279 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
280 sendNotification' = sendMessage
282 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
283 sendResponse = sendMessage
285 -- | Returns the initialize response that was received from the server.
286 -- The initialize requests and responses are not included the session,
287 -- so if you need to test it use this.
288 initializeResponse :: Session InitializeResponse
289 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
291 -- | Opens a text document and sends a notification to the client.
292 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
293 openDoc file languageId = do
294 item <- getDocItem file languageId
295 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
296 TextDocumentIdentifier <$> getDocUri file
298 -- | Reads in a text document as the first version.
299 getDocItem :: FilePath -- ^ The path to the text document to read in.
300 -> String -- ^ The language ID, e.g "haskell" for .hs files.
301 -> Session TextDocumentItem
302 getDocItem file languageId = do
304 let fp = rootDir context </> file
305 contents <- liftIO $ T.readFile fp
306 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
308 -- | Gets the Uri for the file corrected to the session directory.
309 getDocUri :: FilePath -> Session Uri
312 let fp = rootDir context </> file
313 return $ filePathToUri fp
315 -- | Waits for diagnostics to be published and returns them.
316 waitForDiagnostics :: Session [Diagnostic]
317 waitForDiagnostics = do
318 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
319 let (List diags) = diagsNot ^. params . LSP.diagnostics
322 waitForDiagnosticsSource :: String -> Session [Diagnostic]
323 waitForDiagnosticsSource src = do
324 diags <- waitForDiagnostics
325 let res = filter matches diags
327 then waitForDiagnosticsSource src
330 matches :: Diagnostic -> Bool
331 matches d = d ^. source == Just (T.pack src)
333 -- | Expects a 'PublishDiagnosticsNotification' and throws an
334 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
336 noDiagnostics :: Session ()
338 diagsNot <- message :: Session PublishDiagnosticsNotification
339 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
341 -- | Returns the symbols in a document.
342 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
343 getDocumentSymbols doc = do
344 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
345 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
346 let (Just (List symbols)) = mRes
349 -- | Returns all the code actions in a document by
350 -- querying the code actions at each of the current
351 -- diagnostics' positions.
352 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
353 getAllCodeActions doc = do
354 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
355 let ctx = CodeActionContext (List curDiags) Nothing
357 foldM (go ctx) [] curDiags
360 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
362 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
365 Just e -> throw (UnexpectedResponseError rspLid e)
367 let Just (List cmdOrCAs) = mRes
368 in return (acc ++ cmdOrCAs)
370 -- | Executes a command.
371 executeCommand :: Command -> Session ()
372 executeCommand cmd = do
373 let args = decode $ encode $ fromJust $ cmd ^. arguments
374 execParams = ExecuteCommandParams (cmd ^. command) args
375 sendRequest_ WorkspaceExecuteCommand execParams
377 -- | Executes a code action.
378 -- Matching with the specification, if a code action
379 -- contains both an edit and a command, the edit will
381 executeCodeAction :: CodeAction -> Session ()
382 executeCodeAction action = do
383 maybe (return ()) handleEdit $ action ^. edit
384 maybe (return ()) executeCommand $ action ^. command
386 where handleEdit :: WorkspaceEdit -> Session ()
388 -- Its ok to pass in dummy parameters here as they aren't used
389 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
390 in updateState (ReqApplyWorkspaceEdit req)
392 -- | Adds the current version to the document, as tracked by the session.
393 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
394 getVersionedDoc (TextDocumentIdentifier uri) = do
397 case fs Map.!? uri of
398 Just (VirtualFile v _) -> Just v
400 return (VersionedTextDocumentIdentifier uri ver)
402 -- | Applys an edit to the document and returns the updated document version.
403 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
404 applyEdit doc edit = do
406 verDoc <- getVersionedDoc doc
408 caps <- asks (capabilities . config)
410 let supportsDocChanges = fromMaybe False $ do
411 let LSP.ClientCapabilities mWorkspace _ _ = caps
412 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
413 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
416 let wEdit = if supportsDocChanges
418 let docEdit = TextDocumentEdit verDoc (List [edit])
419 in WorkspaceEdit Nothing (Just (List [docEdit]))
421 let changes = HashMap.singleton (doc ^. uri) (List [edit])
422 in WorkspaceEdit (Just changes) Nothing
424 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
425 updateState (ReqApplyWorkspaceEdit req)
427 -- version may have changed
430 -- | Returns the completions for the position in the document.
431 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
432 getCompletions doc pos = do
433 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
435 case getResponseResult rsp of
436 Completions (List items) -> return items
437 CompletionList (CompletionListType _ (List items)) -> return items
439 -- | Returns the references for the position in the document.
440 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
441 -> Position -- ^ The position to lookup.
442 -> Bool -- ^ Whether to include declarations as references.
443 -> Session [Location] -- ^ The locations of the references.
444 getReferences doc pos inclDecl =
445 let ctx = ReferenceContext inclDecl
446 params = ReferenceParams doc pos ctx
447 in getResponseResult <$> sendRequest TextDocumentReferences params
449 -- | Returns the definition(s) for the term at the specified position.
450 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
451 -> Position -- ^ The position the term is at.
452 -> Session [Location] -- ^ The location(s) of the definitions
453 getDefinitions doc pos =
454 let params = TextDocumentPositionParams doc pos
455 in getResponseResult <$> sendRequest TextDocumentDefinition params
457 -- ^ Renames the term at the specified position.
458 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
459 rename doc pos newName = do
460 let params = RenameParams doc pos (T.pack newName)
461 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
462 let wEdit = getResponseResult rsp
463 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
464 updateState (ReqApplyWorkspaceEdit req)
466 -- ^ Returns the hover information at the specified position.
467 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
469 let params = TextDocumentPositionParams doc pos
470 in getResponseResult <$> sendRequest TextDocumentHover params
472 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
473 getHighlights doc pos =
474 let params = TextDocumentPositionParams doc pos
475 in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params
477 -- | Checks the response for errors and throws an exception if needed.
478 -- Returns the result if successful.
479 getResponseResult :: ResponseMessage a -> a
480 getResponseResult rsp = fromMaybe exc (rsp ^. result)
481 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
482 (fromJust $ rsp ^. LSP.error)