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.Types.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 Language.Haskell.LSP.Types.Capabilities
95 import Language.Haskell.LSP.Messages
96 import Language.Haskell.LSP.VFS
97 import Language.Haskell.LSP.Test.Compat
98 import Language.Haskell.LSP.Test.Decoding
99 import Language.Haskell.LSP.Test.Exceptions
100 import Language.Haskell.LSP.Test.Parsing
101 import Language.Haskell.LSP.Test.Session
102 import Language.Haskell.LSP.Test.Server
104 import System.Directory
105 import System.FilePath
106 import qualified Yi.Rope as Rope
108 -- | Starts a new session.
110 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
111 -- > doc <- openDoc "Desktop/simple.hs" "haskell"
112 -- > diags <- waitForDiagnostics
113 -- > let pos = Position 12 5
114 -- > params = TextDocumentPositionParams doc
115 -- > hover <- request TextDocumentHover params
116 runSession :: String -- ^ The command to run the server.
117 -> ClientCapabilities -- ^ The capabilities that the client should declare.
118 -> FilePath -- ^ The filepath to the root directory for the session.
119 -> Session a -- ^ The session to run.
121 runSession = runSessionWithConfig def
123 -- | Starts a new sesion with a custom configuration.
124 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
125 -> String -- ^ The command to run the server.
126 -> ClientCapabilities -- ^ The capabilities that the client should declare.
127 -> FilePath -- ^ The filepath to the root directory for the session.
128 -> Session a -- ^ The session to run.
130 runSessionWithConfig config serverExe caps rootDir session = do
131 pid <- getCurrentProcessID
132 absRootDir <- canonicalizePath rootDir
134 let initializeParams = InitializeParams (Just pid)
135 (Just $ T.pack absRootDir)
136 (Just $ filePathToUri absRootDir)
140 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
141 runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
143 -- Wrap the session around initialize and shutdown calls
144 initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
146 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
148 initRspVar <- initRsp <$> ask
149 liftIO $ putMVar initRspVar initRspMsg
151 sendNotification Initialized InitializedParams
153 -- Run the actual test
156 sendNotification Exit ExitParams
160 -- | Listens to the server output, makes sure it matches the record and
161 -- signals any semaphores
162 listenServer :: Handle -> SessionContext -> IO ()
163 listenServer serverOut context = do
164 msgBytes <- getNextMessage serverOut
166 reqMap <- readMVar $ requestMap context
168 let msg = decodeFromServerMsg reqMap msgBytes
169 writeChan (messageChan context) (ServerMessage msg)
171 listenServer serverOut context
173 -- | The current text contents of a document.
174 documentContents :: TextDocumentIdentifier -> Session T.Text
175 documentContents doc = do
177 let file = vfs Map.! (doc ^. uri)
178 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
180 -- | Parses an ApplyEditRequest, checks that it is for the passed document
181 -- and returns the new content
182 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
183 getDocumentEdit doc = do
184 req <- message :: Session ApplyWorkspaceEditRequest
186 unless (checkDocumentChanges req || checkChanges req) $
187 liftIO $ throw (IncorrectApplyEditRequest (show req))
191 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
192 checkDocumentChanges req =
193 let changes = req ^. params . edit . documentChanges
194 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
196 Just docs -> (doc ^. uri) `elem` docs
198 checkChanges :: ApplyWorkspaceEditRequest -> Bool
200 let mMap = req ^. params . edit . changes
201 in maybe False (HashMap.member (doc ^. uri)) mMap
203 -- | Sends a request to the server and waits for its response.
204 -- Will skip any messages in between the request and the response
206 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
208 -- Note: will skip any messages in between the request and the response.
209 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
210 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
212 -- | The same as 'sendRequest', but discard the response.
213 request_ :: ToJSON params => ClientMethod -> params -> Session ()
214 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
216 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
219 => ClientMethod -- ^ The request method.
220 -> params -- ^ The request parameters.
221 -> Session LspId -- ^ The id of the request that was sent.
222 sendRequest method params = do
223 id <- curReqId <$> get
224 modify $ \c -> c { curReqId = nextId id }
226 let req = RequestMessage' "2.0" id method params
228 -- Update the request map
229 reqMap <- requestMap <$> ask
230 liftIO $ modifyMVar_ reqMap $
231 \r -> return $ updateRequestMap r id method
237 where nextId (IdInt i) = IdInt (i + 1)
238 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
240 -- | A custom type for request message that doesn't
241 -- need a response type, allows us to infer the request
242 -- message type without using proxies.
243 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
245 instance ToJSON a => ToJSON (RequestMessage' a) where
246 toJSON (RequestMessage' rpc id method params) =
247 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
250 -- | Sends a notification to the server.
251 sendNotification :: ToJSON a
252 => ClientMethod -- ^ The notification method.
253 -> a -- ^ The notification parameters.
256 -- Open a virtual file if we send a did open text document notification
257 sendNotification TextDocumentDidOpen params = do
258 let params' = fromJust $ decode $ encode params
259 n :: DidOpenTextDocumentNotification
260 n = NotificationMessage "2.0" TextDocumentDidOpen params'
261 oldVFS <- vfs <$> get
262 newVFS <- liftIO $ openVFS oldVFS n
263 modify (\s -> s { vfs = newVFS })
266 -- Close a virtual file if we send a close text document notification
267 sendNotification TextDocumentDidClose params = do
268 let params' = fromJust $ decode $ encode params
269 n :: DidCloseTextDocumentNotification
270 n = NotificationMessage "2.0" TextDocumentDidClose params'
271 oldVFS <- vfs <$> get
272 newVFS <- liftIO $ closeVFS oldVFS n
273 modify (\s -> s { vfs = newVFS })
276 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
278 -- | Sends a response to the server.
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 -- | The same as 'waitForDiagnostics', but will only match a specific
331 -- 'Language.Haskell.LSP.Types._source'.
332 waitForDiagnosticsSource :: String -> Session [Diagnostic]
333 waitForDiagnosticsSource src = do
334 diags <- waitForDiagnostics
335 let res = filter matches diags
337 then waitForDiagnosticsSource src
340 matches :: Diagnostic -> Bool
341 matches d = d ^. source == Just (T.pack src)
343 -- | Expects a 'PublishDiagnosticsNotification' and throws an
344 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
346 noDiagnostics :: Session ()
348 diagsNot <- message :: Session PublishDiagnosticsNotification
349 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
351 -- | Returns the symbols in a document.
352 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
353 getDocumentSymbols doc = do
354 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc)
355 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
356 let (Just (List symbols)) = mRes
359 -- | Returns all the code actions in a document by
360 -- querying the code actions at each of the current
361 -- diagnostics' positions.
362 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
363 getAllCodeActions doc = do
364 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
365 let ctx = CodeActionContext (List curDiags) Nothing
367 foldM (go ctx) [] curDiags
370 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
372 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
375 Just e -> throw (UnexpectedResponseError rspLid e)
377 let Just (List cmdOrCAs) = mRes
378 in return (acc ++ cmdOrCAs)
380 -- | Executes a command.
381 executeCommand :: Command -> Session ()
382 executeCommand cmd = do
383 let args = decode $ encode $ fromJust $ cmd ^. arguments
384 execParams = ExecuteCommandParams (cmd ^. command) args
385 request_ WorkspaceExecuteCommand execParams
387 -- | Executes a code action.
388 -- Matching with the specification, if a code action
389 -- contains both an edit and a command, the edit will
391 executeCodeAction :: CodeAction -> Session ()
392 executeCodeAction action = do
393 maybe (return ()) handleEdit $ action ^. edit
394 maybe (return ()) executeCommand $ action ^. command
396 where handleEdit :: WorkspaceEdit -> Session ()
398 -- Its ok to pass in dummy parameters here as they aren't used
399 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
400 in updateState (ReqApplyWorkspaceEdit req)
402 -- | Adds the current version to the document, as tracked by the session.
403 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
404 getVersionedDoc (TextDocumentIdentifier uri) = do
407 case fs Map.!? uri of
408 Just (VirtualFile v _) -> Just v
410 return (VersionedTextDocumentIdentifier uri ver)
412 -- | Applys an edit to the document and returns the updated document version.
413 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
414 applyEdit doc edit = do
416 verDoc <- getVersionedDoc doc
418 caps <- asks sessionCapabilities
420 let supportsDocChanges = fromMaybe False $ do
421 let ClientCapabilities mWorkspace _ _ = caps
422 WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
423 WorkspaceEditClientCapabilities mDocChanges <- mEdit
426 let wEdit = if supportsDocChanges
428 let docEdit = TextDocumentEdit verDoc (List [edit])
429 in WorkspaceEdit Nothing (Just (List [docEdit]))
431 let changes = HashMap.singleton (doc ^. uri) (List [edit])
432 in WorkspaceEdit (Just changes) Nothing
434 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
435 updateState (ReqApplyWorkspaceEdit req)
437 -- version may have changed
440 -- | Returns the completions for the position in the document.
441 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
442 getCompletions doc pos = do
443 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
445 case getResponseResult rsp of
446 Completions (List items) -> return items
447 CompletionList (CompletionListType _ (List items)) -> return items
449 -- | Returns the references for the position in the document.
450 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
451 -> Position -- ^ The position to lookup.
452 -> Bool -- ^ Whether to include declarations as references.
453 -> Session [Location] -- ^ The locations of the references.
454 getReferences doc pos inclDecl =
455 let ctx = ReferenceContext inclDecl
456 params = ReferenceParams doc pos ctx
457 in getResponseResult <$> request TextDocumentReferences params
459 -- | Returns the definition(s) for the term at the specified position.
460 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
461 -> Position -- ^ The position the term is at.
462 -> Session [Location] -- ^ The location(s) of the definitions
463 getDefinitions doc pos =
464 let params = TextDocumentPositionParams doc pos
465 in getResponseResult <$> request TextDocumentDefinition params
467 -- | Renames the term at the specified position.
468 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
469 rename doc pos newName = do
470 let params = RenameParams doc pos (T.pack newName)
471 rsp <- request TextDocumentRename params :: Session RenameResponse
472 let wEdit = getResponseResult rsp
473 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
474 updateState (ReqApplyWorkspaceEdit req)
476 -- | Returns the hover information at the specified position.
477 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
479 let params = TextDocumentPositionParams doc pos
480 in getResponseResult <$> request TextDocumentHover params
482 -- | Returns the highlighted occurences of the term at the specified position
483 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
484 getHighlights doc pos =
485 let params = TextDocumentPositionParams doc pos
486 in getResponseResult <$> request TextDocumentDocumentHighlight params
488 -- | Checks the response for errors and throws an exception if needed.
489 -- Returns the result if successful.
490 getResponseResult :: ResponseMessage a -> a
491 getResponseResult rsp = fromMaybe exc (rsp ^. result)
492 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
493 (fromJust $ rsp ^. LSP.error)
495 -- | Applies formatting to the specified document.
496 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
497 formatDoc doc opts = do
498 let params = DocumentFormattingParams doc opts
499 edits <- getResponseResult <$> request TextDocumentFormatting params
500 applyTextEdits doc edits
502 -- | Applies formatting to the specified range in a document.
503 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
504 formatRange doc opts range = do
505 let params = DocumentRangeFormattingParams doc range opts
506 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
507 applyTextEdits doc edits
509 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
510 applyTextEdits doc edits =
511 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
512 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
513 in updateState (ReqApplyWorkspaceEdit req)