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
70 import Control.Applicative.Combinators
71 import Control.Concurrent
73 import Control.Monad.IO.Class
74 import Control.Exception
75 import Control.Lens hiding ((.=), List)
76 import qualified Data.Text as T
77 import qualified Data.Text.IO as T
80 import qualified Data.HashMap.Strict as HashMap
81 import qualified Data.Map as Map
83 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
84 import qualified Language.Haskell.LSP.Types as LSP
85 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
86 import Language.Haskell.LSP.Messages
87 import Language.Haskell.LSP.VFS
88 import Language.Haskell.LSP.Test.Compat
89 import Language.Haskell.LSP.Test.Decoding
90 import Language.Haskell.LSP.Test.Exceptions
91 import Language.Haskell.LSP.Test.Parsing
92 import Language.Haskell.LSP.Test.Session
93 import Language.Haskell.LSP.Test.Server
95 import System.Directory
96 import System.FilePath
97 import qualified Yi.Rope as Rope
99 -- | Starts a new session.
100 runSession :: String -- ^ The command to run the server.
101 -> FilePath -- ^ The filepath to the root directory for the session.
102 -> Session a -- ^ The session to run.
104 runSession = runSessionWithConfig def
106 -- | Starts a new sesion with a client with the specified capabilities.
107 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
108 -> String -- ^ The command to run the server.
109 -> FilePath -- ^ The filepath to the root directory for the session.
110 -> Session a -- ^ The session to run.
112 runSessionWithConfig config serverExe rootDir session = do
113 pid <- getCurrentProcessID
114 absRootDir <- canonicalizePath rootDir
116 let initializeParams = InitializeParams (Just pid)
117 (Just $ T.pack absRootDir)
118 (Just $ filePathToUri absRootDir)
120 (capabilities config)
122 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
123 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
125 -- Wrap the session around initialize and shutdown calls
126 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
128 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
130 initRspVar <- initRsp <$> ask
131 liftIO $ putMVar initRspVar initRspMsg
133 sendNotification Initialized InitializedParams
135 -- Run the actual test
138 sendNotification Exit ExitParams
142 -- | Listens to the server output, makes sure it matches the record and
143 -- signals any semaphores
144 listenServer :: Handle -> SessionContext -> IO ()
145 listenServer serverOut context = do
146 msgBytes <- getNextMessage serverOut
148 reqMap <- readMVar $ requestMap context
150 let msg = decodeFromServerMsg reqMap msgBytes
151 writeChan (messageChan context) (ServerMessage msg)
153 listenServer serverOut context
155 -- | The current text contents of a document.
156 documentContents :: TextDocumentIdentifier -> Session T.Text
157 documentContents doc = do
159 let file = vfs Map.! (doc ^. uri)
160 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
162 -- | Parses an ApplyEditRequest, checks that it is for the passed document
163 -- and returns the new content
164 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
165 getDocumentEdit doc = do
166 req <- message :: Session ApplyWorkspaceEditRequest
168 unless (checkDocumentChanges req || checkChanges req) $
169 liftIO $ throw (IncorrectApplyEditRequest (show req))
173 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
174 checkDocumentChanges req =
175 let changes = req ^. params . edit . documentChanges
176 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
178 Just docs -> (doc ^. uri) `elem` docs
180 checkChanges :: ApplyWorkspaceEditRequest -> Bool
182 let mMap = req ^. params . edit . changes
183 in maybe False (HashMap.member (doc ^. uri)) mMap
185 -- | Sends a request to the server and waits for its response.
187 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
189 -- Note: will skip any messages in between the request and the response.
190 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
191 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
193 -- | Send a request to the server and wait for its response,
195 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
196 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
198 -- | Sends a request to the server without waiting on the response.
201 => ClientMethod -- ^ The request method.
202 -> params -- ^ The request parameters.
203 -> Session LspId -- ^ The id of the request that was sent.
204 sendRequest' method params = do
205 id <- curReqId <$> get
206 modify $ \c -> c { curReqId = nextId id }
208 let req = RequestMessage' "2.0" id method params
210 -- Update the request map
211 reqMap <- requestMap <$> ask
212 liftIO $ modifyMVar_ reqMap $
213 \r -> return $ updateRequestMap r id method
219 where nextId (IdInt i) = IdInt (i + 1)
220 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
222 -- | A custom type for request message that doesn't
223 -- need a response type, allows us to infer the request
224 -- message type without using proxies.
225 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
227 instance ToJSON a => ToJSON (RequestMessage' a) where
228 toJSON (RequestMessage' rpc id method params) =
229 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
232 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
233 sendRequestMessage req = do
234 -- Update the request map
235 reqMap <- requestMap <$> ask
236 liftIO $ modifyMVar_ reqMap $
237 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
241 -- | Sends a notification to the server.
242 sendNotification :: ToJSON a
243 => ClientMethod -- ^ The notification method.
244 -> a -- ^ The notification parameters.
247 -- | Open a virtual file if we send a did open text document notification
248 sendNotification TextDocumentDidOpen params = do
249 let params' = fromJust $ decode $ encode params
250 n :: DidOpenTextDocumentNotification
251 n = NotificationMessage "2.0" TextDocumentDidOpen params'
252 oldVFS <- vfs <$> get
253 newVFS <- liftIO $ openVFS oldVFS n
254 modify (\s -> s { vfs = newVFS })
257 -- | Close a virtual file if we send a close text document notification
258 sendNotification TextDocumentDidClose params = do
259 let params' = fromJust $ decode $ encode params
260 n :: DidCloseTextDocumentNotification
261 n = NotificationMessage "2.0" TextDocumentDidClose params'
262 oldVFS <- vfs <$> get
263 newVFS <- liftIO $ closeVFS oldVFS n
264 modify (\s -> s { vfs = newVFS })
267 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
269 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
270 sendNotification' = sendMessage
272 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
273 sendResponse = sendMessage
275 -- | Returns the initialize response that was received from the server.
276 -- The initialize requests and responses are not included the session,
277 -- so if you need to test it use this.
278 initializeResponse :: Session InitializeResponse
279 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
281 -- | Opens a text document and sends a notification to the client.
282 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
283 openDoc file languageId = do
284 item <- getDocItem file languageId
285 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
286 TextDocumentIdentifier <$> getDocUri file
288 -- | Reads in a text document as the first version.
289 getDocItem :: FilePath -- ^ The path to the text document to read in.
290 -> String -- ^ The language ID, e.g "haskell" for .hs files.
291 -> Session TextDocumentItem
292 getDocItem file languageId = do
294 let fp = rootDir context </> file
295 contents <- liftIO $ T.readFile fp
296 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
298 -- | Gets the Uri for the file corrected to the session directory.
299 getDocUri :: FilePath -> Session Uri
302 let fp = rootDir context </> file
303 return $ filePathToUri fp
305 -- | Waits for diagnostics to be published and returns them.
306 waitForDiagnostics :: Session [Diagnostic]
307 waitForDiagnostics = do
308 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
309 let (List diags) = diagsNot ^. params . LSP.diagnostics
312 waitForDiagnosticsSource :: String -> Session [Diagnostic]
313 waitForDiagnosticsSource src = do
314 diags <- waitForDiagnostics
315 let res = filter matches diags
317 then waitForDiagnosticsSource src
320 matches :: Diagnostic -> Bool
321 matches d = d ^. source == Just (T.pack src)
323 -- | Expects a 'PublishDiagnosticsNotification' and throws an
324 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
326 noDiagnostics :: Session ()
328 diagsNot <- message :: Session PublishDiagnosticsNotification
329 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
331 -- | Returns the symbols in a document.
332 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
333 getDocumentSymbols doc = do
334 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
335 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
336 let (Just (List symbols)) = mRes
339 -- | Returns all the code actions in a document by
340 -- querying the code actions at each of the current
341 -- diagnostics' positions.
342 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
343 getAllCodeActions doc = do
344 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
345 let ctx = CodeActionContext (List curDiags) Nothing
347 foldM (go ctx) [] curDiags
350 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
352 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
355 Just e -> throw (UnexpectedResponseError rspLid e)
357 let Just (List cmdOrCAs) = mRes
358 in return (acc ++ cmdOrCAs)
360 -- | Executes a command.
361 executeCommand :: Command -> Session ()
362 executeCommand cmd = do
363 let args = decode $ encode $ fromJust $ cmd ^. arguments
364 execParams = ExecuteCommandParams (cmd ^. command) args
365 sendRequest_ WorkspaceExecuteCommand execParams
367 -- | Executes a code action.
368 -- Matching with the specification, if a code action
369 -- contains both an edit and a command, the edit will
371 executeCodeAction :: CodeAction -> Session ()
372 executeCodeAction action = do
373 maybe (return ()) handleEdit $ action ^. edit
374 maybe (return ()) executeCommand $ action ^. command
376 where handleEdit :: WorkspaceEdit -> Session ()
378 -- Its ok to pass in dummy parameters here as they aren't used
379 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
380 in updateState (ReqApplyWorkspaceEdit req)
382 -- | Adds the current version to the document, as tracked by the session.
383 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
384 getVersionedDoc (TextDocumentIdentifier uri) = do
387 case fs Map.!? uri of
388 Just (VirtualFile v _) -> Just v
390 return (VersionedTextDocumentIdentifier uri ver)
392 -- | Applys an edit to the document and returns the updated document version.
393 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
394 applyEdit doc edit = do
396 verDoc <- getVersionedDoc doc
398 caps <- asks (capabilities . config)
400 let supportsDocChanges = fromMaybe False $ do
401 let LSP.ClientCapabilities mWorkspace _ _ = caps
402 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
403 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
406 let wEdit = if supportsDocChanges
408 let docEdit = TextDocumentEdit verDoc (List [edit])
409 in WorkspaceEdit Nothing (Just (List [docEdit]))
411 let changes = HashMap.singleton (doc ^. uri) (List [edit])
412 in WorkspaceEdit (Just changes) Nothing
414 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
415 updateState (ReqApplyWorkspaceEdit req)
417 -- version may have changed
420 -- | Returns the completions for the position in the document.
421 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
422 getCompletions doc pos = do
423 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
425 let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
426 (fromJust $ rsp ^. LSP.error)
427 res = fromMaybe exc (rsp ^. result)
429 Completions (List items) -> return items
430 CompletionList (CompletionListType _ (List items)) -> return items
432 getReferences :: TextDocumentIdentifier -> Position -> Bool -> Session [Location]
433 getReferences doc pos inclDecl =
434 let ctx = ReferenceContext inclDecl
435 params = ReferenceParams doc pos ctx
436 in fromMaybe [] . (^. result) <$> sendRequest TextDocumentReferences params