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
86 import Control.Applicative
87 import Control.Applicative.Combinators
88 import Control.Concurrent
90 import Control.Monad.IO.Class
91 import Control.Exception
92 import Control.Lens hiding ((.=), List)
93 import qualified Data.Text as T
94 import qualified Data.Text.IO as T
97 import qualified Data.HashMap.Strict as HashMap
98 import qualified Data.Map as Map
100 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
101 import qualified Language.Haskell.LSP.Types as LSP
102 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
103 import Language.Haskell.LSP.Messages
104 import Language.Haskell.LSP.VFS
105 import Language.Haskell.LSP.Test.Compat
106 import Language.Haskell.LSP.Test.Decoding
107 import Language.Haskell.LSP.Test.Exceptions
108 import Language.Haskell.LSP.Test.Parsing
109 import Language.Haskell.LSP.Test.Session
110 import Language.Haskell.LSP.Test.Server
112 import System.Directory
113 import System.FilePath
114 import qualified Yi.Rope as Rope
116 -- | Starts a new session.
117 runSession :: String -- ^ The command to run the server.
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 client with the specified capabilities.
124 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
125 -> String -- ^ The command to run the server.
126 -> FilePath -- ^ The filepath to the root directory for the session.
127 -> Session a -- ^ The session to run.
129 runSessionWithConfig config serverExe rootDir session = do
130 pid <- getCurrentProcessID
131 absRootDir <- canonicalizePath rootDir
133 let initializeParams = InitializeParams (Just pid)
134 (Just $ T.pack absRootDir)
135 (Just $ filePathToUri absRootDir)
137 (capabilities config)
139 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
140 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
142 -- Wrap the session around initialize and shutdown calls
143 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
145 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
147 initRspVar <- initRsp <$> ask
148 liftIO $ putMVar initRspVar initRspMsg
150 sendNotification Initialized InitializedParams
152 -- Run the actual test
155 sendNotification Exit ExitParams
159 -- | Listens to the server output, makes sure it matches the record and
160 -- signals any semaphores
161 listenServer :: Handle -> SessionContext -> IO ()
162 listenServer serverOut context = do
163 msgBytes <- getNextMessage serverOut
165 reqMap <- readMVar $ requestMap context
167 let msg = decodeFromServerMsg reqMap msgBytes
168 writeChan (messageChan context) (ServerMessage msg)
170 listenServer serverOut context
172 -- | The current text contents of a document.
173 documentContents :: TextDocumentIdentifier -> Session T.Text
174 documentContents doc = do
176 let file = vfs Map.! (doc ^. uri)
177 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
179 -- | Parses an ApplyEditRequest, checks that it is for the passed document
180 -- and returns the new content
181 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
182 getDocumentEdit doc = do
183 req <- message :: Session ApplyWorkspaceEditRequest
185 unless (checkDocumentChanges req || checkChanges req) $
186 liftIO $ throw (IncorrectApplyEditRequest (show req))
190 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
191 checkDocumentChanges req =
192 let changes = req ^. params . edit . documentChanges
193 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
195 Just docs -> (doc ^. uri) `elem` docs
197 checkChanges :: ApplyWorkspaceEditRequest -> Bool
199 let mMap = req ^. params . edit . changes
200 in maybe False (HashMap.member (doc ^. uri)) mMap
202 -- | Sends a request to the server and waits for its response.
204 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
206 -- Note: will skip any messages in between the request and the response.
207 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
208 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
210 -- | Send a request to the server and wait for its response,
212 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
213 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
215 -- | Sends a request to the server without waiting on the response.
218 => ClientMethod -- ^ The request method.
219 -> params -- ^ The request parameters.
220 -> Session LspId -- ^ The id of the request that was sent.
221 sendRequest' method params = do
222 id <- curReqId <$> get
223 modify $ \c -> c { curReqId = nextId id }
225 let req = RequestMessage' "2.0" id method params
227 -- Update the request map
228 reqMap <- requestMap <$> ask
229 liftIO $ modifyMVar_ reqMap $
230 \r -> return $ updateRequestMap r id method
236 where nextId (IdInt i) = IdInt (i + 1)
237 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
239 -- | A custom type for request message that doesn't
240 -- need a response type, allows us to infer the request
241 -- message type without using proxies.
242 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
244 instance ToJSON a => ToJSON (RequestMessage' a) where
245 toJSON (RequestMessage' rpc id method params) =
246 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
249 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
250 sendRequestMessage req = do
251 -- Update the request map
252 reqMap <- requestMap <$> ask
253 liftIO $ modifyMVar_ reqMap $
254 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
258 -- | Sends a notification to the server.
259 sendNotification :: ToJSON a
260 => ClientMethod -- ^ The notification method.
261 -> a -- ^ The notification parameters.
264 -- | Open a virtual file if we send a did open text document notification
265 sendNotification TextDocumentDidOpen params = do
266 let params' = fromJust $ decode $ encode params
267 n :: DidOpenTextDocumentNotification
268 n = NotificationMessage "2.0" TextDocumentDidOpen params'
269 oldVFS <- vfs <$> get
270 newVFS <- liftIO $ openVFS oldVFS n
271 modify (\s -> s { vfs = newVFS })
274 -- | Close a virtual file if we send a close text document notification
275 sendNotification TextDocumentDidClose params = do
276 let params' = fromJust $ decode $ encode params
277 n :: DidCloseTextDocumentNotification
278 n = NotificationMessage "2.0" TextDocumentDidClose params'
279 oldVFS <- vfs <$> get
280 newVFS <- liftIO $ closeVFS oldVFS n
281 modify (\s -> s { vfs = newVFS })
284 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
286 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
287 sendNotification' = sendMessage
289 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
290 sendResponse = sendMessage
292 -- | Returns the initialize response that was received from the server.
293 -- The initialize requests and responses are not included the session,
294 -- so if you need to test it use this.
295 initializeResponse :: Session InitializeResponse
296 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
298 -- | Opens a text document and sends a notification to the client.
299 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
300 openDoc file languageId = do
301 item <- getDocItem file languageId
302 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
303 TextDocumentIdentifier <$> getDocUri file
305 -- | Reads in a text document as the first version.
306 getDocItem :: FilePath -- ^ The path to the text document to read in.
307 -> String -- ^ The language ID, e.g "haskell" for .hs files.
308 -> Session TextDocumentItem
309 getDocItem file languageId = do
311 let fp = rootDir context </> file
312 contents <- liftIO $ T.readFile fp
313 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
315 -- | Gets the Uri for the file corrected to the session directory.
316 getDocUri :: FilePath -> Session Uri
319 let fp = rootDir context </> file
320 return $ filePathToUri fp
322 -- | Waits for diagnostics to be published and returns them.
323 waitForDiagnostics :: Session [Diagnostic]
324 waitForDiagnostics = do
325 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
326 let (List diags) = diagsNot ^. params . LSP.diagnostics
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 let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
432 (fromJust $ rsp ^. LSP.error)
433 res = fromMaybe exc (rsp ^. result)
435 Completions (List items) -> return items
436 CompletionList (CompletionListType _ (List items)) -> return items