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
76 import Control.Applicative.Combinators
77 import Control.Concurrent
79 import Control.Monad.IO.Class
80 import Control.Exception
81 import Control.Lens hiding ((.=), List)
82 import qualified Data.Text as T
83 import qualified Data.Text.IO as T
86 import qualified Data.HashMap.Strict as HashMap
87 import qualified Data.Map as Map
89 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
90 import qualified Language.Haskell.LSP.Types as LSP
91 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
92 import Language.Haskell.LSP.Messages
93 import Language.Haskell.LSP.VFS
94 import Language.Haskell.LSP.Test.Compat
95 import Language.Haskell.LSP.Test.Decoding
96 import Language.Haskell.LSP.Test.Exceptions
97 import Language.Haskell.LSP.Test.Parsing
98 import Language.Haskell.LSP.Test.Session
99 import Language.Haskell.LSP.Test.Server
101 import System.Directory
102 import System.FilePath
103 import qualified Yi.Rope as Rope
105 -- | Starts a new session.
106 runSession :: String -- ^ The command to run the server.
107 -> FilePath -- ^ The filepath to the root directory for the session.
108 -> Session a -- ^ The session to run.
110 runSession = runSessionWithConfig def
112 -- | Starts a new sesion with a client with the specified capabilities.
113 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
114 -> String -- ^ The command to run the server.
115 -> FilePath -- ^ The filepath to the root directory for the session.
116 -> Session a -- ^ The session to run.
118 runSessionWithConfig config serverExe rootDir session = do
119 pid <- getCurrentProcessID
120 absRootDir <- canonicalizePath rootDir
122 let initializeParams = InitializeParams (Just pid)
123 (Just $ T.pack absRootDir)
124 (Just $ filePathToUri absRootDir)
126 (capabilities config)
128 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
129 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
131 -- Wrap the session around initialize and shutdown calls
132 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
134 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
136 initRspVar <- initRsp <$> ask
137 liftIO $ putMVar initRspVar initRspMsg
139 sendNotification Initialized InitializedParams
141 -- Run the actual test
144 sendNotification Exit ExitParams
148 -- | Listens to the server output, makes sure it matches the record and
149 -- signals any semaphores
150 listenServer :: Handle -> SessionContext -> IO ()
151 listenServer serverOut context = do
152 msgBytes <- getNextMessage serverOut
154 reqMap <- readMVar $ requestMap context
156 let msg = decodeFromServerMsg reqMap msgBytes
157 writeChan (messageChan context) (ServerMessage msg)
159 listenServer serverOut context
161 -- | The current text contents of a document.
162 documentContents :: TextDocumentIdentifier -> Session T.Text
163 documentContents doc = do
165 let file = vfs Map.! (doc ^. uri)
166 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
168 -- | Parses an ApplyEditRequest, checks that it is for the passed document
169 -- and returns the new content
170 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
171 getDocumentEdit doc = do
172 req <- message :: Session ApplyWorkspaceEditRequest
174 unless (checkDocumentChanges req || checkChanges req) $
175 liftIO $ throw (IncorrectApplyEditRequest (show req))
179 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
180 checkDocumentChanges req =
181 let changes = req ^. params . edit . documentChanges
182 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
184 Just docs -> (doc ^. uri) `elem` docs
186 checkChanges :: ApplyWorkspaceEditRequest -> Bool
188 let mMap = req ^. params . edit . changes
189 in maybe False (HashMap.member (doc ^. uri)) mMap
191 -- | Sends a request to the server and waits for its response.
193 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
195 -- Note: will skip any messages in between the request and the response.
196 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
197 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
199 -- | Send a request to the server and wait for its response,
201 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
202 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
204 -- | Sends a request to the server without waiting on the response.
207 => ClientMethod -- ^ The request method.
208 -> params -- ^ The request parameters.
209 -> Session LspId -- ^ The id of the request that was sent.
210 sendRequest' method params = do
211 id <- curReqId <$> get
212 modify $ \c -> c { curReqId = nextId id }
214 let req = RequestMessage' "2.0" id method params
216 -- Update the request map
217 reqMap <- requestMap <$> ask
218 liftIO $ modifyMVar_ reqMap $
219 \r -> return $ updateRequestMap r id method
225 where nextId (IdInt i) = IdInt (i + 1)
226 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
228 -- | A custom type for request message that doesn't
229 -- need a response type, allows us to infer the request
230 -- message type without using proxies.
231 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
233 instance ToJSON a => ToJSON (RequestMessage' a) where
234 toJSON (RequestMessage' rpc id method params) =
235 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
238 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
239 sendRequestMessage req = do
240 -- Update the request map
241 reqMap <- requestMap <$> ask
242 liftIO $ modifyMVar_ reqMap $
243 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
247 -- | Sends a notification to the server.
248 sendNotification :: ToJSON a
249 => ClientMethod -- ^ The notification method.
250 -> a -- ^ The notification parameters.
253 -- | Open a virtual file if we send a did open text document notification
254 sendNotification TextDocumentDidOpen params = do
255 let params' = fromJust $ decode $ encode params
256 n :: DidOpenTextDocumentNotification
257 n = NotificationMessage "2.0" TextDocumentDidOpen params'
258 oldVFS <- vfs <$> get
259 newVFS <- liftIO $ openVFS oldVFS n
260 modify (\s -> s { vfs = newVFS })
263 -- | Close a virtual file if we send a close text document notification
264 sendNotification TextDocumentDidClose params = do
265 let params' = fromJust $ decode $ encode params
266 n :: DidCloseTextDocumentNotification
267 n = NotificationMessage "2.0" TextDocumentDidClose params'
268 oldVFS <- vfs <$> get
269 newVFS <- liftIO $ closeVFS oldVFS n
270 modify (\s -> s { vfs = newVFS })
273 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
275 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
276 sendNotification' = sendMessage
278 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
279 sendResponse = sendMessage
281 -- | Returns the initialize response that was received from the server.
282 -- The initialize requests and responses are not included the session,
283 -- so if you need to test it use this.
284 initializeResponse :: Session InitializeResponse
285 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
287 -- | Opens a text document and sends a notification to the client.
288 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
289 openDoc file languageId = do
290 item <- getDocItem file languageId
291 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
292 TextDocumentIdentifier <$> getDocUri file
294 -- | Reads in a text document as the first version.
295 getDocItem :: FilePath -- ^ The path to the text document to read in.
296 -> String -- ^ The language ID, e.g "haskell" for .hs files.
297 -> Session TextDocumentItem
298 getDocItem file languageId = do
300 let fp = rootDir context </> file
301 contents <- liftIO $ T.readFile fp
302 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
304 -- | Gets the Uri for the file corrected to the session directory.
305 getDocUri :: FilePath -> Session Uri
308 let fp = rootDir context </> file
309 return $ filePathToUri fp
311 -- | Waits for diagnostics to be published and returns them.
312 waitForDiagnostics :: Session [Diagnostic]
313 waitForDiagnostics = do
314 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
315 let (List diags) = diagsNot ^. params . LSP.diagnostics
318 waitForDiagnosticsSource :: String -> Session [Diagnostic]
319 waitForDiagnosticsSource src = do
320 diags <- waitForDiagnostics
321 let res = filter matches diags
323 then waitForDiagnosticsSource src
326 matches :: Diagnostic -> Bool
327 matches d = d ^. source == Just (T.pack src)
329 -- | Expects a 'PublishDiagnosticsNotification' and throws an
330 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
332 noDiagnostics :: Session ()
334 diagsNot <- message :: Session PublishDiagnosticsNotification
335 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
337 -- | Returns the symbols in a document.
338 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
339 getDocumentSymbols doc = do
340 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
341 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
342 let (Just (List symbols)) = mRes
345 -- | Returns all the code actions in a document by
346 -- querying the code actions at each of the current
347 -- diagnostics' positions.
348 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
349 getAllCodeActions doc = do
350 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
351 let ctx = CodeActionContext (List curDiags) Nothing
353 foldM (go ctx) [] curDiags
356 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
358 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
361 Just e -> throw (UnexpectedResponseError rspLid e)
363 let Just (List cmdOrCAs) = mRes
364 in return (acc ++ cmdOrCAs)
366 -- | Executes a command.
367 executeCommand :: Command -> Session ()
368 executeCommand cmd = do
369 let args = decode $ encode $ fromJust $ cmd ^. arguments
370 execParams = ExecuteCommandParams (cmd ^. command) args
371 sendRequest_ WorkspaceExecuteCommand execParams
373 -- | Executes a code action.
374 -- Matching with the specification, if a code action
375 -- contains both an edit and a command, the edit will
377 executeCodeAction :: CodeAction -> Session ()
378 executeCodeAction action = do
379 maybe (return ()) handleEdit $ action ^. edit
380 maybe (return ()) executeCommand $ action ^. command
382 where handleEdit :: WorkspaceEdit -> Session ()
384 -- Its ok to pass in dummy parameters here as they aren't used
385 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
386 in updateState (ReqApplyWorkspaceEdit req)
388 -- | Adds the current version to the document, as tracked by the session.
389 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
390 getVersionedDoc (TextDocumentIdentifier uri) = do
393 case fs Map.!? uri of
394 Just (VirtualFile v _) -> Just v
396 return (VersionedTextDocumentIdentifier uri ver)
398 -- | Applys an edit to the document and returns the updated document version.
399 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
400 applyEdit doc edit = do
402 verDoc <- getVersionedDoc doc
404 caps <- asks (capabilities . config)
406 let supportsDocChanges = fromMaybe False $ do
407 let LSP.ClientCapabilities mWorkspace _ _ = caps
408 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
409 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
412 let wEdit = if supportsDocChanges
414 let docEdit = TextDocumentEdit verDoc (List [edit])
415 in WorkspaceEdit Nothing (Just (List [docEdit]))
417 let changes = HashMap.singleton (doc ^. uri) (List [edit])
418 in WorkspaceEdit (Just changes) Nothing
420 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
421 updateState (ReqApplyWorkspaceEdit req)
423 -- version may have changed
426 -- | Returns the completions for the position in the document.
427 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
428 getCompletions doc pos = do
429 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
431 case getResponseResult rsp of
432 Completions (List items) -> return items
433 CompletionList (CompletionListType _ (List items)) -> return items
435 -- | Returns the references for the position in the document.
436 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
437 -> Position -- ^ The position to lookup.
438 -> Bool -- ^ Whether to include declarations as references.
439 -> Session [Location] -- ^ The locations of the references.
440 getReferences doc pos inclDecl =
441 let ctx = ReferenceContext inclDecl
442 params = ReferenceParams doc pos ctx
443 in getResponseResult <$> sendRequest TextDocumentReferences params
445 -- | Returns the definition(s) for the term at the specified position.
446 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
447 -> Position -- ^ The position the term is at.
448 -> Session [Location] -- ^ The location(s) of the definitions
449 getDefinitions doc pos =
450 let params = TextDocumentPositionParams doc pos
451 in getResponseResult <$> sendRequest TextDocumentDefinition params
453 -- ^ Renames the term at the specified position.
454 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
455 rename doc pos newName = do
456 let params = RenameParams doc pos (T.pack newName)
457 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
458 let wEdit = getResponseResult rsp
459 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
460 updateState (ReqApplyWorkspaceEdit req)
462 -- | Checks the response for errors and throws an exception if needed.
463 -- Returns the result if successful.
464 getResponseResult :: ResponseMessage a -> a
465 getResponseResult rsp = fromMaybe exc (rsp ^. result)
466 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
467 (fromJust $ rsp ^. LSP.error)