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
84 import Control.Applicative
85 import Control.Applicative.Combinators
86 import Control.Concurrent
88 import Control.Monad.IO.Class
89 import Control.Exception
90 import Control.Lens hiding ((.=), List)
91 import qualified Data.Text as T
92 import qualified Data.Text.IO as T
95 import qualified Data.HashMap.Strict as HashMap
96 import qualified Data.Map as Map
98 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
99 import qualified Language.Haskell.LSP.Types as LSP
100 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
101 import Language.Haskell.LSP.Messages
102 import Language.Haskell.LSP.VFS
103 import Language.Haskell.LSP.Test.Compat
104 import Language.Haskell.LSP.Test.Decoding
105 import Language.Haskell.LSP.Test.Exceptions
106 import Language.Haskell.LSP.Test.Parsing
107 import Language.Haskell.LSP.Test.Session
108 import Language.Haskell.LSP.Test.Server
110 import System.Directory
111 import System.FilePath
112 import qualified Yi.Rope as Rope
114 -- | Starts a new session.
115 runSession :: String -- ^ The command to run the server.
116 -> FilePath -- ^ The filepath to the root directory for the session.
117 -> Session a -- ^ The session to run.
119 runSession = runSessionWithConfig def
121 -- | Starts a new sesion with a client with the specified capabilities.
122 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
123 -> String -- ^ The command to run the server.
124 -> FilePath -- ^ The filepath to the root directory for the session.
125 -> Session a -- ^ The session to run.
127 runSessionWithConfig config serverExe rootDir session = do
128 pid <- getCurrentProcessID
129 absRootDir <- canonicalizePath rootDir
131 let initializeParams = InitializeParams (Just pid)
132 (Just $ T.pack absRootDir)
133 (Just $ filePathToUri absRootDir)
135 (capabilities config)
137 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
138 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
140 -- Wrap the session around initialize and shutdown calls
141 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
143 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
145 initRspVar <- initRsp <$> ask
146 liftIO $ putMVar initRspVar initRspMsg
148 sendNotification Initialized InitializedParams
150 -- Run the actual test
153 sendNotification Exit ExitParams
157 -- | Listens to the server output, makes sure it matches the record and
158 -- signals any semaphores
159 listenServer :: Handle -> SessionContext -> IO ()
160 listenServer serverOut context = do
161 msgBytes <- getNextMessage serverOut
163 reqMap <- readMVar $ requestMap context
165 let msg = decodeFromServerMsg reqMap msgBytes
166 writeChan (messageChan context) (ServerMessage msg)
168 listenServer serverOut context
170 -- | The current text contents of a document.
171 documentContents :: TextDocumentIdentifier -> Session T.Text
172 documentContents doc = do
174 let file = vfs Map.! (doc ^. uri)
175 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
177 -- | Parses an ApplyEditRequest, checks that it is for the passed document
178 -- and returns the new content
179 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
180 getDocumentEdit doc = do
181 req <- message :: Session ApplyWorkspaceEditRequest
183 unless (checkDocumentChanges req || checkChanges req) $
184 liftIO $ throw (IncorrectApplyEditRequestException (show req))
188 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
189 checkDocumentChanges req =
190 let changes = req ^. params . edit . documentChanges
191 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
193 Just docs -> (doc ^. uri) `elem` docs
195 checkChanges :: ApplyWorkspaceEditRequest -> Bool
197 let mMap = req ^. params . edit . changes
198 in maybe False (HashMap.member (doc ^. uri)) mMap
200 -- | Sends a request to the server and waits for its response.
202 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
204 -- Note: will skip any messages in between the request and the response.
205 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
206 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
208 -- | Send a request to the server and wait for its response,
210 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
211 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
213 -- | Sends a request to the server without waiting on the response.
216 => ClientMethod -- ^ The request method.
217 -> params -- ^ The request parameters.
218 -> Session LspId -- ^ The id of the request that was sent.
219 sendRequest' method params = do
220 id <- curReqId <$> get
221 modify $ \c -> c { curReqId = nextId id }
223 let req = RequestMessage' "2.0" id method params
225 -- Update the request map
226 reqMap <- requestMap <$> ask
227 liftIO $ modifyMVar_ reqMap $
228 \r -> return $ updateRequestMap r id method
234 where nextId (IdInt i) = IdInt (i + 1)
235 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
237 -- | A custom type for request message that doesn't
238 -- need a response type, allows us to infer the request
239 -- message type without using proxies.
240 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
242 instance ToJSON a => ToJSON (RequestMessage' a) where
243 toJSON (RequestMessage' rpc id method params) =
244 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
247 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
248 sendRequestMessage req = do
249 -- Update the request map
250 reqMap <- requestMap <$> ask
251 liftIO $ modifyMVar_ reqMap $
252 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
256 -- | Sends a notification to the server.
257 sendNotification :: ToJSON a
258 => ClientMethod -- ^ The notification method.
259 -> a -- ^ The notification parameters.
262 -- | Open a virtual file if we send a did open text document notification
263 sendNotification TextDocumentDidOpen params = do
264 let params' = fromJust $ decode $ encode params
265 n :: DidOpenTextDocumentNotification
266 n = NotificationMessage "2.0" TextDocumentDidOpen params'
267 oldVFS <- vfs <$> get
268 newVFS <- liftIO $ openVFS oldVFS n
269 modify (\s -> s { vfs = newVFS })
272 -- | Close a virtual file if we send a close text document notification
273 sendNotification TextDocumentDidClose params = do
274 let params' = fromJust $ decode $ encode params
275 n :: DidCloseTextDocumentNotification
276 n = NotificationMessage "2.0" TextDocumentDidClose params'
277 oldVFS <- vfs <$> get
278 newVFS <- liftIO $ closeVFS oldVFS n
279 modify (\s -> s { vfs = newVFS })
282 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
284 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
285 sendNotification' = sendMessage
287 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
288 sendResponse = sendMessage
290 -- | Returns the initialize response that was received from the server.
291 -- The initialize requests and responses are not included the session,
292 -- so if you need to test it use this.
293 initializeResponse :: Session InitializeResponse
294 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
296 -- | Opens a text document and sends a notification to the client.
297 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
298 openDoc file languageId = do
299 item <- getDocItem file languageId
300 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
301 TextDocumentIdentifier <$> getDocUri file
303 -- | Reads in a text document as the first version.
304 getDocItem :: FilePath -- ^ The path to the text document to read in.
305 -> String -- ^ The language ID, e.g "haskell" for .hs files.
306 -> Session TextDocumentItem
307 getDocItem file languageId = do
309 let fp = rootDir context </> file
310 contents <- liftIO $ T.readFile fp
311 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
313 -- | Gets the Uri for the file corrected to the session directory.
314 getDocUri :: FilePath -> Session Uri
317 let fp = rootDir context </> file
318 return $ filePathToUri fp
320 -- | Waits for diagnostics to be published and returns them.
321 waitForDiagnostics :: Session [Diagnostic]
322 waitForDiagnostics = do
323 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
324 let (List diags) = diagsNot ^. params . LSP.diagnostics
327 -- | Expects a 'PublishDiagnosticsNotification' and throws an
328 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
330 noDiagnostics :: Session ()
332 diagsNot <- message :: Session PublishDiagnosticsNotification
333 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
335 -- | Returns the symbols in a document.
336 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
337 getDocumentSymbols doc = do
338 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
339 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
340 let (Just (List symbols)) = mRes
343 -- | Returns all the code actions in a document by
344 -- querying the code actions at each of the current
345 -- diagnostics' positions.
346 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
347 getAllCodeActions doc = do
348 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
349 let ctx = CodeActionContext (List curDiags) Nothing
351 foldM (go ctx) [] curDiags
354 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
356 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
359 Just e -> throw (UnexpectedResponseError rspLid e)
361 let Just (List cmdOrCAs) = mRes
362 in return (acc ++ cmdOrCAs)
364 -- | Executes a command.
365 executeCommand :: Command -> Session ()
366 executeCommand cmd = do
367 let args = decode $ encode $ fromJust $ cmd ^. arguments
368 execParams = ExecuteCommandParams (cmd ^. command) args
369 sendRequest_ WorkspaceExecuteCommand execParams
371 -- | Executes a code action.
372 -- Matching with the specification, if a code action
373 -- contains both an edit and a command, the edit will
375 executeCodeAction :: CodeAction -> Session ()
376 executeCodeAction action = do
377 maybe (return ()) handleEdit $ action ^. edit
378 maybe (return ()) executeCommand $ action ^. command
380 where handleEdit :: WorkspaceEdit -> Session ()
382 -- Its ok to pass in dummy parameters here as they aren't used
383 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
384 in updateState (ReqApplyWorkspaceEdit req)
386 -- | Adds the current version to the document, as tracked by the session.
387 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
388 getVersionedDoc (TextDocumentIdentifier uri) = do
391 case fs Map.!? uri of
392 Just (VirtualFile v _) -> Just v
394 return (VersionedTextDocumentIdentifier uri ver)
396 -- | Applys an edit to the document and returns the updated document version.
397 applyEdit :: TextEdit -> TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
398 applyEdit edit doc = do
400 verDoc <- getVersionedDoc doc
402 caps <- asks (capabilities . config)
404 let supportsDocChanges = fromMaybe False $ do
405 let LSP.ClientCapabilities mWorkspace _ _ = caps
406 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
407 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
410 let wEdit = if supportsDocChanges
412 let docEdit = TextDocumentEdit verDoc (List [edit])
413 in WorkspaceEdit Nothing (Just (List [docEdit]))
415 let changes = HashMap.singleton (doc ^. uri) (List [edit])
416 in WorkspaceEdit (Just changes) Nothing
418 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
419 updateState (ReqApplyWorkspaceEdit req)
421 -- version may have changed