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
156 let file = vfs Map.! (doc ^. uri)
157 return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
159 -- | Parses an ApplyEditRequest, checks that it is for the passed document
160 -- and returns the new content
161 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
162 getDocumentEdit doc = do
163 req <- message :: Session ApplyWorkspaceEditRequest
165 unless (checkDocumentChanges req || checkChanges req) $
166 liftIO $ throw (IncorrectApplyEditRequest (show req))
170 checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
171 checkDocumentChanges req =
172 let changes = req ^. params . edit . documentChanges
173 maybeDocs = fmap (fmap (^. textDocument . uri)) changes
175 Just docs -> (doc ^. uri) `elem` docs
177 checkChanges :: ApplyWorkspaceEditRequest -> Bool
179 let mMap = req ^. params . edit . changes
180 in maybe False (HashMap.member (doc ^. uri)) mMap
182 -- | Sends a request to the server and waits for its response.
184 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
186 -- Note: will skip any messages in between the request and the response.
187 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
188 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
190 -- | Send a request to the server and wait for its response,
192 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
193 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
195 -- | Sends a request to the server without waiting on the response.
198 => ClientMethod -- ^ The request method.
199 -> params -- ^ The request parameters.
200 -> Session LspId -- ^ The id of the request that was sent.
201 sendRequest' method params = do
202 id <- curReqId <$> get
203 modify $ \c -> c { curReqId = nextId id }
205 let req = RequestMessage' "2.0" id method params
207 -- Update the request map
208 reqMap <- requestMap <$> ask
209 liftIO $ modifyMVar_ reqMap $
210 \r -> return $ updateRequestMap r id method
216 where nextId (IdInt i) = IdInt (i + 1)
217 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
219 -- | A custom type for request message that doesn't
220 -- need a response type, allows us to infer the request
221 -- message type without using proxies.
222 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
224 instance ToJSON a => ToJSON (RequestMessage' a) where
225 toJSON (RequestMessage' rpc id method params) =
226 object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
229 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
230 sendRequestMessage req = do
231 -- Update the request map
232 reqMap <- requestMap <$> ask
233 liftIO $ modifyMVar_ reqMap $
234 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
238 -- | Sends a notification to the server.
239 sendNotification :: ToJSON a
240 => ClientMethod -- ^ The notification method.
241 -> a -- ^ The notification parameters.
244 -- | Open a virtual file if we send a did open text document notification
245 sendNotification TextDocumentDidOpen params = do
246 let params' = fromJust $ decode $ encode params
247 n :: DidOpenTextDocumentNotification
248 n = NotificationMessage "2.0" TextDocumentDidOpen params'
249 oldVFS <- vfs <$> get
250 newVFS <- liftIO $ openVFS oldVFS n
251 modify (\s -> s { vfs = newVFS })
254 -- | Close a virtual file if we send a close text document notification
255 sendNotification TextDocumentDidClose params = do
256 let params' = fromJust $ decode $ encode params
257 n :: DidCloseTextDocumentNotification
258 n = NotificationMessage "2.0" TextDocumentDidClose params'
259 oldVFS <- vfs <$> get
260 newVFS <- liftIO $ closeVFS oldVFS n
261 modify (\s -> s { vfs = newVFS })
264 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
266 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
267 sendNotification' = sendMessage
269 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
270 sendResponse = sendMessage
272 -- | Returns the initialize response that was received from the server.
273 -- The initialize requests and responses are not included the session,
274 -- so if you need to test it use this.
275 initializeResponse :: Session InitializeResponse
276 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
278 -- | Opens a text document and sends a notification to the client.
279 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
280 openDoc file languageId = do
281 item <- getDocItem file languageId
282 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
283 TextDocumentIdentifier <$> getDocUri file
285 -- | Reads in a text document as the first version.
286 getDocItem :: FilePath -- ^ The path to the text document to read in.
287 -> String -- ^ The language ID, e.g "haskell" for .hs files.
288 -> Session TextDocumentItem
289 getDocItem file languageId = do
291 let fp = rootDir context </> file
292 contents <- liftIO $ T.readFile fp
293 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
295 -- | Gets the Uri for the file corrected to the session directory.
296 getDocUri :: FilePath -> Session Uri
299 let fp = rootDir context </> file
300 return $ filePathToUri fp
302 -- | Waits for diagnostics to be published and returns them.
303 waitForDiagnostics :: Session [Diagnostic]
304 waitForDiagnostics = do
305 diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
306 let (List diags) = diagsNot ^. params . LSP.diagnostics
309 -- | Expects a 'PublishDiagnosticsNotification' and throws an
310 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
312 noDiagnostics :: Session ()
314 diagsNot <- message :: Session PublishDiagnosticsNotification
315 when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
317 -- | Returns the symbols in a document.
318 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
319 getDocumentSymbols doc = do
320 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
321 maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
322 let (Just (List symbols)) = mRes
325 -- | Returns all the code actions in a document by
326 -- querying the code actions at each of the current
327 -- diagnostics' positions.
328 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
329 getAllCodeActions doc = do
330 curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
331 let ctx = CodeActionContext (List curDiags) Nothing
333 foldM (go ctx) [] curDiags
336 go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
338 ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
341 Just e -> throw (UnexpectedResponseError rspLid e)
343 let Just (List cmdOrCAs) = mRes
344 in return (acc ++ cmdOrCAs)
346 -- | Executes a command.
347 executeCommand :: Command -> Session ()
348 executeCommand cmd = do
349 let args = decode $ encode $ fromJust $ cmd ^. arguments
350 execParams = ExecuteCommandParams (cmd ^. command) args
351 sendRequest_ WorkspaceExecuteCommand execParams
353 -- | Executes a code action.
354 -- Matching with the specification, if a code action
355 -- contains both an edit and a command, the edit will
357 executeCodeAction :: CodeAction -> Session ()
358 executeCodeAction action = do
359 maybe (return ()) handleEdit $ action ^. edit
360 maybe (return ()) executeCommand $ action ^. command
362 where handleEdit :: WorkspaceEdit -> Session ()
364 -- Its ok to pass in dummy parameters here as they aren't used
365 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
366 in updateState (ReqApplyWorkspaceEdit req)
368 -- | Adds the current version to the document, as tracked by the session.
369 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
370 getVersionedDoc (TextDocumentIdentifier uri) = do
373 case fs Map.!? uri of
374 Just (VirtualFile v _) -> Just v
376 return (VersionedTextDocumentIdentifier uri ver)
378 -- | Applys an edit to the document and returns the updated document version.
379 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
380 applyEdit doc edit = do
382 verDoc <- getVersionedDoc doc
384 caps <- asks (capabilities . config)
386 let supportsDocChanges = fromMaybe False $ do
387 let LSP.ClientCapabilities mWorkspace _ _ = caps
388 LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
389 LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
392 let wEdit = if supportsDocChanges
394 let docEdit = TextDocumentEdit verDoc (List [edit])
395 in WorkspaceEdit Nothing (Just (List [docEdit]))
397 let changes = HashMap.singleton (doc ^. uri) (List [edit])
398 in WorkspaceEdit (Just changes) Nothing
400 let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
401 updateState (ReqApplyWorkspaceEdit req)
403 -- version may have changed
406 -- | Returns the completions for the position in the document.
407 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
408 getCompletions doc pos = do
409 rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
411 let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
412 (fromJust $ rsp ^. LSP.error)
413 res = fromMaybe exc (rsp ^. result)
415 Completions (List items) -> return items
416 CompletionList (CompletionListType _ (List items)) -> return items