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
67 import Control.Applicative.Combinators
68 import Control.Concurrent
70 import Control.Monad.IO.Class
71 import Control.Exception
72 import Control.Lens hiding ((.=), List)
73 import qualified Data.Text as T
74 import qualified Data.Text.IO as T
77 import qualified Data.HashMap.Strict as HashMap
78 import qualified Data.Map as Map
80 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
81 import qualified Language.Haskell.LSP.Types as LSP
82 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
83 import Language.Haskell.LSP.Messages
84 import Language.Haskell.LSP.VFS
85 import Language.Haskell.LSP.Test.Compat
86 import Language.Haskell.LSP.Test.Decoding
87 import Language.Haskell.LSP.Test.Exceptions
88 import Language.Haskell.LSP.Test.Parsing
89 import Language.Haskell.LSP.Test.Session
90 import Language.Haskell.LSP.Test.Server
92 import System.Directory
93 import System.FilePath
94 import qualified Yi.Rope as Rope
96 -- | Starts a new session.
97 runSession :: String -- ^ The command to run the server.
98 -> FilePath -- ^ The filepath to the root directory for the session.
99 -> Session a -- ^ The session to run.
101 runSession = runSessionWithConfig def
103 -- | Starts a new sesion with a client with the specified capabilities.
104 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
105 -> String -- ^ The command to run the server.
106 -> FilePath -- ^ The filepath to the root directory for the session.
107 -> Session a -- ^ The session to run.
109 runSessionWithConfig config serverExe rootDir session = do
110 pid <- getCurrentProcessID
111 absRootDir <- canonicalizePath rootDir
113 let initializeParams = InitializeParams (Just pid)
114 (Just $ T.pack absRootDir)
115 (Just $ filePathToUri absRootDir)
117 (capabilities config)
119 withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
120 runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
122 -- Wrap the session around initialize and shutdown calls
123 initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
125 liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
127 initRspVar <- initRsp <$> ask
128 liftIO $ putMVar initRspVar initRspMsg
130 sendNotification Initialized InitializedParams
132 -- Run the actual test
135 sendNotification Exit ExitParams
139 -- | Listens to the server output, makes sure it matches the record and
140 -- signals any semaphores
141 listenServer :: Handle -> SessionContext -> IO ()
142 listenServer serverOut context = do
143 msgBytes <- getNextMessage serverOut
145 reqMap <- readMVar $ requestMap context
147 let msg = decodeFromServerMsg reqMap msgBytes
148 writeChan (messageChan context) (ServerMessage msg)
150 listenServer serverOut context
152 -- | The current text contents of a document.
153 documentContents :: TextDocumentIdentifier -> Session T.Text
154 documentContents doc = do
158 let file = vfs Map.! (doc ^. uri)
159 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
161 -- | Parses an ApplyEditRequest, checks that it is for the passed document
162 -- and returns the new content
163 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
164 getDocumentEdit doc = do
165 req <- message :: Session ApplyWorkspaceEditRequest
167 unless (checkDocumentChanges req || checkChanges req) $
168 liftIO $ throw (IncorrectApplyEditRequest (show req))
172 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
173 checkDocumentChanges req =
174 let changes = req ^. params . edit . documentChanges
175 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
177 Just docs -> (doc ^. uri) `elem` docs
179 checkChanges :: ApplyWorkspaceEditRequest -> Bool
181 let mMap = req ^. params . edit . changes
182 in maybe False (HashMap.member (doc ^. uri)) mMap
184 -- | Sends a request to the server and waits for its response.
186 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
188 -- Note: will skip any messages in between the request and the response.
189 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
190 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
192 -- | Send a request to the server and wait for its response,
194 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
195 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
197 -- | Sends a request to the server without waiting on the response.
200 => ClientMethod -- ^ The request method.
201 -> params -- ^ The request parameters.
202 -> Session LspId -- ^ The id of the request that was sent.
203 sendRequest' method params = do
204 id <- curReqId <$> get
205 modify $ \c -> c { curReqId = nextId id }
207 let req = RequestMessage' "2.0" id method params
209 -- Update the request map
210 reqMap <- requestMap <$> ask
211 liftIO $ modifyMVar_ reqMap $
212 \r -> return $ updateRequestMap r id method
218 where nextId (IdInt i) = IdInt (i + 1)
219 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
221 -- | A custom type for request message that doesn't
222 -- need a response type, allows us to infer the request
223 -- message type without using proxies.
224 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
226 instance ToJSON a => ToJSON (RequestMessage' a) where
227 toJSON (RequestMessage' rpc id method params) =
228 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
231 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
232 sendRequestMessage req = do
233 -- Update the request map
234 reqMap <- requestMap <$> ask
235 liftIO $ modifyMVar_ reqMap $
236 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
240 -- | Sends a notification to the server.
241 sendNotification :: ToJSON a
242 => ClientMethod -- ^ The notification method.
243 -> a -- ^ The notification parameters.
246 -- | Open a virtual file if we send a did open text document notification
247 sendNotification TextDocumentDidOpen params = do
248 let params' = fromJust $ decode $ encode params
249 n :: DidOpenTextDocumentNotification
250 n = NotificationMessage "2.0" TextDocumentDidOpen params'
251 oldVFS <- vfs <$> get
252 newVFS <- liftIO $ openVFS oldVFS n
253 modify (\s -> s { vfs = newVFS })
256 -- | Close a virtual file if we send a close text document notification
257 sendNotification TextDocumentDidClose params = do
258 let params' = fromJust $ decode $ encode params
259 n :: DidCloseTextDocumentNotification
260 n = NotificationMessage "2.0" TextDocumentDidClose params'
261 oldVFS <- vfs <$> get
262 newVFS <- liftIO $ closeVFS oldVFS n
263 modify (\s -> s { vfs = newVFS })
266 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
268 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
269 sendNotification' = sendMessage
271 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
272 sendResponse = sendMessage
274 -- | Returns the initialize response that was received from the server.
275 -- The initialize requests and responses are not included the session,
276 -- so if you need to test it use this.
277 initializeResponse :: Session InitializeResponse
278 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
280 -- | Opens a text document and sends a notification to the client.
281 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
282 openDoc file languageId = do
283 item <- getDocItem file languageId
284 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
285 TextDocumentIdentifier <$> getDocUri file
287 -- | Reads in a text document as the first version.
288 getDocItem :: FilePath -- ^ The path to the text document to read in.
289 -> String -- ^ The language ID, e.g "haskell" for .hs files.
290 -> Session TextDocumentItem
291 getDocItem file languageId = do
293 let fp = rootDir context </> file
294 contents <- liftIO $ T.readFile fp
295 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
297 -- | Gets the Uri for the file corrected to the session directory.
298 getDocUri :: FilePath -> Session Uri
301 let fp = rootDir context </> file
302 return $ filePathToUri fp
304 -- | Waits for diagnostics to be published and returns them.
305 waitForDiagnostics :: Session [Diagnostic]
306 waitForDiagnostics = do
307 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
308 let (List diags) = diagsNot ^. params . LSP.diagnostics
311 -- | Expects a 'PublishDiagnosticsNotification' and throws an
312 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
314 noDiagnostics :: Session ()
316 diagsNot <- message :: Session PublishDiagnosticsNotification
317 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
319 -- | Returns the symbols in a document.
320 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
321 getDocumentSymbols doc = do
322 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
323 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
324 let (Just (List symbols)) = mRes
327 -- | Returns all the code actions in a document by
328 -- querying the code actions at each of the current
329 -- diagnostics' positions.
330 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
331 getAllCodeActions doc = do
332 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
333 let ctx = CodeActionContext (List curDiags) Nothing
335 foldM (go ctx) [] curDiags
338 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
340 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
343 Just e -> throw (UnexpectedResponseError rspLid e)
345 let Just (List cmdOrCAs) = mRes
346 in return (acc ++ cmdOrCAs)
348 -- | Executes a command.
349 executeCommand :: Command -> Session ()
350 executeCommand cmd = do
351 let args = decode $ encode $ fromJust $ cmd ^. arguments
352 execParams = ExecuteCommandParams (cmd ^. command) args
353 sendRequest_ WorkspaceExecuteCommand execParams
355 -- | Executes a code action.
356 -- Matching with the specification, if a code action
357 -- contains both an edit and a command, the edit will
359 executeCodeAction :: CodeAction -> Session ()
360 executeCodeAction action = do
361 maybe (return ()) handleEdit $ action ^. edit
362 maybe (return ()) executeCommand $ action ^. command
364 where handleEdit :: WorkspaceEdit -> Session ()
366 -- Its ok to pass in dummy parameters here as they aren't used
367 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
368 in updateState (ReqApplyWorkspaceEdit req)
370 -- | Adds the current version to the document, as tracked by the session.
371 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
372 getVersionedDoc (TextDocumentIdentifier uri) = do
375 case fs Map.!? uri of
376 Just (VirtualFile v _) -> Just v
378 return (VersionedTextDocumentIdentifier uri ver)
380 -- | Applys an edit to the document and returns the updated document version.
381 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
382 applyEdit doc edit = do
384 verDoc <- getVersionedDoc doc
386 caps <- asks (capabilities . config)
388 let supportsDocChanges = fromMaybe False $ do
389 let LSP.ClientCapabilities mWorkspace _ _ = caps
390 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
391 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
394 let wEdit = if supportsDocChanges
396 let docEdit = TextDocumentEdit verDoc (List [edit])
397 in WorkspaceEdit Nothing (Just (List [docEdit]))
399 let changes = HashMap.singleton (doc ^. uri) (List [edit])
400 in WorkspaceEdit (Just changes) Nothing
402 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
403 updateState (ReqApplyWorkspaceEdit req)
405 -- version may have changed
408 -- | Returns the completions for the position in the document.
409 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
410 getCompletions doc pos = do
411 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
413 let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
414 (fromJust $ rsp ^. LSP.error)
415 res = fromMaybe exc (rsp ^. result)
417 Completions (List items) -> return items
418 CompletionList (CompletionListType _ (List items)) -> return items