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.Test.Capabilities
28 , module Language.Haskell.LSP.Test.Exceptions
37 , module Language.Haskell.LSP.Test.Parsing
39 -- | Quick helper functions for common tasks.
53 , waitForDiagnosticsSource
79 import Control.Applicative.Combinators
80 import Control.Concurrent
82 import Control.Monad.IO.Class
83 import Control.Exception
84 import Control.Lens hiding ((.=), List)
85 import qualified Data.Text as T
86 import qualified Data.Text.IO as T
89 import qualified Data.HashMap.Strict as HashMap
90 import qualified Data.Map as Map
92 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
93 import qualified Language.Haskell.LSP.Types as LSP
94 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
95 import Language.Haskell.LSP.Messages
96 import Language.Haskell.LSP.VFS
97 import Language.Haskell.LSP.Test.Capabilities
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.
111 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
112 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
113 -- > diags <- waitForDiagnostics
114 -- > let pos = Position 12 5
115 -- > params = TextDocumentPositionParams doc
116 -- > hover <- request TextDocumentHover params
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 custom configuration.
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 -- | Sends a response to the server.
280 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
281 sendResponse = sendMessage
283 -- | Returns the initialize response that was received from the server.
284 -- The initialize requests and responses are not included the session,
285 -- so if you need to test it use this.
286 initializeResponse :: Session InitializeResponse
287 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
289 -- | Opens a text document and sends a notification to the client.
290 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
291 openDoc file languageId = do
292 item <- getDocItem file languageId
293 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
294 TextDocumentIdentifier <$> getDocUri file
296 -- | Reads in a text document as the first version.
297 getDocItem :: FilePath -- ^ The path to the text document to read in.
298 -> String -- ^ The language ID, e.g "haskell" for .hs files.
299 -> Session TextDocumentItem
300 getDocItem file languageId = do
302 let fp = rootDir context </> file
303 contents <- liftIO $ T.readFile fp
304 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
306 -- | Closes a text document and sends a notification to the client.
307 closeDoc :: TextDocumentIdentifier -> Session ()
309 let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
310 sendNotification TextDocumentDidClose params
312 oldVfs <- vfs <$> get
313 let notif = NotificationMessage "" TextDocumentDidClose params
314 newVfs <- liftIO $ closeVFS oldVfs notif
315 modify $ \s -> s { vfs = newVfs }
317 -- | Gets the Uri for the file corrected to the session directory.
318 getDocUri :: FilePath -> Session Uri
321 let fp = rootDir context </> file
322 return $ filePathToUri fp
324 -- | Waits for diagnostics to be published and returns them.
325 waitForDiagnostics :: Session [Diagnostic]
326 waitForDiagnostics = do
327 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
328 let (List diags) = diagsNot ^. params . LSP.diagnostics
331 -- | The same as 'waitForDiagnostics', but will only match a specific
332 -- 'Language.Haskell.LSP.Types._source'.
333 waitForDiagnosticsSource :: String -> Session [Diagnostic]
334 waitForDiagnosticsSource src = do
335 diags <- waitForDiagnostics
336 let res = filter matches diags
338 then waitForDiagnosticsSource src
341 matches :: Diagnostic -> Bool
342 matches d = d ^. source == Just (T.pack src)
344 -- | Expects a 'PublishDiagnosticsNotification' and throws an
345 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
347 noDiagnostics :: Session ()
349 diagsNot <- message :: Session PublishDiagnosticsNotification
350 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
352 -- | Returns the symbols in a document.
353 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
354 getDocumentSymbols doc = do
355 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc)
356 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
357 let (Just (List symbols)) = mRes
360 -- | Returns all the code actions in a document by
361 -- querying the code actions at each of the current
362 -- diagnostics' positions.
363 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
364 getAllCodeActions doc = do
365 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
366 let ctx = CodeActionContext (List curDiags) Nothing
368 foldM (go ctx) [] curDiags
371 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
373 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
376 Just e -> throw (UnexpectedResponseError rspLid e)
378 let Just (List cmdOrCAs) = mRes
379 in return (acc ++ cmdOrCAs)
381 -- | Executes a command.
382 executeCommand :: Command -> Session ()
383 executeCommand cmd = do
384 let args = decode $ encode $ fromJust $ cmd ^. arguments
385 execParams = ExecuteCommandParams (cmd ^. command) args
386 request_ WorkspaceExecuteCommand execParams
388 -- | Executes a code action.
389 -- Matching with the specification, if a code action
390 -- contains both an edit and a command, the edit will
392 executeCodeAction :: CodeAction -> Session ()
393 executeCodeAction action = do
394 maybe (return ()) handleEdit $ action ^. edit
395 maybe (return ()) executeCommand $ action ^. command
397 where handleEdit :: WorkspaceEdit -> Session ()
399 -- Its ok to pass in dummy parameters here as they aren't used
400 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
401 in updateState (ReqApplyWorkspaceEdit req)
403 -- | Adds the current version to the document, as tracked by the session.
404 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
405 getVersionedDoc (TextDocumentIdentifier uri) = do
408 case fs Map.!? uri of
409 Just (VirtualFile v _) -> Just v
411 return (VersionedTextDocumentIdentifier uri ver)
413 -- | Applys an edit to the document and returns the updated document version.
414 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
415 applyEdit doc edit = do
417 verDoc <- getVersionedDoc doc
419 caps <- asks sessionCapabilities
421 let supportsDocChanges = fromMaybe False $ do
422 let LSP.ClientCapabilities mWorkspace _ _ = caps
423 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
424 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
427 let wEdit = if supportsDocChanges
429 let docEdit = TextDocumentEdit verDoc (List [edit])
430 in WorkspaceEdit Nothing (Just (List [docEdit]))
432 let changes = HashMap.singleton (doc ^. uri) (List [edit])
433 in WorkspaceEdit (Just changes) Nothing
435 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
436 updateState (ReqApplyWorkspaceEdit req)
438 -- version may have changed
441 -- | Returns the completions for the position in the document.
442 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
443 getCompletions doc pos = do
444 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
446 case getResponseResult rsp of
447 Completions (List items) -> return items
448 CompletionList (CompletionListType _ (List items)) -> return items
450 -- | Returns the references for the position in the document.
451 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
452 -> Position -- ^ The position to lookup.
453 -> Bool -- ^ Whether to include declarations as references.
454 -> Session [Location] -- ^ The locations of the references.
455 getReferences doc pos inclDecl =
456 let ctx = ReferenceContext inclDecl
457 params = ReferenceParams doc pos ctx
458 in getResponseResult <$> request TextDocumentReferences params
460 -- | Returns the definition(s) for the term at the specified position.
461 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
462 -> Position -- ^ The position the term is at.
463 -> Session [Location] -- ^ The location(s) of the definitions
464 getDefinitions doc pos =
465 let params = TextDocumentPositionParams doc pos
466 in getResponseResult <$> request TextDocumentDefinition params
468 -- | Renames the term at the specified position.
469 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
470 rename doc pos newName = do
471 let params = RenameParams doc pos (T.pack newName)
472 rsp <- request TextDocumentRename params :: Session RenameResponse
473 let wEdit = getResponseResult rsp
474 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
475 updateState (ReqApplyWorkspaceEdit req)
477 -- | Returns the hover information at the specified position.
478 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
480 let params = TextDocumentPositionParams doc pos
481 in getResponseResult <$> request TextDocumentHover params
483 -- | Returns the highlighted occurences of the term at the specified position
484 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
485 getHighlights doc pos =
486 let params = TextDocumentPositionParams doc pos
487 in getResponseResult <$> request TextDocumentDocumentHighlight params
489 -- | Checks the response for errors and throws an exception if needed.
490 -- Returns the result if successful.
491 getResponseResult :: ResponseMessage a -> a
492 getResponseResult rsp = fromMaybe exc (rsp ^. result)
493 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
494 (fromJust $ rsp ^. LSP.error)
496 -- | Applies formatting to the specified document.
497 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
498 formatDoc doc opts = do
499 let params = DocumentFormattingParams doc opts
500 edits <- getResponseResult <$> request TextDocumentFormatting params
501 applyTextEdits doc edits
503 -- | Applies formatting to the specified range in a document.
504 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
505 formatRange doc opts range = do
506 let params = DocumentRangeFormattingParams doc range opts
507 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
508 applyTextEdits doc edits
510 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
511 applyTextEdits doc edits =
512 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
513 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
514 in updateState (ReqApplyWorkspaceEdit req)