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 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers> at the JSON level.
14 module Language.Haskell.LSP.Test
18 , runSessionWithHandles
19 , runSessionWithConfig
22 , SessionException(..)
40 , publishDiagnosticsNotification
55 , waitForDiagnosticsSource
72 import Control.Applicative.Combinators
73 import Control.Concurrent
75 import Control.Monad.IO.Class
76 import Control.Exception
77 import Control.Lens hiding ((.=), List)
78 import qualified Data.Text as T
79 import qualified Data.Text.IO as T
82 import qualified Data.HashMap.Strict as HashMap
83 import qualified Data.Map as Map
85 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
86 import qualified Language.Haskell.LSP.Types as LSP
87 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
88 import Language.Haskell.LSP.Messages
89 import Language.Haskell.LSP.VFS
90 import Language.Haskell.LSP.Test.Compat
91 import Language.Haskell.LSP.Test.Decoding
92 import Language.Haskell.LSP.Test.Exceptions
93 import Language.Haskell.LSP.Test.Parsing
94 import Language.Haskell.LSP.Test.Session
95 import Language.Haskell.LSP.Test.Server
97 import System.Directory
98 import System.FilePath
99 import qualified Yi.Rope as Rope
101 -- | Starts a new session.
102 runSession :: String -- ^ The command to run the server.
103 -> FilePath -- ^ The filepath to the root directory for the session.
104 -> Session a -- ^ The session to run.
106 runSession = runSessionWithConfig def
108 -- | Starts a new sesion with a client with the specified capabilities.
109 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
110 -> 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 runSessionWithConfig config serverExe rootDir session = do
115 pid <- getCurrentProcessID
116 absRootDir <- canonicalizePath rootDir
118 let initializeParams = InitializeParams (Just pid)
119 (Just $ T.pack absRootDir)
120 (Just $ filePathToUri absRootDir)
122 (capabilities config)
124 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
125 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
127 -- Wrap the session around initialize and shutdown calls
128 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
130 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
132 initRspVar <- initRsp <$> ask
133 liftIO $ putMVar initRspVar initRspMsg
135 sendNotification Initialized InitializedParams
137 -- Run the actual test
140 sendNotification Exit ExitParams
144 -- | Listens to the server output, makes sure it matches the record and
145 -- signals any semaphores
146 listenServer :: Handle -> SessionContext -> IO ()
147 listenServer serverOut context = do
148 msgBytes <- getNextMessage serverOut
150 reqMap <- readMVar $ requestMap context
152 let msg = decodeFromServerMsg reqMap msgBytes
153 writeChan (messageChan context) (ServerMessage msg)
155 listenServer serverOut context
157 -- | The current text contents of a document.
158 documentContents :: TextDocumentIdentifier -> Session T.Text
159 documentContents doc = do
161 let file = vfs Map.! (doc ^. uri)
162 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
164 -- | Parses an ApplyEditRequest, checks that it is for the passed document
165 -- and returns the new content
166 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
167 getDocumentEdit doc = do
168 req <- message :: Session ApplyWorkspaceEditRequest
170 unless (checkDocumentChanges req || checkChanges req) $
171 liftIO $ throw (IncorrectApplyEditRequest (show req))
175 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
176 checkDocumentChanges req =
177 let changes = req ^. params . edit . documentChanges
178 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
180 Just docs -> (doc ^. uri) `elem` docs
182 checkChanges :: ApplyWorkspaceEditRequest -> Bool
184 let mMap = req ^. params . edit . changes
185 in maybe False (HashMap.member (doc ^. uri)) mMap
187 -- | Sends a request to the server and waits for its response.
189 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
191 -- Note: will skip any messages in between the request and the response.
192 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
193 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
195 -- | Send a request to the server and wait for its response,
197 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
198 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
200 -- | Sends a request to the server without waiting on the response.
203 => ClientMethod -- ^ The request method.
204 -> params -- ^ The request parameters.
205 -> Session LspId -- ^ The id of the request that was sent.
206 sendRequest' method params = do
207 id <- curReqId <$> get
208 modify $ \c -> c { curReqId = nextId id }
210 let req = RequestMessage' "2.0" id method params
212 -- Update the request map
213 reqMap <- requestMap <$> ask
214 liftIO $ modifyMVar_ reqMap $
215 \r -> return $ updateRequestMap r id method
221 where nextId (IdInt i) = IdInt (i + 1)
222 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
224 -- | A custom type for request message that doesn't
225 -- need a response type, allows us to infer the request
226 -- message type without using proxies.
227 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
229 instance ToJSON a => ToJSON (RequestMessage' a) where
230 toJSON (RequestMessage' rpc id method params) =
231 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
234 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
235 sendRequestMessage req = do
236 -- Update the request map
237 reqMap <- requestMap <$> ask
238 liftIO $ modifyMVar_ reqMap $
239 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
243 -- | Sends a notification to the server.
244 sendNotification :: ToJSON a
245 => ClientMethod -- ^ The notification method.
246 -> a -- ^ The notification parameters.
249 -- | Open a virtual file if we send a did open text document notification
250 sendNotification TextDocumentDidOpen params = do
251 let params' = fromJust $ decode $ encode params
252 n :: DidOpenTextDocumentNotification
253 n = NotificationMessage "2.0" TextDocumentDidOpen params'
254 oldVFS <- vfs <$> get
255 newVFS <- liftIO $ openVFS oldVFS n
256 modify (\s -> s { vfs = newVFS })
259 -- | Close a virtual file if we send a close text document notification
260 sendNotification TextDocumentDidClose params = do
261 let params' = fromJust $ decode $ encode params
262 n :: DidCloseTextDocumentNotification
263 n = NotificationMessage "2.0" TextDocumentDidClose params'
264 oldVFS <- vfs <$> get
265 newVFS <- liftIO $ closeVFS oldVFS n
266 modify (\s -> s { vfs = newVFS })
269 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
271 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
272 sendNotification' = sendMessage
274 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
275 sendResponse = sendMessage
277 -- | Returns the initialize response that was received from the server.
278 -- The initialize requests and responses are not included the session,
279 -- so if you need to test it use this.
280 initializeResponse :: Session InitializeResponse
281 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
283 -- | Opens a text document and sends a notification to the client.
284 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
285 openDoc file languageId = do
286 item <- getDocItem file languageId
287 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
288 TextDocumentIdentifier <$> getDocUri file
290 -- | Reads in a text document as the first version.
291 getDocItem :: FilePath -- ^ The path to the text document to read in.
292 -> String -- ^ The language ID, e.g "haskell" for .hs files.
293 -> Session TextDocumentItem
294 getDocItem file languageId = do
296 let fp = rootDir context </> file
297 contents <- liftIO $ T.readFile fp
298 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
300 -- | Gets the Uri for the file corrected to the session directory.
301 getDocUri :: FilePath -> Session Uri
304 let fp = rootDir context </> file
305 return $ filePathToUri fp
307 -- | Waits for diagnostics to be published and returns them.
308 waitForDiagnostics :: Session [Diagnostic]
309 waitForDiagnostics = do
310 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
311 let (List diags) = diagsNot ^. params . LSP.diagnostics
314 waitForDiagnosticsSource :: String -> Session [Diagnostic]
315 waitForDiagnosticsSource src = do
316 diags <- waitForDiagnostics
317 let res = filter matches diags
319 then waitForDiagnosticsSource src
322 matches :: Diagnostic -> Bool
323 matches d = d ^. source == Just (T.pack src)
325 -- | Expects a 'PublishDiagnosticsNotification' and throws an
326 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
328 noDiagnostics :: Session ()
330 diagsNot <- message :: Session PublishDiagnosticsNotification
331 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
333 -- | Returns the symbols in a document.
334 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
335 getDocumentSymbols doc = do
336 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
337 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
338 let (Just (List symbols)) = mRes
341 -- | Returns all the code actions in a document by
342 -- querying the code actions at each of the current
343 -- diagnostics' positions.
344 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
345 getAllCodeActions doc = do
346 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
347 let ctx = CodeActionContext (List curDiags) Nothing
349 foldM (go ctx) [] curDiags
352 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
354 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
357 Just e -> throw (UnexpectedResponseError rspLid e)
359 let Just (List cmdOrCAs) = mRes
360 in return (acc ++ cmdOrCAs)
362 -- | Executes a command.
363 executeCommand :: Command -> Session ()
364 executeCommand cmd = do
365 let args = decode $ encode $ fromJust $ cmd ^. arguments
366 execParams = ExecuteCommandParams (cmd ^. command) args
367 sendRequest_ WorkspaceExecuteCommand execParams
369 -- | Executes a code action.
370 -- Matching with the specification, if a code action
371 -- contains both an edit and a command, the edit will
373 executeCodeAction :: CodeAction -> Session ()
374 executeCodeAction action = do
375 maybe (return ()) handleEdit $ action ^. edit
376 maybe (return ()) executeCommand $ action ^. command
378 where handleEdit :: WorkspaceEdit -> Session ()
380 -- Its ok to pass in dummy parameters here as they aren't used
381 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
382 in updateState (ReqApplyWorkspaceEdit req)
384 -- | Adds the current version to the document, as tracked by the session.
385 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
386 getVersionedDoc (TextDocumentIdentifier uri) = do
389 case fs Map.!? uri of
390 Just (VirtualFile v _) -> Just v
392 return (VersionedTextDocumentIdentifier uri ver)
394 -- | Applys an edit to the document and returns the updated document version.
395 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
396 applyEdit doc edit = do
398 verDoc <- getVersionedDoc doc
400 caps <- asks (capabilities . config)
402 let supportsDocChanges = fromMaybe False $ do
403 let LSP.ClientCapabilities mWorkspace _ _ = caps
404 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
405 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
408 let wEdit = if supportsDocChanges
410 let docEdit = TextDocumentEdit verDoc (List [edit])
411 in WorkspaceEdit Nothing (Just (List [docEdit]))
413 let changes = HashMap.singleton (doc ^. uri) (List [edit])
414 in WorkspaceEdit (Just changes) Nothing
416 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
417 updateState (ReqApplyWorkspaceEdit req)
419 -- version may have changed
422 -- | Returns the completions for the position in the document.
423 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
424 getCompletions doc pos = do
425 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
427 case getResponseResult rsp of
428 Completions (List items) -> return items
429 CompletionList (CompletionListType _ (List items)) -> return items
431 -- | Returns the references for the position in the document.
432 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
433 -> Position -- ^ The position to lookup.
434 -> Bool -- ^ Whether to include declarations as references.
435 -> Session [Location] -- ^ The locations of the references.
436 getReferences doc pos inclDecl =
437 let ctx = ReferenceContext inclDecl
438 params = ReferenceParams doc pos ctx
439 in fromMaybe [] . (^. result) <$> sendRequest TextDocumentReferences params
441 -- ^ Renames the term at the specified position.
442 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
443 rename doc pos newName = do
444 let params = RenameParams doc pos (T.pack newName)
445 rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
446 let wEdit = getResponseResult rsp
447 req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
448 updateState (ReqApplyWorkspaceEdit req)
450 -- | Checks the response for errors and throws an exception if needed.
451 -- Returns the result if successful.
452 getResponseResult :: ResponseMessage a -> a
453 getResponseResult rsp = fromMaybe exc (rsp ^. result)
454 where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
455 (fromJust $ rsp ^. LSP.error)