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 (Either [DocumentSymbol] [SymbolInformation])
353 getDocumentSymbols doc = do
354 ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
355 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
357 Just (DSDocumentSymbols (List xs)) -> return (Left xs)
358 Just (DSSymbolInformation (List xs)) -> return (Right xs)
359 Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
361 -- | Returns all the code actions in a document by
362 -- querying the code actions at each of the current
363 -- diagnostics' positions.
364 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
365 getAllCodeActions doc = do
366 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
367 let ctx = CodeActionContext (List curDiags) Nothing
369 foldM (go ctx) [] curDiags
372 go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
374 ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
377 Just e -> throw (UnexpectedResponseError rspLid e)
379 let Just (List cmdOrCAs) = mRes
380 in return (acc ++ cmdOrCAs)
382 -- | Executes a command.
383 executeCommand :: Command -> Session ()
384 executeCommand cmd = do
385 let args = decode $ encode $ fromJust $ cmd ^. arguments
386 execParams = ExecuteCommandParams (cmd ^. command) args
387 request_ WorkspaceExecuteCommand execParams
389 -- | Executes a code action.
390 -- Matching with the specification, if a code action
391 -- contains both an edit and a command, the edit will
393 executeCodeAction :: CodeAction -> Session ()
394 executeCodeAction action = do
395 maybe (return ()) handleEdit $ action ^. edit
396 maybe (return ()) executeCommand $ action ^. command
398 where handleEdit :: WorkspaceEdit -> Session ()
400 -- Its ok to pass in dummy parameters here as they aren't used
401 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
402 in updateState (ReqApplyWorkspaceEdit req)
404 -- | Adds the current version to the document, as tracked by the session.
405 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
406 getVersionedDoc (TextDocumentIdentifier uri) = do
409 case fs Map.!? uri of
410 Just (VirtualFile v _) -> Just v
412 return (VersionedTextDocumentIdentifier uri ver)
414 -- | Applys an edit to the document and returns the updated document version.
415 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
416 applyEdit doc edit = do
418 verDoc <- getVersionedDoc doc
420 caps <- asks sessionCapabilities
422 let supportsDocChanges = fromMaybe False $ do
423 let ClientCapabilities mWorkspace _ _ = caps
424 WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
425 WorkspaceEditClientCapabilities mDocChanges <- mEdit
428 let wEdit = if supportsDocChanges
430 let docEdit = TextDocumentEdit verDoc (List [edit])
431 in WorkspaceEdit Nothing (Just (List [docEdit]))
433 let changes = HashMap.singleton (doc ^. uri) (List [edit])
434 in WorkspaceEdit (Just changes) Nothing
436 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
437 updateState (ReqApplyWorkspaceEdit req)
439 -- version may have changed
442 -- | Returns the completions for the position in the document.
443 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
444 getCompletions doc pos = do
445 rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
447 case getResponseResult rsp of
448 Completions (List items) -> return items
449 CompletionList (CompletionListType _ (List items)) -> return items
451 -- | Returns the references for the position in the document.
452 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
453 -> Position -- ^ The position to lookup.
454 -> Bool -- ^ Whether to include declarations as references.
455 -> Session [Location] -- ^ The locations of the references.
456 getReferences doc pos inclDecl =
457 let ctx = ReferenceContext inclDecl
458 params = ReferenceParams doc pos ctx
459 in getResponseResult <$> request TextDocumentReferences params
461 -- | Returns the definition(s) for the term at the specified position.
462 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
463 -> Position -- ^ The position the term is at.
464 -> Session [Location] -- ^ The location(s) of the definitions
465 getDefinitions doc pos =
466 let params = TextDocumentPositionParams doc pos
467 in getResponseResult <$> request TextDocumentDefinition params
469 -- | Renames the term at the specified position.
470 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
471 rename doc pos newName = do
472 let params = RenameParams doc pos (T.pack newName)
473 rsp <- request TextDocumentRename params :: Session RenameResponse
474 let wEdit = getResponseResult rsp
475 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
476 updateState (ReqApplyWorkspaceEdit req)
478 -- | Returns the hover information at the specified position.
479 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
481 let params = TextDocumentPositionParams doc pos
482 in getResponseResult <$> request TextDocumentHover params
484 -- | Returns the highlighted occurences of the term at the specified position
485 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
486 getHighlights doc pos =
487 let params = TextDocumentPositionParams doc pos
488 in getResponseResult <$> request TextDocumentDocumentHighlight params
490 -- | Checks the response for errors and throws an exception if needed.
491 -- Returns the result if successful.
492 getResponseResult :: ResponseMessage a -> a
493 getResponseResult rsp = fromMaybe exc (rsp ^. result)
494 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
495 (fromJust $ rsp ^. LSP.error)
497 -- | Applies formatting to the specified document.
498 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
499 formatDoc doc opts = do
500 let params = DocumentFormattingParams doc opts
501 edits <- getResponseResult <$> request TextDocumentFormatting params
502 applyTextEdits doc edits
504 -- | Applies formatting to the specified range in a document.
505 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
506 formatRange doc opts range = do
507 let params = DocumentRangeFormattingParams doc range opts
508 edits <- getResponseResult <$> request TextDocumentRangeFormatting params
509 applyTextEdits doc edits
511 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
512 applyTextEdits doc edits =
513 let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
514 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
515 in updateState (ReqApplyWorkspaceEdit req)